Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/stp/stp1.for
There is 1 other file named stp1.for in the archive. Click here to see a list.
C *** STAT PACK ***
C SUBROUTINE FOR FREQUENCIES
C CALLING SEQUENCE: CALL STFREQ(NV,NC,MV,MC,DATA,AV,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C AV - EXTRAL VECTOR AT LEAST AS LONG AS NC
C NAMES - A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM MAKES USE OF A SORT TECHNIQUE SPECIFIED IN ACM OF 1970
C TO PUT THENUMBERS IN ORDER, IN THE AV VECTOR; ALLOWING THE DATA
C MATRIX (DATA) TO REMAIN UNCHANGED. ONCE THE SORT IS COMPLETED
C IT IS A SIMPLE TASK TO FORM FREQUENCIES, OR FREQUENCIES AND
C PERCENTS.
C
SUBROUTINE STFREQ(NV,NC,MV,MC,DATA,AV,NAMES)
DIMENSION DATA(MC,MV),IX(40),AV(1),IV(12),XV(12),NAMES(1)
C FOLLLOWING DIMENSION OF USE IN SORT ONLY. IU(K) AND IL(K)
C WILL SORT UP TO 2**(K-1)-1 ELEMENTS
DIMENSION IU(16),IL(16)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
DASH='-----'
ISQ=5
IF(IOUT.EQ.21) ISQ=12
ALL=0
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT('0DO YOU ALSO WANT PERCENTAGES (YES OR NO)? ',$)
READ (ICC,3)ANS
3 FORMAT(A3)
IF(ANS.EQ.'YES') GO TO 4
IF(ANS.EQ.'NO') GO TO 4
IF(ANS.EQ.'!') RETURN
WRITE(IDLG,5)
5 FORMAT('0ANSWER EITHER YES OR NO')
GO TO 1
4 IF(ICC.NE.2) WRITE(IDLG,6)
6 FORMAT('0WHICH VARIABLES? ',$)
CALL ALPHA(IX,40,NN,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 4
IF(IHELP.NE.1) GO TO 8
WRITE(IDLG,7)
7 FORMAT(' ENTER THE VAR. NUMBERS OR NAMES FOR WHCIH FREQUENCIES'/
1' ARE TO BE CALCULATED, SEPARATED BY COMMAS. RANGES OF'/
2' VARIABLES MAY BE SPECIFIED BY ENTERING THE EXTREMES OF THE'/
3' RANGE SEPARATED BY A MINUS. ALL VARIABLES MAY BE SPECIFIED'/
4' BY ENTERING A *, OR THE WORD "ALL".')
GO TO 4
8 DO 9 I=1,NN
IF(IX(I).GE.0) GO TO 9
ALL=1
NN=NV
GO TO 13
9 CONTINUE
13 IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
IF(ANS.EQ.'YES') WRITE(IOUT,57)(DASH,DASH,J=1,ISQ)
IF(ANS.NE.'YES') WRITE(IOUT,40)(DASH,DASH,J=1,ISQ)
40 FORMAT('0VAR.',20X,'FREQUENCY'/1X,5('-'),2X,5('-'),24A5)
57 FORMAT('0VAR.',15X,'FREQUENCY AND PERCENTAGES'/1X,
15('-'),2X,5('-'),24A5)
LINES=5
C ***********************************************************
C PARTITIONING METHOD OF SORTING AS FOUND IN ACM.
C
DO 11 I=1,NN
IF(ALL.NE.1) IVAR=IX(I)
IF(ALL.EQ.1) IVAR=I
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) 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
90 IF(I.EQ.1) GO TO 43
IF(IOUT.NE.21) GO TO 58
IF(LINES+1.GT.LINPP) GO TO 43
LINES=LINES+1
58 WRITE(IOUT,41)
41 FORMAT(/)
43 LL=1
COM=AV(1)
XV(1)=AV(1)
42 IV(1)=1
IF(NC.EQ.1) GO TO 53
DO 44 J=2,NC
IF(COM.EQ.AV(J)) GO TO 44
COM=AV(J)
LL=LL+1
IF(LL.LE.ISQ) GO TO 52
IF(IOUT.NE.21) GO TO 59
IF(ANS.NE.'YES'.AND.LINES+3.LE.LINPP)GO TO 59
IF(ANS.EQ.'YES'.AND.LINES+4.LE.LINPP)GO TO 59
CALL PRNTHD
IF(ANS.EQ.'YES')WRITE(IOUT,57)(DASH,DASH,K=1,ISQ)
IF(ANS.NE.'YES')WRITE(IOUT,40)(DASH,DASH,K=1,ISQ)
LINES=5
IF(ANS.EQ.'YES')LINES=LINES+1
IF(LINES.LE.LINPP)GO TO 59
59 IF(XV(1).EQ.AV(1)) WRITE(IOUT,45) NAMES(IVAR),(XV(K),K=1,ISQ)
IF(XV(1).NE.AV(1)) WRITE(IOUT,46)(XV(K),K=1,ISQ)
WRITE(IOUT,47)(IV(K),K=1,ISQ)
45 FORMAT('0',A5,2X,'VALUE',12(1X,G9.3))
46 FORMAT('0',7X,'VALUE',12(1X,G9.3))
47 FORMAT(8X,'FREQ',1X,12(I5,5X))
LINES=LINES+3
IF(ANS.NE.'YES') GO TO 50
Y=NC
DO 48 K=1,ISQ
Z=IV(K)
48 XV(K)=Z/Y*100.
WRITE(IOUT,49)(XV(K),K=1,ISQ)
49 FORMAT(8X,'%',4X,12(F6.1,1H%,3X))
LINES=LINES+1
50 LL=1
52 XV(LL)=AV(J)
IV(LL)=0
44 IV(LL)=IV(LL)+1
53 IF(IOUT.NE.21) GO TO 60
IF(ANS.NE.'YES'.AND.LINES+3.LE.LINPP)GO TO 60
IF(ANS.EQ.'YES'.AND.LINES+4.LE.LINPP)GO TO 60
CALL PRNTHD
IF(ANS.EQ.'YES')WRITE(IOUT,57)(DASH,DASH,K=1,ISQ)
IF(ANS.NE.'YES')WRITE(IOUT,40)(DASH,DASH,K=1,ISQ)
LINES=5
IF(ANS.EQ.'YES')LINES=LINES+1
IF(LINES.LE.LINPP)GO TO 60
60 IF(XV(1).EQ.AV(1)) WRITE(IOUT,45) NAMES(IVAR),(XV(K),K=1,LL)
IF(XV(1).NE.AV(1)) WRITE(IOUT,46)(XV(K),K=1,LL)
WRITE(IOUT,47)(IV(K),K=1,LL)
LINES=LINES+3
IF(ANS.NE.'YES') GO TO 11
Y=NC
DO 56 K=1,LL
Z=IV(K)
56 XV(K)=Z/Y*100.
WRITE(IOUT,49)(XV(K),K=1,LL)
LINES=LINES+1
11 CONTINUE
RETURN
END
C *** STAT PACK ***
C SUBROUTINE FOR HISTOGRAM, LEVELS BASED ON STRICT PERCENTAGES.
C CALLING SEQUENCE: CALL HIST(NV,NC,MV,MC,DATA,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C NAMES- IS A VECTOR CONTAINING VARIABLE NAMES
C
C HISTOGRAM IS BASED ON DATA BEING BROKEN INTO 8 GROUPS WITH
C 20 INCREMENTS OF HEIGHT FOR EACH GROUP. IF OUTPUT HAS BEEN
C ASSIGNEDTHERE ARE 20 GROUPS WITH 40 INCREMENTS OF HEIGHT.
C TO CREATE THE HISTOGRAM THE RANGE OF THE VARIABLE IS DIVIDED BY
C THE NUMBER OF GROUPS, THIS IS SCALED BY POWERS OF 10 TIMES 5, 2.5,
C 2.0, OR 1. NEXT THE NUMBER OF OBSERVATIONS WHICH FALL INTO EACH
C GROUP IS DETERMINED AND THE RESPCETIVE PERCENTAGES CALCULATED
C AND SCALED. IF ANY SPACE EXISTS WHICH DOES NOT CONTAIN POINTS,
C IT IS SURPRESSED IN THE OUTPUT. OUTPUT IS CREATED 1 LINE AT A
C TIME AND OUTPUT, EACH LINE USING THE SAME AREA AS ALL PREVIOUS
C LINES.
C
SUBROUTINE HIST(NV,NC,MV,MC,DATA,NAMES)
DIMENSION DATA(MC,MV),XCT(25),GOUT(51),ICT(25),NAMES(1),IVB(20)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /EXTRA/HEDR(70),NSZ
ARROW='^'
MINUS='-----'
PLUS='+'
IDIV=20
NDIV=8
IF(IOUT.EQ.21) NDIV=20
IF(IOUT.EQ.21) IDIV=40
ALL=0
2 IF(ICC.NE.2) WRITE(IDLG,1)
1 FORMAT('0WHICH VARIABLES? ',$)
CALL ALPHA(IVB,20,NN,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 2
IF(IHELP.NE.1) GO TO 35
WRITE(IDLG,36)
36 FORMAT(' TYPE IN THE VARIABLE NUMBER TO BE USED FOR THE'/
1'HISTOGRAM. IF A HISTOGRAM FOR EACH VARIABLE IS DESIRED TYPE'/
2'"ALL". TO RETURN TYPE "!".')
GO TO 2
35 DO 4 I=1,NN
IF(IVB(I).GT.0) GO TO 4
ALL=1
NN=NV
GO TO 37
4 CONTINUE
37 DO 50 IKJ=1,NN
N=IVB(IKJ)
IF(ALL.EQ.1) N=IKJ
30 AMAX=DATA(1,N)
AMIN=DATA(1,N)
DO 6 I=2,NC
IF(DATA(I,N).GT.AMAX)AMAX=DATA(I,N)
IF(DATA(I,N).LT.AMIN)AMIN=DATA(I,N)
6 CONTINUE
RANGE=AMAX-AMIN
DEGREE=RANGE/NDIV
IF(DEGREE.LE.0) DEGREE=1.0
B=ALOG10(DEGREE)
M=B
B=B-M
IF(B.GE.0) GO TO 27
M=M-1
B=B+1
27 C=10.**B
D=10.
IF(C.LE.5.0) D=5.
IF(C.LE.2.5) D=2.5
IF(C.LE.2.0) D=2.0
IF(C.LE.1.0) D=1.0
DEGREE=D*10.**M
DO 7 I=1,NDIV
7 XCT(I)=0
DO 8 I=1,NC
J=(DATA(I,N)-AMIN)/DEGREE+1.0
IF(J.GT.NDIV) J=NDIV
8 XCT(J)=XCT(J)+1.
XMAX=0
DO 9 I=1,NDIV
ICT(I)=XCT(I)+.1
XCT(I)=(XCT(I)/NC)*100.
IF(XCT(I).GT.XMAX) XMAX=XCT(I)
9 CONTINUE
DO 28 KK=NDIV,1,-1
IF(XCT(KK).NE.0) GO TO 29
28 CONTINUE
29 XMM=100.
IF(XMAX.LE.80.) XMM=80.
IF(XMAX.LE.60.) XMM=60.
IF(XMAX.LE.50.) XMM=50.
IF(XMAX.LE.40.) XMM=40.
IF(XMAX.LE.20.) XMM=20.
IF(XMAX.LE.10.) XMM=10.
IF(XMAX.LE.8.) XMM=8.
IF(XMAX.LE.6.) XMM=6.
IF(XMAX.LE.4.) XMM=4.
XDIV=XMM/IDIV
LL=IDIV/4
XROUND=XDIV/2.
LM=KK*2+1
DO 10 I=1,LM
10 GOUT(I)=' '
IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(I),I=1,NSZ)
IF(IOUT.EQ.21) CALL PRNTHD
5566 FORMAT('1',70A1)
WRITE(IOUT,20)NAMES(N)
20 FORMAT('0',10X,'***** HISTOGRAM FOR VARIABLE: ',A5,' *****'//)
DO 11 I=0,IDIV-1
PL=XMM-XDIV*I
DO 12 J=1,KK
IF((XCT(J)+XROUND).LT.PL) GO TO 12
L=J*2
GOUT(L)='XXXXX'
GOUT(L-1)='I'
GOUT(L+1)='I'
12 CONTINUE
DO 14 L=LM,2,-1
IF(GOUT(L).NE.' ') GO TO 15
14 CONTINUE
15 IF((I-(I/LL)*LL).EQ.0) GO TO 25
WRITE(IOUT,21)(GOUT(J),J=1,L)
21 FORMAT(8X,'I ',A1,20(A5,A1))
GO TO 11
25 WRITE(IOUT,26)PL,(GOUT(J),J=1,L)
26 FORMAT(1X,F6.2,' + ',A1,20(A5,A1))
11 CONTINUE
WRITE(IOUT,40)(MINUS,PLUS,I=1,KK)
40 FORMAT(8X,'--+',25(A5,A1))
WRITE(IOUT,41)(ICT(I),I=1,KK)
41 FORMAT(10X,'^',25(I4,' ^'))
WRITE(IOUT,42)(ARROW,I=1,KK)
42 FORMAT(10X,'^',20(5X,A1))
XCT(1)=AMIN
DO 16 I=2,KK+1
16 XCT(I)=XCT(I-1)+DEGREE
LMP=KK-((KK/2)*2)
IF(LMP.EQ.0) WRITE(IOUT,23)(XCT(I),I=2,KK+1,2)
23 FORMAT(10X,'^',13(2X,G9.3,'^'))
IF(LMP.EQ.1) WRITE(IOUT,43)(ARROW,XCT(I),I=2,KK+1,2)
43 FORMAT(10X,13(A1,2X,G9.3))
WRITE(IOUT,24)(XCT(I),I=1,KK+1,2)
24 FORMAT(8X,G9.3,1X,9(1X,G9.3,2X),1X,G9.3)
50 CONTINUE
RETURN
END
C *** STAT PACK ***
C SUBROUTINE FOR STANDARD ERROR OF MEAN, SKEWNESS, AND
C COEFFICIENT OF VARIATION.
C CALLING SEQUENCE: CALL ERANA(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C VMN - IS A VECTOR CARRYING MEANS OF VARIABLES.
C STD - IS A VECTOR CARRYING STANDARD DEVIATIONS OF VAR.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM MAKES USE OF STANDARD DEVIATIONS ALREADY CALCULATED AT
C INPUT TIME, FOR STANDARD ERROR OF MEAN CALCULATIONS. IT ALSO USES
C THE CALCULATED MEANS IN ADDITION TO STANDARD DEVIATIONS,
C TO CALCULATE THE COEFFICIENTS OF VARIATION.
C
SUBROUTINE ERANA (NV,NC,MV,MC,DATA,VMN,STD,NAMES,LINES)
DIMENSION DATA(MC,MV),STD(1),VMN(1),NAMES(1)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
IF(IOUT.NE.21) GO TO 9
LINES=LINES+2
IF(LINES.LE.(LINPP-5)) GO TO 9
CALL PRNTHD
LINES=4
9 WRITE(IOUT,1)
DO 2 I=1,NV
C
C **********************************************************
C STANDARD ERROR OF MEAN
X=NC
STDM=STD(I)/SQRT(X)
IF(STD(I).EQ.0.0) GO TO 11
C
C **********************************************************
C COEFFICIENT OF VARIATION
6 COV=(100*STD(I))/VMN(I)
C
C **********************************************************
C COEFICIENT OF SKEWNESS
SX2=0
SX3=0
DO 3 J=1,NC
D=DATA(J,I)-VMN(I)
SX2=SX2+D**2
SX3=SX3+D**3
3 CONTINUE
COS=(SX3/X)/((SX2/X)**1.5)
11 IF(IOUT.NE.21) GO TO 8
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 8
CALL PRNTHD
WRITE(IOUT,1)
LINES=5
8 IF(STD(I).NE.0) WRITE(IOUT,5) NAMES(I),STDM,COS,COV
5 FORMAT(1X,A5,3X,3G15.7)
IF(STD(I).EQ.0) WRITE(IOUT,7) NAMES(I),STDM
7 FORMAT(1X,A5,3X,G15.7,1X,'CANNOT CALCULATE (STD. DEV.= 0)')
1 FORMAT('0VAR.',4X,'STD ERR OF MEAN',3X,'SKEWNESS',4X,
1'COEF. OF VAR.')
2 CONTINUE
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO OUTPUT SAMPLE SIZES, MEANS, STANDARD DEVIATIONS
C AND VARIANCES.
C CALLING SEQUENCE IS CALL DESC(NV,NC,MV,MC,VMN,STD,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C VMN - IS A VECTOR CONTAINING VARIABLE MEANS.
C STD - IS A VECTOR CONTAINING VARIABLE STANDARD DEVIATIONS
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C THE SUBROUTINE SIMPLY OUTPUTS VALUES WHICH HAVE BEEN
C PREVIOUSLY CALCULATED.
C
SUBROUTINE DESC(NV,NC,MV,MC,VMN,STD,NAMES,LINES)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
DIMENSION VMN(1),STD(1),NAMES(1)
IF(IOUT.NE.21) GO TO 1
LINES=LINES+4
IF(LINES.LE.(LINPP-5)) GO TO 1
CALL PRNTHD
LINES=6
1 WRITE (IOUT,100)NV,NC
100 FORMAT('0THERE ARE',I5,' VARIABLES AND',I5,' OBSERVATIONS')
WRITE(IOUT,102)
102 FORMAT('0VAR. MEANS STD.DEV. VARIANCE')
DO 200 I=1,NV
XVAR=STD(I)**2
IF(IOUT.NE.21) GO TO 200
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 200
CALL PRNTHD
WRITE(IOUT,102)
LINES=5
200 WRITE (IOUT,101) NAMES(I),VMN(I),STD(I),XVAR
101 FORMAT(1X,A5,2X,3G15.7)
RETURN
END
C *** STAT PACK ***
C SUBROUTINE FOR CORRELATION MATRIX
C CALLING SEQUENCE: CALL CORR(NV,NC,MV,MC,COR,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C COR - IS THE CORRELATION MATRIX.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM SIMPLY OUTPUTS THE CORRELATION MATRIX AS CALCULATED
C ELSEWHERE IN THE PROGRAM.
C
SUBROUTINE CORR(NV,NC,MV,MC,COR,NAMES)
COMMON/DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
DIMENSION COR(MV,MV),NAMES(1)
ISQ=7
IF(IOUT.EQ.21) ISQ=15
IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
LINES=4
WRITE(IOUT,104)
104 FORMAT('0',10X,'***** CORRELATION MATRIX *****'//' VAR.')
DO 200 I=1,NV
IF(IOUT.NE.21) GO TO 202
L=I/ISQ+1
LINES=LINES+L
IF(LINES.LE.(LINPP-L-1)) GO TO 202
WRITE(IOUT,103)
DO 203 J=1,I-1,ISQ
NEND=J+ISQ-1
IF(NEND.GT.(I-1)) NEND=I-1
203 WRITE(IOUT,102)(NAMES(K),K=J,NEND)
CALL PRNTHD
LINES=2+L
202 DO 200 K=1,I,ISQ
NEND=K+ISQ-1
IF(NEND.GT.I) NEND=I
IF(K.EQ.1) WRITE(IOUT,100) NAMES(I),(COR(I,J),J=K,NEND)
100 FORMAT(1X,A5,2X,15F8.4)
IF(K.NE.1) WRITE(IOUT,101) (COR(I,J),J=K,NEND)
101 FORMAT(8X,15F8.4)
200 CONTINUE
WRITE(IOUT,103)
103 FORMAT(1X)
DO 201 I=1,NV,ISQ
NEND=I+ISQ-1
IF(NEND.GT.NV) NEND=NV
201 WRITE(IOUT,102)(NAMES(J),J=I,NEND)
102 FORMAT(8X,15(3X,A5))
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO INPUT DATA FROM TTY.
C CALLING SEQUENCE: CALL DDATA(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C VMN - IS A VECTOR CONTAINING THE VARIABLE MEANS
C COR - IS A MATRIX CONTAINING THE CORRELATIONS
C STD - IS A VECTOR CONTAINING THE STANDARD DEVIATIONS OF
C THE VARIABLES.
C FMT - IS THE OBJECT TIME FORMAT.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM ACCEPTS DATA FROM TTY IN FLOATING MODE.
C CALCULATES MEANS, STANDARD DEVIATIONS, AND CORRELATIONS.
C
SUBROUTINE DDATA(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
DIMENSION DATA(MC,MV),STD(1),VMN(1),COR(MV,MV),FMT(80)
DIMENSION NAMES(1)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
IF(ICC.NE.2) WRITE (IDLG,1)
1 FORMAT('0HOW MANY INPUT VARIABLES? ',$)
READ(ICC,16) ANS
IF(ANS.EQ.'!') RETURN
16 FORMAT(A5)
REREAD 2,NV
2 FORMAT(20I)
IF(NV.LE.MV) GO TO 4
WRITE(IDLG,3)
3 FORMAT('0TOO MANY VARIABLES!')
RETURN
4 DO 5 J=1,NV
VMN(J)=0.
DO 5 K=1,NV
5 COR(K,J)=0.
I=1
WRITE(IDLG,6)
6 FORMAT('0ENTER INPUT DATA'/)
7 READ(IDATA,FMT,ERR=20,END=10) (STD(J),J=1,NV)
DO 8 J=1,NV
DATA(I,J)=STD(J)
VMN(J)=VMN(J)+STD(J)
DO 8 K=1,J
8 COR(K,J)=COR(K,J)+STD(J)*STD(K)
I=I+1
IF(I.LE.MC) GO TO 7
READ(IDATA,FMT,END=10) A
WRITE(IDLG,9)
9 FORMAT(' ***WARNING*** YOU HAVE COMPLETED THE SPECIFIED',
1' NUMBER'/' OF OBSERVATIONS - NO MORE DATA ACCEPTED')
GO TO 10
20 WRITE(IDLG,21)
21 FORMAT(' YOU HAVE AN ERROR ON THE LAST LINE OF DATA - REENTER IT'
1/)
GO TO 7
10 NC=I-1
DO 11 I=1,NV
DO 11 J=I,NV
11 COR(J,I)=NC*COR(I,J)-VMN(I)*VMN(J)
DO 12 I=1,NV
STD(I)=SQRT(COR(I,I)/(NC*(NC-1)))
12 VMN(I)=VMN(I)/NC
DO 13 I=1,NV
DO 13 J=I,NV
IF(I.EQ.J) GO TO 13
IF(COR(I,I)*COR(J,J).EQ.0) GO TO 14
COR(I,J)=COR(J,I)/SQRT(COR(I,I)*COR(J,J))
COR(J,I)=COR(I,J)
GO TO 13
14 COR(I,J)=0.
COR(J,I)=0.
13 CONTINUE
DO 15 I=1,NV
15 COR(I,I)=1.0
DO 18 I=1,NV
18 ENCODE(5,17,NAMES(I)) I
17 FORMAT(I3,2X)
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO STORE ENTIRE, OR SUBSETS, OF DATA ON DISK
C UNDER USER SPECIFIED NAME, AND PROTECTION.
C CALLING SEQUENCE: CALL STORE(NV,NC,MV,MC,DATA,IV,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C IV - IS A VECTOR DIMENSIONED AT LEAST FOR NV.
C NAMES - IS A VECTOR CONTIANING VARIABLE NAMES
C
C PROGRAM OUTPUTS DATA IN CORE TO DISK, EITHER AS AND ENTIRE
C SET OR AS A SERIES OF VARIABLES. USER SPECIFIES NAME AND
C PROTECTION.
C
SUBROUTINE STORE(NV,NC,MV,MC,DATA,IV,NAMES)
DOUBLE PRECISION NAME1
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
DIMENSION DATA(MC,MV),IV(1),NAMES(1),LAME(10)
112 IF(ICC.NE.2) WRITE (IDLG,210)
210 FORMAT('0WHAT IS THE NAME OF THE FILE? ',$)
269 READ (ICC,211) LAME
IF(LAME(1).EQ.'!') RETURN
IF((LAME(1).NE.'H').OR.(LAME(2).NE.'E').OR.(LAME(3).NE.'L')
1.OR.(LAME(4).NE.'P').OR.(LAME(5).NE.' ')) GO TO 110
WRITE(IDLG,111)
111 FORMAT('0STORE IS DESIGNED TO STORE DATA ON A DISK FOR FUTURE'/
1' REFERENCE EITHER BY STAT-PACK, OR ANOTHER PROGRAM. THE'/
2' NAME THAT YOU WISH THE DATA TO BE STORED UNDER SHOULD '/
3' BE TYPED WHEN THE MACHINE ASKS "WHAT IS THE NAME OF THE'/
4' FILE?", NO EXTENSION IS NECESSARY.'/
7' VARIABLES ARE STORED UNDER THE FORMAT (8G15.7).'/
8' PROTECTION CAN BE ASSIGNED BY TYPEING THE PROTECTION CODE'/
9' DESIRED WHEN THE MACHINE ASKS "WHAT '/
1' PROTECTION WOULD YOU LIKE?". IF NO PROTECTION IS GIVEN'/
2' THE MACHINE ASSUMES A <177> PROTECTION')
GO TO 112
211 FORMAT(10A1)
110 IPD=0
DO 10 I=1,10
IF(LAME(I).EQ.'.') IPD=1
IF(LAME(I).EQ.' ') GO TO 12
10 CONTINUE
WRITE(IDLG,11)
11 FORMAT('0NO PERIOD SEPARATED NAME FROM EXTENSION')
GO TO 1
12 IF(IPD.EQ.0) LAME(I)='.'
ENCODE(10,211,NAME1) LAME
IERR=0
CALL CHKNAM(NAME1,IERR)
IF(IERR.EQ.0) GO TO 1
WRITE(IDLG,264)
264 FORMAT('0ILLEGAL NAME')
GO TO 112
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT('0WHICH VARIABLES? ',$)
CALL ALPHA(IV,NV,N,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 1
IF(IHELP.NE.1) GO TO 4
WRITE(IDLG,3)
3 FORMAT(' LIST VAR. NAMES OR NUMBERS OF VAR. TO BE STORED')
GO TO 1
4 IF(ICC.NE.2) WRITE(IDLG,217)
217 FORMAT(1X,'WHAT PROTECTION WOULD YOU LIKE? ',$)
READ (ICC,218) IPRO
218 FORMAT(O)
IF(IPRO.EQ.0) WRITE (IDLG,219)
219 FORMAT(' STANDARD 177 PROTECTION GIVEN')
IF(IPRO.EQ.0) IPRO=127
OPEN(UNIT=IDSK,FILE=NAME1,ACCESS='SEQOUT',DEVICE='DSK',
1PROTECTION=IPRO)
DO 5 I=1,N
IF(IV(I).LT.0) GO TO 213
5 CONTINUE
DO 212 I=1,NC
WRITE (IDSK,666)(DATA(I,IV(J)),J=1,N)
666 FORMAT(8G15.7)
212 CONTINUE
GO TO 215
213 DO 214 I=1,NC
WRITE(IDSK,666)(DATA(I,J),J=1,NV)
214 CONTINUE
215 CLOSE(UNIT=IDSK)
CALL RELEAS (IDSK)
WRITE (IDLG,216)
216 FORMAT('0SELECTED VARIABLES WERE STORED ACCORDING TO
1 FORMAT:'/' (8G15.7)')
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO INPUT DATA FROM DISK, FILE SPECIFIED BY USER.
C CALLING SEQUENCE: CALL FETCH(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C VMN - IS A VECTOR CONTAINING VARIABLE MEANS.
C COR - IS A MATRIX CONTAINING CORRELATIONS.
C STD - IS A VECTOR CONTAINING VARIABLE STANDARD
C DEVIATIONS.
C FMT - IS A VECTOR CONTAINING OBJECT TIME FORMAT.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM ALLOWS DATA TO BE READ FROM DISK, FROM A FILE
C SPECIFIED BY THE USER.
C
SUBROUTINE FETCH(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
DIMENSION DATA (MC,MV),STD(1),VMN(1),COR(MV,MV),NAME(25)
DIMENSION FMT(80),NAMES(1),PATH(3),LAME(10)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
DOUBLE PRECISION NAME1,IPG
EQUIVALENCE(PATH(1),IPROJ),(PATH(2),IPROG)
C NBL IS LEFT HAND BRACKET, NBR IS RIGHT HAND BRACKET
DATA NBL,NBR/"555004020100,"565004020100/
PATH(3)=0
6 IF(ICC.NE.2) WRITE (IDLG,240)
240 FORMAT ('0WHAT IS THE FILE NAME AND EXTENSION? ',$)
READ (ICC,241) NAME
IF(NAME(1).EQ.'!') RETURN
241 FORMAT (25A1)
IF ((NAME(1).NE.'H').OR.(NAME(2).NE.'E').OR.(NAME(3).NE.'L').
1OR.(NAME(4).NE.'P').OR.(NAME(5).NE.' ')) GO TO 27
WRITE (IDLG,1)
1 FORMAT('0THE FETCH COMMAND IS USED TO READ DATA FROM'/
1' THE DISK. BOTH THE FILE NAME AND EXTENSION MUST BE '/
2' SPECIFIED. IN ORDER TO READ FROM ANOTHER AREA THE'/
3' PROJECT, PROGRAMMER NUMBER MUST BE INSERTED IN BRACKETS'/
4' DIRECTLY ADJOINING THE NAME AND EXTENSION.')
GO TO 6
C
C DETERMINE FILE NAME
C
27 IPD=0
DO 28 I=1,10
28 LAME(I)=' '
DO 2 I=1,10
IF(NAME(I).EQ.'.') IPD=1
IF (NAME(I).EQ.' ') GO TO 3
IF (NAME(I).EQ.NBL) GO TO 3
LAME(I)=NAME(I)
2 CONTINUE
I=11
IF(IPD.EQ.1) GO TO 3
WRITE(IDLG,29)
29 FORMAT('0NO PEROID BETWEEN NAME AND EXTENSION')
GO TO 6
3 IF(IPD.EQ.0) LAME(I)='.'
ENCODE(10,241,NAME1)LAME
L=I
C
C DETERMINE PROJECT NUMBER
C
IF (NAME(L).NE.NBL) GO TO 14
L=L+1
DO 4 I=L,25
IF (NAME(I).EQ.',') GO TO 8
IF (NAME(I).NE.NBR) GO TO 9
WRITE (IDLG,5)
5 FORMAT ('0NO COMMA BETWEEN THE PROJECT NUMBER AND PROGRAMMER'
1' NUMBER')
GO TO 6
14 IPROJ=0
IPROG=0
GO TO 15
9 IF ((NAME(I).LE.'7').AND.(NAME(I).GE.'0')) GO TO 4
WRITE (IDLG,12)
12 FORMAT ('0PROJECT OR PROGRAMMER NUMBER ILLEGAL')
GO TO 6
4 CONTINUE
WRITE (IDLG,7)
7 FORMAT ('0INVALID PROJECT PROGRAMMER NUMBER')
GO TO 6
C
C DETERMINE PROGRAMMER NUMBER
C
8 M=I-1
K=I-L
IPG=BLANK
ENCODE (K,241,IPG) (NAME(I),I=L,M)
DECODE (10,10,IPG) IPROJ
10 FORMAT (O)
L=M+2
DO 11 I=L,25
IF (NAME(I).EQ.NBR) GO TO 13
IF ((NAME(I).LE.'7').AND.(NAME(I).GE.'0')) GO TO 11
WRITE (IDLG,12)
GO TO 6
11 CONTINUE
WRITE (IDLG,7)
GO TO 6
13 M=I-1
K=I-L
IPG=BLANK
ENCODE (K,241,IPG) (NAME(I),I=L,M)
DECODE (10,20,IPG) IPROG
20 FORMAT(O)
15 IERR=0
CALL EXIST(NAME1,IERR,IPROJ,IPROG)
IF(IERR.EQ.0) GO TO 16
WRITE(IDLG,17)
17 FORMAT('0FILE NAME ILLEGAL OR FILE NOT FOUND')
GO TO 6
16 OPEN(UNIT=IDSK,FILE=NAME1,ACCESS='SEQIN',DEVICE='DSK',
1DIRECTORY=PATH)
150 IF(ICC.NE.2) WRITE (IDLG,200)
200 FORMAT ('0HOW MANY INPUT VARIABLES? ',$)
READ (ICC,400) NV
400 FORMAT (I)
IF (NV.LE.MV) GO TO 244
WRITE (IDLG,402)
402 FORMAT('0TOO MANY VARIABLES!')
GO TO 150
244 DO 245 J=1,NV
DO 245 K=1,NV
245 COR(K,J)=0.
DO 246 J=1,NV
246 VMN(J)=0.
NERRS=0
I=1
GO TO 250
300 IF(NERRS.GT.3) GO TO 304
WRITE(IDLG,301) I
301 FORMAT(' ERROR ON READING - OBS. ',I4,
1' REPLACED WITH -9999E-20')
DO 302 J=1,NV
302 DATA(I,J)=-9999E-20
NERRS=NERRS+1
GO TO 303
304 WRITE(IDLG,305)
305 FORMAT('0MORE THAN 4 ERRORS WHILE READING - FETCH ABORTED')
NV=0
NC=0
RETURN
250 READ (IDSK,FMT,END=252,ERR=300) (STD(J),J=1,NV)
303 DO 253 K=1,NV
DATA(I,K)=STD(K)
VMN(K)=VMN(K)+STD(K)
DO 253 J=1,K
253 COR(J,K)=COR(J,K)+STD(J)*STD(K)
I=I+1
IF (I.LE.MC) GO TO 250
READ(IDSK,FMT,END=252,ERR=300) A
WRITE (IDLG,920)
920 FORMAT(' ***WARNING*** YOU HAVE COMPLETED THE SPECIFIED',
1' NUMBER'/' OF OBSERVATIONS - NO MORE DATA ACCEPTED')
252 CALL RELEAS (IDSK)
NC=I-1
DO 503 I=1,NV
DO 503 J=I,NV
503 COR(J,I)=NC*COR(I,J)-VMN(I)*VMN(J)
DO 504 I=1,NV
STD(I)=SQRT(COR(I,I)/(NC*(NC-1)))
504 VMN(I)=VMN(I)/NC
DO 505 I=1,NV
DO 505 J=I,NV
IF (I.EQ.J) GO TO 505
IF (COR(I,I)*COR(J,J).EQ.0) GO TO 50
COR(I,J)=COR(J,I)/SQRT(COR(I,I)*COR(J,J))
COR(J,I)=COR(I,J)
GO TO 505
50 COR(I,J)=0
COR(J,I)=0
505 CONTINUE
DO 506 I=1,NV
ENCODE(5,507,NAMES(I)) I
507 FORMAT(I3,2X)
506 COR(I,I)=1.0
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO ENTER OBJECT TIME FORMAT
C CALLING SEQUENCE: CALL FORM(FMT)
C WHERE FMT - IS A VECTOR FOR THE OBJECT TIME FORMAT.
C
C SUBROUTINE ALLOWS THE ENTERING OF A USER SPECIFIED
C FORMAT. FORMAT MAY BE ENTERED ON MULTIPLE LINES - UP TO 400
C CHARACTERS LONG. MUST BE ENCLOSED IN PARANTHESIS END OF
C FORMAT IS SIGNALED BY CLOSING PARANTHESIS.
C
SUBROUTINE FORM(FMT)
DIMENSION FMT(80),DATIN(80)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' ENTER INPUT FORMAT'/)
DO 50 I=1,80
50 FMT(I)=' '
IPARN=0
J=1
K=1
3 READ(ICC,4,END=30)(DATIN(I),I=K,80)
4 FORMAT(80A1)
C
C COMPRESS OUT BLANKS
C
C FIRST LOCATE LAST NON- BLANK CHARACTER
C
IF((DATIN(K).EQ.'H').AND.(DATIN(K+1).EQ.'E').AND.(DATIN(K+2).EQ.
1'L').AND.(DATIN(K+3).EQ.'P')) GO TO 40
DO 5 N=80,K,-1
IF(DATIN(N).NE.' ') GO TO 6
5 CONTINUE
GO TO 3
C
C GET RID OF BLANKS
C
6 I=K
7 IF(DATIN(I).NE.' ') GO TO 9
DO 8 L=I+1,N
8 DATIN(L-1)=DATIN(L)
N=N-1
GO TO 10
9 I=I+1
10 IF(I.LT.N) GO TO 7
IF(DATIN(K).EQ.'!') GO TO 30
IF((J.EQ.1).AND.(DATIN(1).NE.'(')) GO TO 35
C
C CHECK PARANTHESIS
C
DO 11 I=K,N
IF(DATIN(I).EQ.'(') IPARN=IPARN+1
IF(DATIN(I).NE.')') GO TO 11
IPARN=IPARN-1
IF(IPARN.LE.0) GO TO 20
11 CONTINUE
IF(N.GE.5) GO TO 12
K=N+1
GO TO 3
C
C ENCODE DATA INTO FMT FROM DATIN
C
12 I=1
13 IF((I+4).LE.N) GO TO 15
DO 14 L=I,N
14 DATIN(L-I+1)=DATIN(L)
K=N-I+2
GO TO 3
15 ENCODE(5,4,FMT(J))(DATIN(L),L=I,I+4)
J=J+1
IF(J.LE.80) GO TO 17
WRITE(IDLG,16)
16 FORMAT(' FORMAT MAY NOT BE LONGER THAN 400 CHARACTERS')
GO TO 1
17 I=I+5
GO TO 13
20 I=1
21 ENCODE(5,4,FMT(J))(DATIN(L),L=I,I+4)
I=I+5
IF(I.GT.N) RETURN
J=J+1
IF(J.LE.80) GO TO 21
WRITE(IDLG,16)
GO TO 1
C
C RESTORE ORIGINAL FORMAT AND RETURN
C
30 FMT(1)='(20F)'
FMT(2)=' '
RETURN
C
C
C
35 WRITE(IDLG,36)
36 FORMAT(' FORMAT MUST BE ENCLOSED IN PARANTHESIS')
GO TO 1
C
C HELP SECTION
C
40 WRITE(IDLG,41)
41 FORMAT('0ENTER FORMAT TO BE USED FOR INPUTTING VARIABLES.'/
1' FORMAT MUST BE:'/
2' 1. ENCLOSED IN PARANTHESIS. A PARANTHESIS COUNT OF ZERO'/
3' IS USED TO DETERMINE WHEN THE ENTIRE FORMAT HAS BEEN'/
4' ENTERED, THUS THE ENTIRE FORMAT MUST BE ENCLOSED IN'/
5' PARANTHESIS.'/
6' 2. IN FLOATING POINT NOTATION. STP WILL ONLY ANALYSE'/
7' FLOATING POINT VARIABLES, THUS ALL FORMAT STATEMENTS'/
8' MUST BE OF THE F-TYPE. (EXAMPLES ARE: F, G, AND E)'/
9' 3. LESS THAN OR EQUAL TO 400 CHARACTERS. MULTIPLE LINES'/
1' MAY BE USED TO ENTER THE FORMAT, WITH NO LINE'/
2' LONGER THAN 72 CHARACTERS; BUT, THE ENTIRE FORMAT'/
3' MUST NOT EXCEED 400 CHARACTERS.'/
4'0IF A ^Z(CONTROL Z) IS TYPED WHILE ENTERING THE FORMAT, THE'/
5' ORIGINAL FORMAT OF (20F) WILL BE ASSUMED.'/
6'0EXAMPLE FORMAT:'/
7' (2X,3F3.0,2(F2.1,1X),2X,F4.2,2X,F2.1,F1.0,1X,F1.0)'/
8'0FOR A MORE DETAILED DESCRIPTION OF FORMATS CONSULT THE DEC'/
9' SYSTEM 10 MATHEMATICAL LANGUAGES HANDBOOK PAGES 5-1 THRU 5-9.')
GO TO 1
END
C *** STAT PACK ***
C SUBROUTINE FOR MEDIAN, MODE, MAXIMUM, AND MINIMUM.
C CALLING SEQUENCE: CALL STBAS(NV,NC,MV,MC,DATA,AV,NAMES)
C WHERE NV - IS NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS NUMBER OF ROWS ACTUALLY FILLED (OBSERVATIONS, CASES)
C MV - IS MAXIMUM NUMBER OF COLUMNS, AS SPECIFIED IN MAIN
C MC - IS MAXIMUM NUMBER OF ROWS, AS SPECIFIED IN MAIN
C DATA - STORAGE FOR DATA DIMENSIONED FOR MAXIMUM MATRIX
C AV - IS A VECTOR AT LEAST NC LONG FOR EXTRA ROOM
C DURING THE SORT
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C PROGRAM DOES A PARTITIONING SORT ON EACH VARIABLE,
C FIRST TRANSFEREING THE DATA TO AV. ONCE THIS HAS BEEN
C PERFORMED, THE MEDIAN, MODE, MAX, AND MIN ARE EASILY
C CALCULATED. DATA MATRIX IS RETURNED TO MAIN LINE UNCHANGED.
C
SUBROUTINE STBAS(NV,NC,MV,MC,DATA,AV,NAMES,LINES)
DIMENSION DATA(MC,MV),AV(1),NAMES(1)
C
C FOLLOWING DIMENSION FOR SORT ALONE. IU(K) AND 8L(K)
C WILL SORT UP TO 2**(K-1)-1 ELEMENTS
DIMENSION IU(16),IL(16)
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
INTEGER BASE
IF(IOUT.NE.21) GO TO 3
LINES=LINES+2
IF(LINES.LE.(LINPP-5)) GO TO 3
CALL PRNTHD
LINES=4
3 WRITE(IOUT,1)
1 FORMAT('0VAR.',6X,'MEDIAN',11X,'MODE',12X,'MAXIMUM',
19X,'MINIMUM')
C
C *********************************************************
C PARTITIONING SORTING METHOD.
ISBIMD=0
DO 2 I=1,NV
BIMOD=' '
DO 70 J=1,NC
70 AV(J)=DATA(J,I)
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 MEDIAN
90 IF((NC-(NC/2)*2).EQ.0) GO TO 20
N=NC/2+1
XMED=AV(N)
GO TO 30
20 N=NC/2
XMED=(AV(N)+AV(N+1))/2.
C
C ************************************************************
C MODE
30 MAX=0
AMOD=AV(1)
XMAX=AV(1)
LL=1
DO 31 J=2,NC
IF(XMAX.NE.AV(J)) GO TO 32
LL=LL+1
GO TO 31
32 IF(LL.LT.MAX) GO TO 33
IF(LL.GT.MAX) GO TO 35
BIMOD='*'
GO TO 33
35 MAX=LL
AMOD=XMAX
BIMOD=' '
33 XMAX=AV(J)
LL=1
31 CONTINUE
IF(LL.GT.MAX)AMOD=XMAX
IF(LL.GT.MAX) BIMOD=' '
IF(LL.EQ.MAX) BIMOD='*'
C
C *************************************************************
C OUTPUT
IF(IOUT.NE.21) GO TO 4
LINES=LINES+1
IF(LINES.LE.(LINPP-2)) GO TO 4
CALL PRNTHD
WRITE(IOUT,1)
LINES=4
4 WRITE(IOUT,34) NAMES(I),XMED,AMOD,BIMOD,AV(NC),AV(1)
34 FORMAT(1X,A5,2X,G15.7,1X,G15.7,A1,1X,G15.7,1X,G15.7)
IF(BIMOD.EQ.'*') ISBIMD=1
2 CONTINUE
IF(ISBIMD.EQ.1) WRITE (IOUT,36)
36 FORMAT('0* MORE THAN 1 MODE EXISTS - ONLY THE FIRST IS SHOWN')
RETURN
END
C *** STAT PACK ***
C SUBROUTINE TO INSERT MULTIPLE LINE DOCUMENTATION INTO LINE
C PRINTER OUTPUT
C CALLING SEQUENCE: CALL MAKEST
C
C OUTPUT IS ON LINE PRINTER .
C ALTHOUGH EACH TIME THE MAKE COMMAND IS USED ANOTHER PAGE OF
C DOCUMENT IS PRODUCED, IT IS ONLY PUT OUT ONCE (NOT BEFOR EVERY
C INSTRUCTION AS WITH THE TITLE COMMAND). TRANSFER OF USER
C INFORMATION IS PERFORMED LINE BY LINE, MAKEING CORRECTIONS TO
C PREVIOUS LINES IMPOSSIBLE. AN ALTMODE SIGNALS THE DOCUMENT IS
C COMPLETE AND RETURNS TO WHICH COMMAND?.
C
SUBROUTINE MAKEST
DOUBLE PRECISION NAME
DIMENSION A(132)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
DATA ALTMOD/"155004020100/
CALL PRNTHD
LINES=2
100 WRITE(IDLG,1)
1 FORMAT(' ENTER DOCUMENTATION'/)
CARCNT='1'
2 READ(ICC,3,END=9) A
3 FORMAT(133A1)
DO 4 I=132,1,-1
IF(A(I).NE.' ') GO TO 5
4 CONTINUE
5 N=I
IF((A(1).EQ.'@').AND.(N.LE.11)) GO TO 12
IF((N.EQ.4).AND.(A(1).EQ.'H').AND.(A(2).EQ.'E').AND.(A(3).EQ.'L').
1AND.(A(4).EQ.'P')) GO TO 10
IF((N.EQ.1).AND.(A(1).EQ.'!')) GO TO 9
DO 6 I=1,N
IF(A(I).EQ.ALTMOD) GO TO 8
6 CONTINUE
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 7
CALL PRNTHD
LINES=3
7 WRITE(21,3) CARCNT,(A(I),I=1,N)
CARCNT=' '
GO TO 2
8 IF(I.EQ.1) GO TO 9
WRITE(21,3) CARCNT,(A(J),J=1,I-1)
9 RETURN
10 WRITE(IDLG,11)
11 FORMAT(' THIS ROUTINE ALLOWS FOR INSERTION OF DOCUMENTATION'/
1' INTO THE LINE PRINTER OUTPUT. MORE THAN 1 LINE OF DOCUMENT'/
2' MAY BE INSERTED. WHEN FINISHED TYPE AN ALTMODE OR A'/
3' CONTROL Z (^Z). A "!" IN THE FIRST COLUMN WILL ALSO WORK'/
4' HOWEVER THOSE LINES ALREADY TYPED IN WILL REMAIN.'/
5'0A STORED ASCII FILE MAY BE INSERTED INTO THE PRINTOUT'/
6' RATHER THAN INPUT FROM THE TERMINAL BY TYPING AN "@"'/
7' AND THE NAME AND EXTENSION OF THE FILE TO BE INSERTED.'/
8' THE FILE MUST BE IN THE AREA STATPACK IS BEING RUN FROM.')
GO TO 100
C
C READ FILE FOR DOCUMENTATION
C
12 ENCODE(10,3,NAME)(A(I),I=2,11)
CALL EXIST(NAME,IERR,0,0)
IF(IERR.EQ.0) GO TO 14
WRITE(IDLG,13)
13 FORMAT(' NAME ILLEGAL OR FILE NOT FOUND')
GO TO 100
14 OPEN(UNIT=IDSK,FILE=NAME,ACCESS='SEQIN',DEVICE='DSK')
15 READ(IDSK,3,END=16) A
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 17
CALL PRNTHD
LINES=3
17 WRITE(21,3) CARCNT,A
CARCNT=' '
GO TO 15
16 CALL RELEAS (IDSK)
GO TO 9
END