Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50520/stp.d20
There is 1 other file named stp.d20 in the archive. Click here to see a list.
C     STAT PACK FOR W.M.U. WRITTEN BY DICK HOUCHARD .  TAKE
C     OFF ON BABYSTAT.
C     ORIGINAL COPY OF BABYSTAT OBTAINED FROM MICHIGAN MARCH 1971
C     STAT PACK STARTED MAY 1971
C     EXPERIMENTAL VERSION RELEASE JULY 1971
C     VERSION 1 RELEASED SEPTEMBER 1971
C     VERSION 2 RELEASED FEB 1971
C     VERSION 3 RELEASED JULY 1973
C     VERSION 4 RELEASED SEPTEMBER 1974
C     VERSION 4 (MODIFIED FOR F10 AND FOROTS) RELEASE JAN 6,1975
C
C     PROGRAM WRITTEN TO BE RUN ON DIGITAL EQUIPMENT CORPORATION
C     PDP-10 SYSTEM WITH LEVEL-C OR D MONITOR
C     FOLLOWING MODIFICATIONS FOR WESTERN MICHIGAN UNIVERSITY SYSTEM
C     ARE MADE USE OF IN STAT PACK
C     1. MODIFICATIONS TO CHAINB AND LOADER
C     2. ASSIGNMENT OF DEVICE 30 TO TTY
C     3. CALLING TO PRINT ROUTINE THROUGH PRINTS
C
C     IN ADDITION THE FOLLOWING ROUTINES AS ACQUIRED THROUGH NORM
C     GRANTS PROGRAM LIBRARY ARE USED
C     1. CORE ALLOCATION (MAKING USE OF DYNAMIC ALLOCATION OF 
C                        SUBSCRIPTS)
C           A. ALLCOR - ALLOCATE AMOUNT OF CORE NEEDED TO SATISIFY
C                        USER REQUIREMENTS
C     3. EXIST - CHECK FOR EXISTENCE OF A FILE
C     4. PROTEK - CHANGE PROTECTION ON A FILE IN USER AREA
C     5. CHKNAM - CHECK TO SEE THAT A FILE NAME IS LEGAL
C               (AS USED IN CONJUNCTION WITH EXIST)
C     7. JOBNUM - RETURN JOB NUMBER OF USER.
C     8. GETPPN - RETURN PROJECT, PROGRAMMER NUMBER OF USER.
C     9. BUSY - WAIT FOR DEVICE TO BECOME CLEAR.
C     10. TYPEON - TURNS TYPE ON IF CONTROL O HAS BEEN USED
C     11. USAGE - USED TO KEEP TRACK OF HOW MANY TIMES EACH
C                 SEMESTER STP IS CALLED.  ADDS 1 TO A COUNT EACH TIME.
C     12. SIZE - DETERMINE OVERLAY SIZES.
C     13. RUNUUO - PERFORMS R, RUN, AND COMPIL CLASS COMMANDS.
C
C
C
C AAR ================================================================
C AAR
C AAR    	*** ASSOCIATION OF AMERICAN R.R. UPDATES ***
C AAR    	*** MADE 10/10/77 BY W.E.BARKER TO RUN   ***
C AAR    	***         ON DECSYSTEM-20		 ***			
C AAR
C AAR    	CHANGES MADE:
C AAR
C AAR    	1) FOR ALL LINEPRINTER OUTPUT, REPLACE CALL 
C AAR    	   TO "PRINTS" ROUTINE (WHICH HANGS UP) BY
C AAR    	   PRINTING THE FILE WHEN IT IS CLOSED. THIS
C AAR    	   IS ACCOMPLISHED WITH THE DISPOSE='LIST'
C AAR    	   OPTION.
C AAR
C AAR    	2) CALL A MACRO ROUTINE, "EXPUNG", TO CLEAN
C AAR    	   UP DELETED FILES BEFORE EXITING, OR 
C AAR    	   BEFORE RUNNING ANOTHER BANK PROGRAM.
C AAR
C AAR
C AAR    NOTE: CHANGES MADE BY THE AAR ARE NUMBERED, AND ARE 
C AAR          SURROUNDED BY COMMENTS WITH "AAR" IN THE LEFT
C AAR          MARGIN. STATEMENTS WHICH WERE IN THE ORIGINAL
C AAR          VERSION AND HAVE BEEN COMMENTED OUT HAVE A
C AAR          "WMU" IN THE LEFT MARGIN.
C AAR
C AAR
C AAR =================================================================
C
C
C
      EXTERNAL FLOAT,SQRT,PROTEK,RELEAS,PRINTS
      EXTERNAL IFIX,EXIST,CHKNAM,GETPPN
      EXTERNAL SNGL,ALOG,EXP,SIN,COS,ASIN,ATAN
C
C     FOLLOWING ROUTINES ARE USED ONLY IN MTA/I SUBROUTINE.
      EXTERNAL JOBNUM,BUSY
      DOUBLE PRECISION OFLL
      DIMENSION VAR(2),CAS(2),SP(1)
      COMMON/EXTRA/HEDR(70),NSZ,RESTRT
      COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
      COMMON /PRNT/ LINPP,ICOPS,RUNPRG
      COMMON /HDR/ DATRN(2),NPAGE,PROG
      DATA YES,VAR(1),VAR(2),CAS(1),CAS(2)/'YES','VARIA','BLES?',
     1'OBSER','V.?  '/
      CALL TIME (OFIL)
      CALL DATE(DATRN)
      DECODE(5,200,OFIL)(HEDR(I),I=1,5)
200   FORMAT(9A1)
C      CALL USAGE('STP')
      HEDR(3)=HEDR(2)
      HEDR(2)=HEDR(1)
      HEDR(1)='S'
      DO 201 I=2,4
      IF(HEDR(I).EQ.' ') HEDR(I)='0'
201   CONTINUE
      HEDR(6)='.'
      HEDR(7)='D'
      HEDR(8)='A'
      HEDR(9)='T'
      ENCODE(9,200,OFLL)(HEDR(I),I=1,9)
      OPEN(UNIT=21,FILE=OFLL,ACCESS='SEQOUT',DEVICE='DSK')
      DO 203 I=1,70
203   HEDR(I)=' '
      NSZ=0
      RUNPRG=0
      ICOPS=1
      PRINT=0
      NPAGE=0
C
C     LINPP IS THE INDICATOR TELLING HOW MANY LINES WILL BE ALLOWED PER
C     PAGE IN ASSIGNED OUTPUT, IT WILL WORK CORRECTLY FOR ALL PROGRAMS
C     EXCEPT THOSE ASSOCIATED WITH A CHART (HIST,PLOT,BARGR,ETC)
      LINPP=59
C
C     DETERMINE DEVICE DESIGNATIONS: ICC IS RESPONSES TO PROMPTING(TTY)
C     - IDATA IS NORMAL INPUT MODE (TTY) - IOUT IS STRICTLY OUTPUT
C     (HERE DESIGNATED 30(TTY)) - IDLG IS PROMPTING DIALOGUE
C     (HERE TTY OUT ONLY) -
C     IDSK IS THE RANDOM ACCESS CHANNEL (ACBNK,FETCH,STORE) -
C     IN ORDER TO TO RECHANNEL OUTPUT TO THE LINE PRINTER IOUT
C     MAY BE CHANGED TO DEVICE 21.  TO COMMUNICATE WITH THE 
C     PLEASE TERMINAL DEVICE 7 MAY BE CHANGED. IN USEING THE 
C     @CMD.FIL, ICC WILL BE CHANGED TO 2 TO READ THE COMMAND FILE.
C     BOTH IOUT AND ICC WILL BE CHECKED AGAINST 21 AND 2 RESPECTIVELY
C     TO DETERMINE IF OUTPUT IS TO LINEPRINTER AND IF INPUT
C     IS FROM A COMMAND FILE
C
      ICC=-4
      IDATA=5
      IOUT=30
      IDLG=-1
      IDSK=1
C
      OPEN(UNIT=IDATA,DEVICE='TTY',ACCESS='SEQIN')
      OPEN(UNIT=IOUT,DEVICE='TTY',ACCESS='SEQOUT')
      WRITE(IDLG,100)
100   FORMAT('1STAT PACK  V4'/' WESTERN MICHIGAN UNIVERSITY')
C     DYNAMICALLY DIMENSIONED
216   WRITE (IDLG,210)
210   FORMAT('0DATA LIMITS ARE 100 OBSERVATIONS AND 7 VARIABLES.'/
     1' DO YOU WISH TO CHANGE THESE? (YES OR NO) ',$)
      READ (ICC,211)ANS
211   FORMAT(A5)
      IF(ANS.NE.'HELP') GO TO 214
      WRITE(IDLG,215)
215   FORMAT(' THIS IS A ONCE ONLY DIALOGUE USED TO ESTABLISH'/
     1' THE MAXIMUM CORE NEEDED FOR THIS RUN.  A SIZE OF 7 VARIABLES'/
     2' EACH CONTAINING 100 OBSERVATIONS IS ASSUMED.  TO CHANGE'/
     3' THE ASSUMED SIZE ANSWER "YES" TO THIS QUESTION.  YOU WILL'/
     4' BE ASKED TO SUPPLY THE NUMBER OF VARIABLES(NV) AND THE'/
     5' NUMBER OF OBSERVATIONS(NO).  TO DETERMINE IF THE DATA WILL'/
     6' FIT IN STP USE THE FOLLOWING FORMULA (MAX IS THE LARGER OF '/
     7' NO AND NV):'/
     8' NV*NO+NV*3+NV*NV+2*MAX<8001')
      GO TO 216
214   MC=100
      MV=7
      IF(ANS.EQ.'UNL') GO TO 213
      IF(ANS.NE.YES) GO TO 220
213   IF(ICC.NE.2) WRITE(IDLG,212)CAS
212   FORMAT('0MAXIMUM NUMBER OF ',2A5,1X,$)
300   FORMAT(I)
      READ(ICC,300)MC
      IF(ICC.NE.2) WRITE(IDLG,212)VAR
      READ(ICC,300)MV
C
C     CALCULATION OF CORE NEEDED IN ALLOCATION
C
      NV=0
      NC=0
      RESTRT=0
220   ML=MC
      IF(MV.GT.ML)ML=MV
      ITOT=MC*MV+MV*3+MV*MV+ML*2
      IF(ANS.EQ.'UNL') GO TO 400
C
C     ARBITRARY CUTOFF POINT AT 8000 DATA POINTS, UNLESS "UNL" HAS
C     BEEN SPECIFIED.  ALLCOR  WILL RESERVE THAT CORE IN A HIGH
C     SEGEMENT; IF THERE IS NOT ENOUGH ROOM FOR THAT HIGH SEGMENT
C     IERR WILL BE SENT BACK WITH A VALUE OTHER THAN ZERO.
C
      IF(ITOT.GT.8000) GO TO 221
400   CALL ALLCOR(ITOT,IERR,I1,SP)
C     IF IERR IS NOT ZERO THERE IS NOT ENOUGH ROOM OR THERE WOULD
C     BE NO ROOM LEFT OVER.
      IF(IERR.EQ.0) GO TO 230
221   WRITE (IDLG,301)
301   FORMAT(1X,'THERE IS NOT ENOUGH ROOM TRY AGAIN')
      GO TO 213
230   I2=I1+MC*MV
      I3=I2+MV
      I4=I3+MV
      I5=I4+MV*MV
      I6=I5+ML
      I7=I6+ML
      IF(ICC.NE.2) WRITE(IDLG,222)
222   FORMAT('0FOR A BRIEF PROGRAM DESCRIPTION TYPE "INFO"')
      CALL MAIN(NV,NC,MV,MC,SP(I1),SP(I2),SP(I3),SP(I4),SP(I5),
     1SP(I6),SP(I7))
      IF(RESTRT.EQ.1) GO TO 213
C
C     DETERMINE IF "ASSIGN" HAS EVER BEEN USED IF IT HAS PRINT
C     OUTPUT FILE === !!!  DAN MOORE -  E. I. LILLY POINTED OUT THE
C     PROBLEM THAT AT INSTALATIONS WHERE THE DEFAULT PROTECTION CODE
C     SAVED FILES AT LOGOUT TIME THE SYSTEM TENDED TO FILL UP WITH STP
C     OUTPUT FILES.  A PATCH HAS BEEN IMPLEMENTED TO AVOID THIS PROBLEM
C     BY DELETING THE OUTPUT FILE IF AN ASSIGN OR MAKE COMMAND HAS NOT
C     BEEN USED.  ALSO THE / METHOD OF EXECUTING ANOTHER PROGRAM WITHOUT
C     GOING THRU MONITOR HAS BEEN IMPLEMENTED AND PROCEEDS THRU THIS
C     SECTION.
C
      IF (NPAGE.EQ.0) GO TO 9
C WMU
C WMU
C WMU      CALL RELEAS (21)
C WMU      NPAGE=(NPAGE+1)*ICOPS+2
C WMU      CALL PRINTS(OFLL,2,1,ICOPS,NPAGE)
C WMU
C WMU
C
C AAR
C AAR			*** AAR CHANGE 1 ***
C AAR	     PRINT FILE BY USING LIST OPTION OF CLOSE.
C AAR
C AAR ----
C AAR    !
	CLOSE(UNIT=21,DISPOSE='LIST')
C AAR    !
C AAR ----
C AAR
      GO TO 10
C
C     FOLLOWING WAS RECOMENDED BY E. I. LILLY COMPANY (DAN MOORE) TO
C     DELETE PRINT FILES IF THEY WERE NOT NEEDED.
C
9     CLOSE (UNIT=21,DISPOSE='DELETE')
10    IF(RUNPRG.NE.0)GO TO 77777
C AAR
C AAR			*** AAR CHANGE 2 ***
C AAR		EXPUNGE DELETED FILES.
C AAR
C AAR ----
C AAR    !
	CALL EXPUNG
C AAR    !
C AAR ----
C AAR
	CALL EXIT
77777      ENCODE(15,8,HEDR) RUNPRG
8     FORMAT('R ',A5,8X)
      HEDR(4)=0
C AAR
C AAR ----
C AAR    !
	CALL EXPUNG
C AAR    !
C AAR ----
C AAR
C
      CALL RUNUUO(HEDR)
C     ****************************************************************
C     DUMMIES USED TO PULL IN ROUTINES USED IN CHAINS
C     
      C=A**.5
      WRITE(3) A
      READ(1,7,END=10,ERR=10) A
7     FORMAT(G,O)
      READ(1#2) A
      CLOSE (UNIT=1)
      END
      SUBROUTINE MAIN(NV,NC,MV,MC,DATA,STD,VMN,COR,SP,IV,NAMES)
      DOUBLE PRECISION FILNAM
      COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
      COMMON /PRNT/ LINPP,ICOPS,RUNPRG
      COMMON/EXTRA/HEDR(70),NSZ,RESTRT
      COMMON/HDR/DATRN(2),NPAGE,PROG
      DIMENSION DATA(MC,MV),STD(1),VMN(1),COR(MV,MV),SP(1)
      DIMENSION PR(80),IV(1),FMT(80),NAMES(1),PRGLST(20),NVAL(40)
      DATA FMT(1),FMT(2)/'(20F)','     '/
C
C     COMMAND STORAGE AREA - EACH ENTRY IS A COMMAND IMPLEMENTED, OR AN 
C     INTENDED COMMAND
C
      DATA PR/4HDATA,5HFETCH,5HBARGR,5HSTORE,4HFORM,4HDESC,4HCORR,
     15HBASIC,5HERANA,4HPLOT,5HFRIED,4HSIGN,5HTRANS,4HFREQ,4HXTAB,
     25HPCENT,5HZSCOR,5HKENDL,5HTTEST,5HCHISQ,5HSRANK,4HMANN,5HWILCX,
     35HPCORR,5HANOV1,4HREGR,5HSTEPR,5HTITLE,5HFACTO,4HSTOP,4HHELP,
     44HFINI,4HINFO,5HPRINT,4HTYPE,5HMANIP,5HESTAT,5HASSIG,5HDEASS,
     55HCOPYS,5HANOV2,5HACBNK,5HMTA/I,4HPROB,2HDC,2HST,2HGR,2HIA,
     62HPC,3HSYS,5HDISCR,5HCORRT,5HCVSMT,5H1WAYR,4HNAME,4HHIST,4H@CMD,
     75HXTAB*,5HCRCMD,5HRETUR,4HSAVE,5HPTBIS,4HSIZE,4HSORT,5HMABNK,
     85HANOC1,4HKOLM,4HMAKE,12*1/
      DATA PRGLST/'FREQ','CORL','BANK','REGR','TAB',15*0/
      STLINK='STPK4'
      LINK=0
C
C     COMMON RE-ENTRY POINT  FOR RETURN FROM ALL BRANCHES TO STP
C     SUBROUTINES
C
600   CALL TYPEON
      WRITE(IDLG,202)
202   FORMAT(//'0WHICH COMMAND? ',$)
      READ (ICC,301,END=60) NVAL
301   FORMAT(80A1)
      IF(NVAL(1).EQ.'!') GO TO 600
      DO 106 I=40,1,-1
      IF(NVAL(I).NE.' ') GO TO 107
106   CONTINUE
107   IF(ICC.EQ.2) WRITE(IDLG,103) (NVAL(J),J=1,I)
103   FORMAT('+',40A1/)
C
C     CHECK TO SEE IF THIS IS A TRANSFER TO ANOTHER BANK PROGRAM
C
      IF(NVAL(1).NE.'/') GO TO 510
      ENCODE(5,531,RUNPRG)(NVAL(J),J=2,5)
531   FORMAT(4A1,1X)
      DO 536 I=1,20
      IF(RUNPRG.EQ.PRGLST(I)) RETURN
536   CONTINUE
      WRITE(IDLG,537) RUNPRG
537   FORMAT(' PROGRAM "',A5,'" NOT EQUIPPED WITH BANK')
      RUNPRG=0
      GO TO 600
C
C     CHECK TO SEE IF THIS IS A SPECIFICATION FOR A BANK FILE
C
510   IF(NVAL(1).NE.'@') GO TO 550
      ENCODE(10,301,FILNAM)(NVAL(J),J=2,11)
      CALL EXIST(FILNAM,IERR)
      IF(IERR.EQ.0) GO TO 511
      WRITE(IDLG,512) FILNAM
512   FORMAT(' COMMAND FILE "',A10,'" NOT FOUND')
      GO TO 600
511   IF(ICC.EQ.2) CALL RELEAS (2)
      OPEN (UNIT=2,FILE=FILNAM,ACCESS='SEQIN',DEVICE='DSK')
      ICC=2
      GO TO 600
C
C     JUST A REGULAR COMMAND ENCODE IT AN CHECK TO SEE THAT IT IS CORRECT
C
550   ENCODE(5,301,PROG) (NVAL(J),J=1,5)
      DO 509 J=1,80
      IF(PROG.EQ.PR(J)) GO TO 520
509   CONTINUE
      WRITE (IDLG,101) PROG
101   FORMAT('0COMMAND ',A5,' DOES NOT EXIST'/)
      GO TO 600
C
C     SWITCHING NEEDED TO BRANCH TO CORRECT LINKAGE - AS SUPPLIED
C     BY THE SUBSCRIPT  J FOR PR.
C
520   IF((NV*NC).GT.0) GO TO 530
      IF(J.EQ.5) GO TO 530
      IF(J.LE.2) GO TO530
      IF(J.EQ.28) GO TO 530
      IF((J.GE.30).AND.(J.LE.33)) GO TO 530
      IF(J.EQ.36) GO TO 530
      IF(J.EQ.38) GO TO 530
      IF(J.EQ.39) GO TO 530
      IF(J.EQ.40) GO TO 530
      IF((J.GE.42).AND.(J.LE.51)) GO TO 530
      IF(J.EQ.63) GO TO 530
      IF(J.EQ.68) GO TO 530
      WRITE(IDLG,540) PR(J)
540   FORMAT('0IN ORDER TO RUN ',A5,', YOU MUST HAVE SUPPLIED',
     1' DATA.  FOR DATA'/' CONTROL COMMANDS TYPE "DC" IN RESPONSE',
     2' TO "WHICH COMMAND?".')
      GO TO 600
530   GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     121,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,
     242,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,4
     3,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80),J
C 
C     CALLING FOR LINKAGE - USES OVERLAY PRINCIPLE, TOTAL MAIN
C     LINE HELD IN CORE FOR TOTAL PEROID OF RUN - LINK SECTION
C     OVERLAYED EACH TIME NEW CHAIN IS CALLED FOR.  IF STATEMENTS
C     USED TO DETERMINE IF  CORRECT LINK IS THE ONE IN CORE AT
C     THAT POINT.  ONCE THE  CORRECT OVERLAY HAS BEEN INTRODUCED
C     THE CALL WILL BE THE SAME AS ORDINARY FORTRAN PROGRAM.
C
C     IN CALL CHAINB(N,CHNFLE)
C     THE N IS THE NUMBER OF THE OVERLAY AS ASSOCIATED WITH THE 
C     LOADING PROCEEDURE.  CHNFLE IS THE NAME OF THE CHAIN FILE
C     HERE CALLED "STPK4.CHN" ON THE DISK.  THE W.M.U. MODIFICATION
C     TO THE LOADER SPECIFIES AREA 1,5 AS CHAIN FILE AREA, IT
C     HOWEVER SEARCHES THE USER AREA FIRST.
C
1     IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL DDATA(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
      LINK=1
      GO TO 600
2     IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL FETCH(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
      LINK=1
      GO TO 600
3     IF(LINK.NE.2) CALL CHAINB(2,STLINK)
      CALL BARGR(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=2
      GO TO 600
4     IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL STORE(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=1
      GO TO 600
5     IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL FORM(FMT)
      LINK=1
      GO TO 600
6     IF(LINK.NE.1)CALL CHAINB(1,STLINK)
      IF(IOUT.NE.21) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
      IF(IOUT.EQ.21) CALL PRNTHD
      LINES=2
      CALL DESC(NV,NC,MV,MC,VMN,STD,NAMES,LINES)
      LINK=1
      GO TO 600
7     IF(LINK.NE.1)CALL CHAINB(1,STLINK)
      CALL CORR(NV,NC,MV,MC,COR,NAMES)
      LINK=1
      GO TO 600
8     IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      IF(IOUT.NE.21) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
      IF(IOUT.EQ.21) CALL PRNTHD
      LINES=2
      CALL STBAS(NV,NC,MV,MC,DATA,IV,NAMES,LINES)
      LINK=1
      GO TO 600
9     IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      IF(LINK.NE.1) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
      IF(IOUT.EQ.21) CALL PRNTHD
      LINES=2
      CALL ERANA(NV,NC,MV,MC,DATA,VMN,STD,NAMES,LINES)
      LINK=1
      GO TO 600
10    IF(LINK.NE.10) CALL CHAINB(10,STLINK)
      CALL SPPLOT(NV,NC,MV,MC,DATA,SP,IV,NAMES)
      LINK=10
      GO TO 600
11    IF(LINK.NE.7) CALL CHAINB(7,STLINK)
      CALL FRIED(NV,NC,MV,MC,DATA,SP,IV,NAMES)
      LINK=7
      GO TO 600
12    IF(LINK.NE.7) CALL CHAINB(7,STLINK)
      CALL SIGNT(NV,NC,MV,MC,DATA,NAMES)
      LINK=7
      GO TO 600
13    IF(LINK.NE.13) CALL CHAINB(13,STLINK)
      CALL TRANS(NV,NC,MV,MC,DATA,VMN,STD,COR,NAMES,SP,IV)
      LINK=13
      GO TO 600
14    IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL STFREQ(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=1
      GO TO 600
15    IF(LINK.NE.10) CALL CHAINB(10,STLINK)
      CALL STXTAB(NV,NC,MV,MC,DATA,SP,IV,ISQ,NAMES)
      ISQ=0
      LINK=10
      GO TO 600
16    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STPCNT(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=3
      GO TO 600
17    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STZSC(NV,NC,MV,MC,DATA,VMN,STD,IV,NAMES)
      LINK=3
      GO TO 600
18    IF(LINK.NE.4)  CALL CHAINB(4,STLINK)
      CALL STKTAU(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=4
      GO TO 600
19    IF(LINK.NE.8) CALL CHAINB(8,STLINK)
      CALL TTEST(NV,NC,MV,MC,DATA,VMN,STD,IV,SP,NAMES)
      LINK=8
      GO TO 600
20    IF(LINK.NE.11) CALL CHAINB(11,STLINK)
      CALL CHI(NV,NC,MV,MC,DATA,IV,SP,NAMES)
      LINK=11
      GO TO 600
21    IF(LINK.NE.5) CALL CHAINB(5,STLINK)
      CALL STSRNK(NV,NC,MV,MC,DATA,IV,SP,NAMES)
      LINK=5
      GO TO 600
22    IF(LINK.NE.5) CALL CHAINB(5,STLINK)
      CALL MANN(NV,NC,MV,MC,DATA,IV,SP,NAMES)
      LINK=5
      GO TO 600
23    IF(LINK.NE.4) CALL CHAINB(4,STLINK)
      CALL WILCX(NV,NC,MV,MC,DATA,IV,SP,NAMES)
      LINK=4
      GO TO 600
24    IF(LINK.NE.4) CALL CHAINB(4,STLINK)
      CALL PCORR(NV,NC,MV,MC,COR,SP,NAMES)
      LINK=4
      GO TO 600
25    IF(LINK.NE.10) CALL CHAINB(10,STLINK)
      CALL ANOV1(NV,NC,MV,MC,DATA,VMN,STD,SP,IV,NAMES)
      LINK=10
      GO TO 600
26    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STREGR(NV,NC,MV,MC,VMN,STD,COR,IV,DATA,NAMES)
      LINK=3
      GO TO 600
27    IF(LINK.NE.4) CALL CHAINB(4,STLINK)
      CALL STSTRG(NV,NC,MV,MC,DATA,COR,VMN,STD,IV,NAMES)
      LINK=4
      GO TO 600
28    IF(LINK.NE.8) CALL CHAINB(8,STLINK)
      CALL STHEDR
      LINK=8
      GO TO 600
29    IF(LINK.NE.6) CALL CHAINB(6,STLINK)
      CALL STFACT(NV,NC,MV,MC,DATA,STD,VMN,COR,SP,IV,NAMES)
      LINK=6
      GO TO 600
30    RESTRT=1
      RETURN
31    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STHELP(1)
      LINK=3
      GO TO 600
32    RETURN
33    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STINFO
      LINK=3
      GO TO 600
34    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STPRNT(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=3
      GO TO 600
35    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STTYPE(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=3
      GO TO 600
36    IF(LINK.NE.8) CALL CHAINB(8,STLINK)
      CALL MANIP(NV,NC,MV,MC,DATA,STD,VMN,COR,NAMES,IV)
      LINK=8
      GO TO 600
37    IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      IF(IOUT.NE.21) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
      IF(IOUT.EQ.21) CALL PRNTHD
      LINES=2
      CALL DESC(NV,NC,MV,MC,VMN,STD,NAMES,LINES)
      CALL STBAS(NV,NC,MV,MC,DATA,IV,NAMES,LINES)
      CALL ERANA(NV,NC,MV,MC,DATA,VMN,STD,NAMES,LINES)
      LINK=1
      GO TO 600
38    IOUT=21
      PRINT=1
      WRITE(IDLG,105)
105   FORMAT(' OUTPUT ASSIGNED TO PRINTER')
      GO TO 600
39    IOUT=30
      WRITE(IDLG,104)
104   FORMAT(' OUTPUT ASSIGNED TO TERMINAL')
      GO TO 600
40    IF(LINK.NE.5) CALL CHAINB(5,STLINK)
      CALL STCOPY
      LINK=6
      GO TO 600
41    IF(LINK.NE.7) CALL CHAINB(7,STLINK)
       CALL ANOV2(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
      LINK=7
      GO TO 600
42    IF(LINK.NE.9) CALL CHAINB(9,STLINK)
      CALL ABANK(NV,NC,MV,MC,DATA,VMN,COR,STD,IV,SP,NAMES)
      LINK=9
      GO TO 600
43    IF(LINK.NE.12) CALL CHAINB(12,STLINK)
      CALL TAPEI(NV,NC,MV,MC,DATA,COR,VMN,STD,FMT)
      LINK=12
      GO TO 600
44    IF(LINK.NE.2) CALL CHAINB(2,STLINK)
      CALL PROB
      LINK=2
      GO TO 600
45    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STHELP(2)
      LINK=3
      GO TO 600
46    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STHELP(3)
      LINK=3
      GO TO 600
47    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STHELP(4)
      LINK=3
      GO TO 600
48    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STHELP(5)
      LINK=3
      GO TO 600
49    IF(LINK.NE.3) CALL CHAINB(3,STLINK)
      CALL STHELP(6)
      LINK=3
      GO TO 600
50    CALL EXIT
51    IF(LINK.NE.16) CALL CHAINB(16,STLINK)
      CALL DISCR(NV,NC,MV,MC,DATA,IV,SP,NAMES)
      LINK=16
      GO TO 600
52    IF(LINK.NE.10) CALL CHAINB(10,STLINK)
      CALL CORRT(NV,NC,MV,MC,VMN,COR,STD,IV,NAMES)
      LINK=10
      GO TO 600
53    IF(LINK.NE.12) CALL CHAINB(12,STLINK)
      CALL EXPSM(NV,NC,MV,MC,DATA,IV,NAMES)
      LINK=12
      GO TO 600
54    IF(LINK.NE.12) CALL CHAINB(12,STLINK)
      CALL ANVR(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
      LINK=12
      GO TO 600
55    IF(LINK.NE.5) CALL CHAINB(5,STLINK)
      CALL STPNAM(NV,NAMES)
      LINK=5
      GO TO 600
56    IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL HIST(NV,NC,MV,MC,DATA,NAMES)
      LINK=1
      GO TO 600
57    WRITE(IDLG,100)
      GO TO 600
58    IF(IOUT.EQ.21) ISQ=1
      GO TO 15
59    WRITE(IDLG,100)
      GO TO 600
60    CALL RELEAS(2)
      ICC=-4
      GO TO 600
62    IF(LINK.NE.2) CALL CHAINB(2,STLINK)
      CALL PTBIS(NV,NC,MV,MC,DATA,STD,IV,NAMES)
      LINK=2
      GO TO 600
63    IF(LINK.NE.2) CALL CHAINB(2,STLINK)
      CALL SIZZ
      LINK=2
      GO TO 600
64    IF(LINK.NE.5) CALL CHAINB(5,STLINK)
      CALL SORTCR(NV,NC,MV,MC,DATA,IV,SP,NAMES)
      LINK=5
      GOTO 600
65    IF(LINK.NE.2) CALL CHAINB(2,STLINK)
      CALL MABNK(NV,NC,MV,MC,DATA,NAMES)
      LINK=2
      GO TO 600
66    IF(LINK.NE.14) CALL CHAINB(14,STLINK)
      CALL ANOC1(NV,NC,MV,MC,DATA,VMN,NAMES,IV,SP)
      LINK=14
      GO TO 600
67    IF(LINK.NE.15) CALL CHAINB(15,STLINK)
      CALL KOLMG(NV,NC,MV,MC,DATA,VMN,STD,IV,SP,NAMES)
      LINK=15
      GO TO 600
68    IF(LINK.NE.1) CALL CHAINB(1,STLINK)
      CALL MAKEST
      LINK=1
      GO TO 600
69    WRITE(IDLG,100)
      GO TO 600
70    WRITE(IDLG,100)
      GO TO 600
71    WRITE(IDLG,100)
      GO TO 600
72    WRITE(IDLG,100)
      GO TO 600
73    WRITE(IDLG,100)
      GO TO 600
74    WRITE(IDLG,100)
      GO TO 600
75    WRITE (IDLG,100)
      GO TO 600
76    WRITE(IDLG,100)
      GO TO 600
77    WRITE(IDLG,100)
      GO TO 600
78    WRITE(IDLG,100)
      GO TO 600
79    WRITE(IDLG,100)
      GO TO 600
80    WRITE(IDLG,100)
      GO TO 600
100   FORMAT('0THIS PORTION NOT COMPLETED YET')
102   FORMAT('1',70A1)
C
C     NOTE:
C     THE STATEMENT NUMBERS 69-80 ARE USED FOR FUTURE EXPANSION. 
C     FUTURE EXPANSIONS PRESENTLY BEING CONSIDERED ARE:
C     A CONCISE  COMMAND LANGUAGE PRESENTED AT THE TIME THE COMMAND IS
C     GIVEN, RATHER THAN IN RESPONSE TO QUERIES, AND
C     MORE INSTRUCTIONS. (ITEM ANALYSIS AND ALL TESTS IN SEIGAL)
C
      END
C                                          *** STAT PACK ***
C     FUNCTION IS CALLED FOR IN PROB SUBROUTINE.
C
C     CALCULATES THE PROBABILITY. ROUTINE ORIGINALLY WRITTEN
C     AT WESTERN BY SAM ANEMA.
C
      FUNCTION FISHER(M,N,X)
C
C	REFERENCE:
C		COMMUNICATIONS OF THE A.C.M.
C		FEBRUARY 1971,  PAGE 117
C
C	COMMENT:
C	    IF DF1=1 AND DF2>1000, INVERSE INTERPOLATION IS USED;
C		FISHER=(1-1000/DF2)*FISHER(INFINITY)+1000/N*FISHER(1000)
C		(PER: M. STOLINE - 28 APR 77)
C
      IF(X.EQ.0.0)GO TO 321
      IF(M.EQ.1)GO TO 200
C**THIS STATEMENT REMOVED BECAUSE THE ROUTINE AT
C**201 IS INCORRECT**RRB**3MAY77**
C**      IF((M+N).GT.400)GO TO 201
200	NX=N
	IF(N.GT.1000)N=1000
      NA=2*(M/2)-M+2
      NB=2*(N/2)-N+2
      W=X*FLOAT(M)/FLOAT(N)
      Z=1.0/(1.0+W)
      IF(NA.EQ.1)GO TO 10
      IF(NB.EQ.1)GO TO 9
      D=Z*Z
      P=W*Z
      GO TO 100
9     P=SQRT(Z)
      D=0.5*Z*P
      P=1.0-P
      GO TO 100
10    IF(NB.EQ.1)GO TO 15
      P=SQRT(W*Z)
      D=0.5*P*Z/W
      GO TO 100
15    P=SQRT(W)
      Y=.3183098862
      D=Y*Z/P
      P=2.0*Y*ATAN(P)
100   Y=2.0*W/Z
      IF(N.LT.(NB+2))GO TO 111
      IF(NA.NE.1)GO TO 105
      DO 101 J=NB+2,N,2
      D=(1.0+FLOAT(NA)/FLOAT(J-2))*D*Z
101   P=P+D*Y/FLOAT(J-1)
      GO TO 111
105	IF((ALOG10(Z)*((N-1)/2)).GE.-37) GO TO 106
	ZK=0
	GO TO 107
106	ZK=Z**((N-1)/2)
107	D=D*ZK*FLOAT(N)/FLOAT(NB)
      P=P*ZK+W*Z*(ZK-1.0)/(Z-1.0)
111   CONTINUE
      Y=W*Z
      Z=2.0/Z
      NB=N-2
	IF(M.LT.(NA+2)) GO TO 103
      DO 102 I=NA+2,M,2
      J=I+NB
      D=Y*D*FLOAT(J)/FLOAT(I-2)
      P=P-Z*D/FLOAT(J)
102   CONTINUE
103	FISHER=1-P
	IF(FISHER.LT.0)FISHER=0
	GO TO 322
321   FISHER=1.0
322	N=NX
	IF(N.LE.1000)RETURN
	FP2=(1.-CDFN(SQRT(X)))*2.
	FISHER=(1.-1000./N)*FP2+(1000./N)*FISHER
      RETURN
201   IND=0
      MI=M
      NI=N
      XI=X
      IF(XI.GE.1)GO TO 203
      IND=1
      ISAVE=NI
      NI=MI
      MI=ISAVE
      XI=1.0/XI
203   Z1=2.0/FLOAT(9*MI)
      Z2=2.0/FLOAT(9*NI)
      Z=ABS((1.0-Z2)*XI**(.33333333)-1.0+Z1)
      Z=Z/SQRT(Z2*XI**(.66666667)+Z1)
C      IF(N.GE.4)GO TO 205
      IF(NI.GE.4)GO TO 205
      Z=Z*(1.0+.08*Z**4)/FLOAT(NI)**3
205   Z=(1.0+Z*(.196854+Z*(.115194+Z*(.000344+Z*.019527))))**4
      FISHER=.5/Z
      IF(IND.EQ.1)FISHER=1.0-FISHER
      RETURN
      END
	FUNCTION CDFN(X)
C
C	CDF OF STANDARD UNIT NORMAL
C
C	THIS FUNCTION CALCULATES THE CDF
C	PROBABILITY CDFN(Y) ASSOCIATED
C	WITH THE INPUTTED VALUE Y FOR THE
C	STANDARD UNIT NORMAL DISTRIBUTION.
C
C	SOURCE:	ABRAMOWITZ, M. AND STEGUN, I.A. (1964),
C		"HANDBOOK OF MATHEMATICAL FUNCTIONS WITH
C		FORMULAS, GRAPHS, AND MATHEMATICAL TABLES"
C		(FORMULA 26.2.17, P.932)
C
      T = 1./(1.+(.231642)*ABS(X))
      TEMP = (.319382)*T-(.356564)*T**2+(1.781478)*T**3-(1.821256)*T**4
     #+ (1.330274)*T**5
      Z = (.398942)*EXP(-.5*X**2)
      CDFN = Z*TEMP
      IF(X.GT.0) CDFN = 1.-CDFN
      RETURN
      END
C                                                      *** STAT PACK ***
C     SUBROUTINE TO PRINT PAGE HEADERS
C     CALLING SEQUENCE: CALL PRNTHD
C
C     NO ARGUMENTS ARE NECESSARY
C
      SUBROUTINE PRNTHD
      COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
      COMMON /PRNT/ LINPP,ICOPS,RUNPRG
      COMMON /EXTRA/ HEDR(70),NSZ
      COMMON /HDR/ DATRN(2),NPAGE,PROG
      NPAGE=NPAGE+1
      WRITE(IOUT,1) DATRN,HEDR,PROG,NPAGE
1     FORMAT('1STP-V4',4X,'W.M.U.',3X,2A5,6X,70A1,5X,A5,8X,'PAGE ',I4/)
      RETURN
      END
C                                 *** STAT PACK ****
C     SUBROUTINE TO READ VARIABLE FOR SUBROUTINES
C     CALLING SEQUENCE: CALL ALPHA(IVECT,MAX,N,IRET,IHELP,IERR,NAMES,NV)
C     WHERE IVECT - VECTOR USED TO SEND BACK VARIABLES TO SUBROUTINE
C                   MUST BE AT LEAST MAX LONG
C           MAX - MAXIMUM NUMBER OF VARIABLES PERMISSABLE IN SUBROUTINE
C           N - NUMBER OF VARIABLES ACTUALLY RETURNED
C           IRET - IF A ! IS TYPED INDICATE TO SUB. TO RETURN TO 
C                  WHICH COMMAND BY RETURNING A 1
C           IHELP - IF HELP IS REQUESTED RETURN A 1 OTHERWISE 0
C           IERR - RETURN A 1 IF AN ERROR WAS FOUND OTHERWISE 0
C           NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C           NV - NUMBER OF VARIABLES
C
C      ROUTINE WILL HANDLE BOTH VARIABLE NAMES AND VARIABLE NUMBERS
C      RANGES MAY BE INDICATED BY A -, AND ALL IS AVAILABLE AS A 
C      SPECIAL VARIALBE (IT WILL BE RETURNED AA A -1 IN IVECT)
C
      SUBROUTINE ALPHA(IVECT,MAX,N,IRET,IHELP,IERR,NAMES,NV)
      DIMENSION IVECT(1),NAMES(1),A(80),B(5)
      COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
      COMMON /PRNT/ LINPP,ICOPS,RUNPRG
      ISMPTY=0
      IXTAB=0
      IF(IRET.EQ.-99) ISMPTY=1
      IF(IRET.EQ.-98) IXTAB=1
      IERR=0
      IRET=0
      IHELP=0
      N=0
      THRU=0
      DO 100 I=1,MAX
100   IVECT(I)=0
      READ(ICC,1,END=101) A
1     FORMAT(80A1)
      IF(A(1).EQ.';') GO TO 8
      IF((A(1).EQ.' ').OR.(A(1).EQ.',').OR.(A(1).EQ.'-')) GO TO 8
      IF(A(1).NE.'!') GO TO 2
101   IRET=1
      RETURN
2     I=0
3     DO 4 J=1,5
4     B(J)=' '
      J=1
      I=I+1
      NUM=0
5     IF(A(I).EQ.',') GO TO 11
      IF(A(I).EQ.';') GO TO 11
      IF(A(I).EQ.' ') GO TO 11
      IF(A(I).EQ.'-') GO TO 11
      IF(NUM.NE.1) GO TO 6
      IF((A(I).LE.'9').AND.(A(I).GE.'0')) GO TO 6
      WRITE(IDLG,7)I
7     FORMAT(' COMMA MISSING IN POSITION ',I2,' OR INCORRECT NAME')
      GO TO 8
6     IF(J.GT.5) GO TO 10
      IF(J.GT.1) GO TO 9
      IF((A(I).LE.'9').AND.(A(I).GE.'0')) NUM=1
9     B(J)=A(I)
      J=J+1
10    I=I+1
      IF(I.LT.80) GO TO 5
11    IF(NUM.NE.1) GO TO 14
12    IF(B(5).NE.' ') GO TO 14
      DO 13 K=4,1,-1
13    B(K+1)=B(K)
      B(1)='0'
      GO TO 12
14    IVAL=' '
      ENCODE(5,15,IVAL) B
15    FORMAT(5A1)
      IF(NUM.EQ.1) GO TO 21
      IF(IVAL.EQ.' ') RETURN
      IF(IVAL.EQ.'*') GO TO 20
      IF(IVAL.EQ.'?') GO TO 20
      IF(IVAL.EQ.'ALL') GO TO 20
      IF(IVAL.EQ.'HELP') GO TO 24
      IF((IVAL.EQ.'EMPTY').AND.(ISMPTY.EQ.1)) GO TO 31
      DO 16 K=1,NV
      IF(NAMES(K).EQ.IVAL) GOTO 18
16    CONTINUE
      WRITE(IDLG,17)IVAL
17    FORMAT(' THE NAME "',A5,'" DOES NOT EXIST')
      GO TO 8
18    IF(THRU.EQ.1) GO TO 28
      N=N+1
      IF(N.LE.MAX) GO TO 19
27    WRITE(IDLG,26) MAX
26    FORMAT(' MAXIMUM OF ',I2,' VARIABLES FOR THIS ANALYSIS')
      GO TO 8
19    IVECT(N)=K
30    IF(A(I).EQ.'-') THRU=1
      IF((IXTAB.NE.1).OR.(THRU.NE.1)) GO TO 3
      WRITE(IDLG,32)
32    FORMAT(' THE - WILL NOT WORK HERE')
      GO TO 8
20    K=-1
      GO TO 18
C     NUMERIC VALUES CHECK TO SEE THAT THEY ARE ALL RIGHT
21    DECODE(5,22,IVAL)K
22    FORMAT(I5)
      IF((K.GT.0).AND.(K.LE.NV)) GO TO 18
      WRITE(IDLG,23) K
23    FORMAT(' VARIABLE ',I5,' DOES NOT EXIST')
8     IERR=1
25    N=0
      RETURN
24    IHELP=1
      GO TO 25
31    IVECT(1)=0
      RETURN
C
C     PART FOR THRU FUNCTION "-"
C
28    THRU=0
      INC=1
      IF(IVECT(N).EQ.K) GO TO 30
      IF(IVECT(N).GT.K) INC=-1
      M=N+(K-IVECT(N))*INC
      IF(M.GT.MAX) GO TO 27
      DO 29 J=N+1,M
29    IVECT(J)=IVECT(J-1)+INC
      N=M
      GO TO 30
      END