Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50520/stp.stp
There is 1 other file named stp.stp 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
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 TMPL(14)
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)
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
C 'UNL' IS DE-IMPLIMENTED, BUT RECOGNISED FOR COMPATABILITY.
IF(ANS.NE.'UNL'.AND.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
C
C ALLCOR WILL RESERVE THE AMOUNT OF CORE REQUESTED. IF THERE
C IS NOT ENOUGH ROOM, IERR WILL BE SENT BACK NON-ZERO.
C
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
C
C THIS PART WILL ALWAYS PRINT OUT THE PART OF "STPNEW.TXT"
C THAT HAS A "%" IN COLUMN 1.
C IF THE PPN IS [220,220] THE COPY IN [220,220] IS USED.
IERR=-1
CALL GETPPN(IEPJ,IEPG)
IF(IEPJ.EQ."220.AND.IEPG.EQ."220)GO TO 1229
CALL EXISTS('DSK','STPNEW.TXT',IERR,"2,"5)
IF(IERR.NE.0) GO TO 1221
OPEN(UNIT=10,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',
1 FILE='STPNEW.TXT',DIRECTORY='2,5')
GO TO 1228
1229 WRITE(IDLG,1230)
1230 FORMAT(/,' (USING STPNEW.TXT FROM [220,220])')
1221 CALL EXISTS('DSK','STPNEW.TXT',IERR,"220,"220)
IF(IERR.NE.0) GO TO 1600
OPEN(UNIT=10,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',
1FILE='STPNEW.TXT',DIRECTORY='220,220')
1228 WRITE(IDLG,1226)
1223 READ(10,1224,END=1227) CHR,TMPL
1224 FORMAT(A1,13A5,A4)
IF(CHR.NE.'%') GO TO 1223
DO 1231 JJ = 14, 1, -1
1231 IF(TMPL(JJ).NE.' ') GO TO 1232
JJ = 1
1232 WRITE(IDLG,1225)(TMPL(II),II=1,JJ)
1225 FORMAT(1X,13A5,A4)
GO TO 1223
1227 CLOSE(UNIT=10)
WRITE(IDLG,1226)
1226 FORMAT(/)
C
1600 IF(ICC.NE.2) WRITE(IDLG,222)
222 FORMAT('0FOR A BRIEF PROGRAM DESCRIPTION TYPE "INFO"')
IF(IERR.EQ.0)WRITE(IDLG,223)
223 FORMAT(' FOR A BRIEF DESCRIPTION OF NEW FEATURES TYPE "NEW"')
CALL MAIN(NV,NC,MV,MC,SP(I1),SP(I2),SP(I3),SP(I4),SP(I5),
1SP(I6),SP(I7),OFLL)
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
CALL RELEAS (21)
NPAGE=(NPAGE+1)*ICOPS+2
CALL PRINTS(OFLL,2,1,ICOPS,NPAGE)
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.EQ.0) CALL EXIT
ENCODE(15,8,HEDR) RUNPRG
8 FORMAT('R ',A5,8X)
HEDR(4)=0
CALL RUNUUO(HEDR)
C
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,OFLL)
DOUBLE PRECISION FILNAM,OFLL
COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ,RESTRT
COMMON/HDR/DATRN(2),NPAGE,PROG
C** SP AND IV ARE SCRATCH ARRAYS OF LENGTH MAX(MC,MV)
C** MC IS MAX NUM OF CASES(OBSEVATIONS)
C** MV IS MAX NUM OF VARIABLES
DIMENSION DATA(MC,MV),STD(1),VMN(1),COR(MV,MV),SP(1)
DIMENSION PR(80),IV(1),NAMES(1),PRGLST(20),NVAL(40)
DIMENSION FMT(80),OFMT(80)
C DEFAULTS FOR INPUT AND OUTPUT FORMATS
C DEFAULT FOR OUTPUT CHANGED FROM (8F) ON 19 JAN 81.
DATA FMTD,OFMTD/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,5HITEMA,5HSHADE,5HOFORM,5HLATIN,3HNEW,7*1/
DATA PRGLST/'FREQ','CORL','BANK','REGR','TAB',15*0/
C
C HERE ON INITIAL START AND "STOP" COMMAND(BOTH COME FROM 'MAIN').
C
STLINK='STPK4'
LINK=0
C
C SETUP THE DEFAULTS FOR INPUT AND OUTPUT FORMATS
FMT(1)=FMTD
FMT(2)=' '
OFMT(1)=OFMTD
OFMT(2)=' '
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
IF(J.EQ.73)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,OFMT)
LINK=1
GO TO 600
5 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
CALL FORM(FMT,0,FMTD)
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.19) CALL CHAINB(19,STLINK)
CALL FRIED(NV,NC,MV,MC,DATA,SP,IV,NAMES)
LINK=19
GO TO 600
12 IF(LINK.NE.19) CALL CHAINB(19,STLINK)
CALL SIGNT(NV,NC,MV,MC,DATA,NAMES)
LINK=19
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=5
GO TO 600
41 IF(LINK.NE.7) CALL CHAINB(7,STLINK)
CALL ANOV2(NV,NC,MV,MC,DATA,VMN,STD,NAMES,SP,IV)
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 IF(PRINT.EQ.1)TYPE 5001,OFLL
5001 FORMAT(/,' OUTPUT FILE IS: ',A9)
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)
C ARG IS MAXNUMBER OF LINKS
CALL SIZZ(19)
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
C** 69-72 ARE EXPERIMENTAL AND UNDOCUMENTED AS OF 13 APR 77
69 IF(LINK.NE.17)CALL CHAINB(17,STLINK)
CALL ITEMA(NV,NC,MV,MC,DATA,COR,SP,IV,IV,VMN,STD,NAMES)
LINK=17
GO TO 600
70 IF(LINK.NE.18)CALL CHAINB(18,STLINK)
CALL SHADE(NV,NC,MV,MC,DATA,IV,SP,NAMES)
LINK=18
GO TO 600
C OFORM DEFAULT CHANGED FROM (8F) TO (20F) ON JAN. 19, 81.
71 IF(LINK.NE.1)CALL CHAINB(1,STLINK)
CALL FORM(OFMT,1,OFMTD)
LINK=1
GO TO 600
72 IF(LINK.NE.19)CALL CHAINB(19,STLINK)
CALL LATIN(NV,NC,MV,MC,DATA,IV,NAMES)
LINK=19
GO TO 600
C
C WHEN THE "NEW" COMMAND IS GIVEN, THIS SECION PRINTS OUT
C THE CONTENTS OF "STPNEW.TXT" (EXCEPT THOSE LINES PRECEEDED
C BY A "%".
C IF THE PPN IS [220,220] THE COPY IN [220,220] IS USED.
73 IERR=-1
CALL GETPPN(IEPJ,IEPG)
IF(IEPJ.EQ."220.AND.IEPG.EQ."220)GO TO 229
CALL EXISTS('DSK','STPNEW.TXT',IERR,"2,"5)
IF(IERR.NE.0)GO TO 221
OPEN(UNIT=10,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',
#FILE='STPNEW.TXT',DIRECTORY='2,5')
GO TO 223
229 WRITE(IDLG,230)
230 FORMAT(/,' (USING STPNEW.TXT FROM [220,220])')
221 CALL EXISTS('DSK','STPNEW.TXT',IERR,"220,"220)
IF(IERR.NE.0)GO TO 600
OPEN(UNIT=10,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',
#FILE='STPNEW.TXT',DIRECTORY='220,220')
223 READ(10,224,END=227) CHR,(NVAL(II),II=1,14)
224 FORMAT(A1,13A5,A4)
IF(CHR.EQ.'%') GO TO 223
DO 231 JJ=14,1,-1
231 IF(NVAL(JJ).NE.' ')GO TO 232
JJ=1
232 WRITE(IDLG,225) CHR,(NVAL(II),II=1,JJ)
225 FORMAT(1X,A1,13A5,A4)
GO TO 223
227 CLOSE(UNIT=10)
WRITE(IDLG,226)
226 FORMAT(/)
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 73-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 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
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
C PUT DATE IN HEADER ONLY ONCE IF IN COMMAND FILE MODE(FOR FILCOM)
WRITE(IOUT,1) DATRN,HEDR,PROG,NPAGE
1 FORMAT('1STP-V4',4X,'W.M.U.',3X,2A5,6X,70A1,5X,A5,8X,'PAGE ',I4/)
IF(ICC.NE.2)RETURN
DATRN(1)=' '
DATRN(2)=' '
RETURN
END