Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50520/stp1.stp
There is 1 other file named stp1.stp 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
C**AM#1.1.4-7 RRB/16-MAY-79 @90+2
IF(LINES+2.GT.LINPP) GO TO 43
C**END STFREQ,STP1.STP
LINES=LINES+2
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
DO 2216 JI=80,1,-1
2216 IF(FMT(JI).NE.' '.AND.FMT(JI).NE.0)GO TO 2217
JI=1
2217 WRITE(IDLG,2218)(FMT(IJ),IJ=1,JI)
2218 FORMAT('0VARIABLES WILL BE READ ACCORDING TO',
1 ' FORMAT:',/,(1X,14A5))
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,OFMT)
DOUBLE PRECISION NAME1
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
DIMENSION DATA(MC,MV),IV(1),NAMES(1),LAME(10),OFMT(80)
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 MAY BE STORED UNDER THE DEFAULT FORMAT (8G15.7)',/,
7' OR THE "OFORM" COMMAND MAY BE USED BEFORE THE "STORE" COMMAND'/
7' TO CHANGE THE OUTPUT FORMAT. NOTE: THE INPUT DEFAULT IS (20F).'/
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)
C**AM#1.1.4-4 SUGGESTED BY A.J. BULLEN OF U. OF YORK(LETTER OF 10FEB77)
110 IPD=0
IPOS=0
IF(LAME(1).EQ.' ')GO TO 70
DO 222 I=1,10
IF(LAME(I).NE.'.')GO TO 90
IPD=IPD+1
IPOS=I
GO TO 222
90 IF(LAME(I).EQ.' ')GO TO 91
222 CONTINUE
IF(IPD.EQ.0)GO TO 10
IF(IPD.GT.1)GO TO 20
IF(IPOS.GT.7)GO TO 30
IF(IPOS.LT.7)GO TO 30
I=11
GO TO 93
91 IF(IPD.GT.1)GO TO 20
IF(IPD.EQ.1)GO TO 92
IF(I.GT.7)GO TO 30
LAME(I)='.'
GO TO 94
92 IF(IPOS.GT.7)GO TO 30
IF(I.GT.IPOS+4)GO TO 30
IF(I.EQ.IPOS+1)GO TO 94
93 ENCODE(10,211,NAME1)(LAME(J),J=I-1,IPOS,-1)
IERR=0
CALL CHKNAM(NAME1,IERR)
IF(IERR.NE.0)GO TO 50
94 ENCODE(10,211,NAME1)LAME
CALL CHKNAM(NAME1,IERR)
IF(IERR.NE.0)GO TO 50
GO TO 1
10 WRITE(IDLG,101)
101 FORMAT('0?NO PERIOD SEPARATING FILE NAME FROM EXTENSION')
GO TO 112
20 WRITE(IDLG,202)
202 FORMAT('0MORE THAN ONE PERIOD IN FILE SPECIFICATION')
GO TO 112
30 WRITE(IDLG,303)
303 FORMAT('0?FILE NAME OR EXTENSION TOO LONG')
GO TO 112
50 WRITE(IDLG,505)
505 FORMAT('0?ILLEGAL CHARACTER(S) IN FILE NAME OR EXTENSION')
GO TO 112
70 WRITE(IDLG,707)
707 FORMAT('0?FIRST CHARACTER MUST BE LETTER OR NUMBER')
GO TO 112
C**END OF 1.1.4-4
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,OFMT)(DATA(I,IV(J)),J=1,N)
212 CONTINUE
GO TO 215
213 DO 214 I=1,NC
WRITE(IDSK,OFMT)(DATA(I,J),J=1,NV)
214 CONTINUE
215 CLOSE(UNIT=IDSK)
CALL RELEAS (IDSK)
DO 2216 JI=80,1,-1
2216 IF(OFMT(JI).NE.' '.AND.OFMT(JI).NE.0)GO TO 2217
JI=1
2217 WRITE (IDLG,216)(OFMT(IJ),IJ=1,JI)
216 FORMAT('0SELECTED VARIABLES WERE STORED ACCORDING TO
1 FORMAT:'/,(1X,14A5))
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/
BLANK=' '
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.
C
DO 2216 JI=80,1,-1
2216 IF(FMT(JI).NE.' '.AND.FMT(JI).NE.0)GO TO 2217
JI=1
2217 WRITE(IDLG,2218)(FMT(IJ),IJ=1,JI)
2218 FORMAT('0VARIABLES WILL BE READ ACCORDING TO',
1 ' FORMAT:',/,(1X,14A5))
C
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 STD(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,IOFLAG,STD)
C WHERE FMT - IS A VECTOR FOR THE OBJECT TIME FORMAT.
C IOFLAG - IS 0 IF INPUT FORMAT
C 1 IF OUTPUT FORMAT
C STD - IS THE STANDARD FORMAT FOR IN OR OUT
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,IOFLAG,STD)
DIMENSION FMT(80),DATIN(80)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
1 IF(ICC.NE.2.AND.IOFLAG.EQ.0) WRITE(IDLG,2)
2 FORMAT(' ENTER INPUT FORMAT'/)
IF(ICC.NE.2.AND.IOFLAG.NE.0)WRITE(IDLG,22)
22 FORMAT(' ENTER OUTPUT 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)=STD
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