Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - 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