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