Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/stp/stp.for
There is 1 other file named stp.for in the archive. Click here to see a list.
00100 C STAT PACK FOR W.M.U. WRITTEN BY DICK HOUCHARD . TAKE
00200 C OFF ON BABYSTAT.
00300 C ORIGINAL COPY OF BABYSTAT OBTAINED FROM MICHIGAN MARCH 1971
00400 C STAT PACK STARTED MAY 1971
00500 C EXPERIMENTAL VERSION RELEASE JULY 1971
00600 C VERSION 1 RELEASED SEPTEMBER 1971
00700 C VERSION 2 RELEASED FEB 1971
00800 C VERSION 3 RELEASED JULY 1973
00900 C VERSION 4 RELEASED SEPTEMBER 1974
01000 C VERSION 4 (MODIFIED FOR F10 AND FOROTS) RELEASE JAN 6,1975
01100 C
01200 C PROGRAM WRITTEN TO BE RUN ON DIGITAL EQUIPMENT CORPORATION
01300 C PDP-10 SYSTEM WITH LEVEL-C OR D MONITOR
01400 C FOLLOWING MODIFICATIONS FOR WESTERN MICHIGAN UNIVERSITY SYSTEM
01500 C ARE MADE USE OF IN STAT PACK
01600 C 1. MODIFICATIONS TO CHAINB AND LOADER
01700 C 2. ASSIGNMENT OF DEVICE 30 TO TTY
01800 C 3. CALLING TO PRINT ROUTINE THROUGH PRINTS
01900 C
02000 C IN ADDITION THE FOLLOWING ROUTINES AS ACQUIRED THROUGH NORM
02100 C GRANTS PROGRAM LIBRARY ARE USED
02200 C 1. CORE ALLOCATION (MAKING USE OF DYNAMIC ALLOCATION OF
02300 C SUBSCRIPTS)
02400 C A. ALLCOR - ALLOCATE AMOUNT OF CORE NEEDED TO SATISIFY
02500 C USER REQUIREMENTS
02600 C 3. EXIST - CHECK FOR EXISTENCE OF A FILE
02700 C 4. PROTEK - CHANGE PROTECTION ON A FILE IN USER AREA
02800 C 5. CHKNAM - CHECK TO SEE THAT A FILE NAME IS LEGAL
02900 C (AS USED IN CONJUNCTION WITH EXIST)
03000 C 7. JOBNUM - RETURN JOB NUMBER OF USER.
03100 C 8. GETPPN - RETURN PROJECT, PROGRAMMER NUMBER OF USER.
03200 C 9. BUSY - WAIT FOR DEVICE TO BECOME CLEAR.
03300 C 10. TYPEON - TURNS TYPE ON IF CONTROL O HAS BEEN USED
03400 C 11. USAGE - USED TO KEEP TRACK OF HOW MANY TIMES EACH
03500 C SEMESTER STP IS CALLED. ADDS 1 TO A COUNT EACH TIME.
03600 C 12. SIZE - DETERMINE OVERLAY SIZES.
03700 C 13. RUNUUO - PERFORMS R, RUN, AND COMPIL CLASS COMMANDS.
03800 C
03900 C
04000 C
04100 C AAR ================================================================
04200 C AAR
04300 C AAR *** ASSOCIATION OF AMERICAN R.R. UPDATES ***
04400 C AAR *** MADE 10/10/77 BY W.E.BARKER TO RUN ***
04500 C AAR *** ON DECSYSTEM-20 ***
04600 C AAR
04700 C AAR CHANGES MADE:
04800 C AAR
04900 C AAR 1) FOR ALL LINEPRINTER OUTPUT, REPLACE CALL
05000 C AAR TO "PRINTS" ROUTINE (WHICH HANGS UP) BY
05100 C AAR PRINTING THE FILE WHEN IT IS CLOSED. THIS
05200 C AAR IS ACCOMPLISHED WITH THE DISPOSE='LIST'
05300 C AAR OPTION.
05400 C AAR
05500 C AAR 2) CALL A MACRO ROUTINE, "EXPUNG", TO CLEAN
05600 C AAR UP DELETED FILES BEFORE EXITING, OR
05700 C AAR BEFORE RUNNING ANOTHER BANK PROGRAM.
05800 C AAR
05900 C AAR
06000 C AAR NOTE: CHANGES MADE BY THE AAR ARE NUMBERED, AND ARE
06100 C AAR SURROUNDED BY COMMENTS WITH "AAR" IN THE LEFT
06200 C AAR MARGIN. STATEMENTS WHICH WERE IN THE ORIGINAL
06300 C AAR VERSION AND HAVE BEEN COMMENTED OUT HAVE A
06400 C AAR "WMU" IN THE LEFT MARGIN.
06500 C AAR
06600 C AAR
06700 C AAR =================================================================
06800 C
06900 C
07000 C
07100 EXTERNAL FLOAT,SQRT,PROTEK,RELEAS,PRINTS
07200 EXTERNAL IFIX,EXIST,CHKNAM,GETPPN
07300 EXTERNAL SNGL,ALOG,EXP,SIN,COS,ASIN,ATAN
07400 C
07500 C FOLLOWING ROUTINES ARE USED ONLY IN MTA/I SUBROUTINE.
07600 EXTERNAL JOBNUM,BUSY
07700 DOUBLE PRECISION OFLL
07800 DIMENSION VAR(2),CAS(2),SP(1)
07900 COMMON/EXTRA/HEDR(70),NSZ,RESTRT
08000 COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
08100 COMMON /PRNT/ LINPP,ICOPS,RUNPRG
08200 COMMON /HDR/ DATRN(2),NPAGE,PROG
08300 DATA YES,VAR(1),VAR(2),CAS(1),CAS(2)/'YES','VARIA','BLES?',
08400 1'OBSER','V.? '/
08500 CALL TIME (OFIL)
08600 CALL DATE(DATRN)
08700 DECODE(5,200,OFIL)(HEDR(I),I=1,5)
08800 200 FORMAT(9A1)
08900 C CALL USAGE('STP')
09000 HEDR(3)=HEDR(2)
09100 HEDR(2)=HEDR(1)
09200 HEDR(1)='S'
09300 DO 201 I=2,4
09400 IF(HEDR(I).EQ.' ') HEDR(I)='0'
09500 201 CONTINUE
09600 HEDR(6)='.'
09700 HEDR(7)='D'
09800 HEDR(8)='A'
09900 HEDR(9)='T'
10000 ENCODE(9,200,OFLL)(HEDR(I),I=1,9)
10100 OPEN(UNIT=21,FILE=OFLL,ACCESS='SEQOUT',DEVICE='DSK')
10200 DO 203 I=1,70
10300 203 HEDR(I)=' '
10400 NSZ=0
10500 RUNPRG=0
10600 ICOPS=1
10700 PRINT=0
10800 NPAGE=0
10900 C
11000 C LINPP IS THE INDICATOR TELLING HOW MANY LINES WILL BE ALLOWED PER
11100 C PAGE IN ASSIGNED OUTPUT, IT WILL WORK CORRECTLY FOR ALL PROGRAMS
11200 C EXCEPT THOSE ASSOCIATED WITH A CHART (HIST,PLOT,BARGR,ETC)
11300 LINPP=59
11400 C
11500 C DETERMINE DEVICE DESIGNATIONS: ICC IS RESPONSES TO PROMPTING(TTY)
11600 C - IDATA IS NORMAL INPUT MODE (TTY) - IOUT IS STRICTLY OUTPUT
11700 C (HERE DESIGNATED 30(TTY)) - IDLG IS PROMPTING DIALOGUE
11800 C (HERE TTY OUT ONLY) -
11900 C IDSK IS THE RANDOM ACCESS CHANNEL (ACBNK,FETCH,STORE) -
12000 C IN ORDER TO TO RECHANNEL OUTPUT TO THE LINE PRINTER IOUT
12100 C MAY BE CHANGED TO DEVICE 21. TO COMMUNICATE WITH THE
12200 C PLEASE TERMINAL DEVICE 7 MAY BE CHANGED. IN USEING THE
12300 C @CMD.FIL, ICC WILL BE CHANGED TO 2 TO READ THE COMMAND FILE.
12400 C BOTH IOUT AND ICC WILL BE CHECKED AGAINST 21 AND 2 RESPECTIVELY
12500 C TO DETERMINE IF OUTPUT IS TO LINEPRINTER AND IF INPUT
12600 C IS FROM A COMMAND FILE
12700 C
12800 ICC=-4
12900 IDATA=5
13000 IOUT=30
13100 IDLG=-1
13200 IDSK=1
13300 C
13400 OPEN(UNIT=IDATA,DEVICE='TTY',ACCESS='SEQIN')
13500 OPEN(UNIT=IOUT,DEVICE='TTY',ACCESS='SEQOUT')
13600 WRITE(IDLG,100)
13700 100 FORMAT('1STAT PACK V4'/' WESTERN MICHIGAN UNIVERSITY')
13800 C DYNAMICALLY DIMENSIONED
13900 216 WRITE (IDLG,210)
14000 210 FORMAT('0DATA LIMITS ARE 100 OBSERVATIONS AND 7 VARIABLES.'/
14100 1' DO YOU WISH TO CHANGE THESE? (YES OR NO) ',$)
14200 READ (ICC,211)ANS
14300 211 FORMAT(A5)
14400 IF(ANS.NE.'HELP') GO TO 214
14500 WRITE(IDLG,215)
14600 215 FORMAT(' THIS IS A ONCE ONLY DIALOGUE USED TO ESTABLISH'/
14700 1' THE MAXIMUM CORE NEEDED FOR THIS RUN. A SIZE OF 7 VARIABLES'/
14800 2' EACH CONTAINING 100 OBSERVATIONS IS ASSUMED. TO CHANGE'/
14900 3' THE ASSUMED SIZE ANSWER "YES" TO THIS QUESTION. YOU WILL'/
15000 4' BE ASKED TO SUPPLY THE NUMBER OF VARIABLES(NV) AND THE'/
15100 5' NUMBER OF OBSERVATIONS(NO). TO DETERMINE IF THE DATA WILL'/
15200 6' FIT IN STP USE THE FOLLOWING FORMULA (MAX IS THE LARGER OF '/
15300 7' NO AND NV):'/
15400 8' NV*NO+NV*3+NV*NV+2*MAX<8001')
15500 GO TO 216
15600 214 MC=100
15700 MV=7
15800 IF(ANS.EQ.'UNL') GO TO 213
15900 IF(ANS.NE.YES) GO TO 220
16000 213 IF(ICC.NE.2) WRITE(IDLG,212)CAS
16100 212 FORMAT('0MAXIMUM NUMBER OF ',2A5,1X,$)
16200 300 FORMAT(I)
16300 READ(ICC,300)MC
16400 IF(ICC.NE.2) WRITE(IDLG,212)VAR
16500 READ(ICC,300)MV
16600 C
16700 C CALCULATION OF CORE NEEDED IN ALLOCATION
16800 C
16900 NV=0
17000 NC=0
17100 RESTRT=0
17200 220 ML=MC
17300 IF(MV.GT.ML)ML=MV
17400 ITOT=MC*MV+MV*3+MV*MV+ML*2
17500 IF(ANS.EQ.'UNL') GO TO 400
17600 C
17700 C ARBITRARY CUTOFF POINT AT 8000 DATA POINTS, UNLESS "UNL" HAS
17800 C BEEN SPECIFIED. ALLCOR WILL RESERVE THAT CORE IN A HIGH
17900 C SEGEMENT; IF THERE IS NOT ENOUGH ROOM FOR THAT HIGH SEGMENT
18000 C IERR WILL BE SENT BACK WITH A VALUE OTHER THAN ZERO.
18100 C
18200 IF(ITOT.GT.8000) GO TO 221
18300 400 CALL ALLCOR(ITOT,IERR,I1,SP)
18400 C IF IERR IS NOT ZERO THERE IS NOT ENOUGH ROOM OR THERE WOULD
18500 C BE NO ROOM LEFT OVER.
18600 IF(IERR.EQ.0) GO TO 230
18700 221 WRITE (IDLG,301)
18800 301 FORMAT(1X,'THERE IS NOT ENOUGH ROOM TRY AGAIN')
18900 GO TO 213
19000 230 I2=I1+MC*MV
19100 I3=I2+MV
19200 I4=I3+MV
19300 I5=I4+MV*MV
19400 I6=I5+ML
19500 I7=I6+ML
19600 IF(ICC.NE.2) WRITE(IDLG,222)
19700 222 FORMAT('0FOR A BRIEF PROGRAM DESCRIPTION TYPE "INFO"')
19800 CALL MAIN(NV,NC,MV,MC,SP(I1),SP(I2),SP(I3),SP(I4),SP(I5),
19900 1SP(I6),SP(I7))
20000 IF(RESTRT.EQ.1) GO TO 213
20100 C
20200 C DETERMINE IF "ASSIGN" HAS EVER BEEN USED IF IT HAS PRINT
20300 C OUTPUT FILE === !!! DAN MOORE - E. I. LILLY POINTED OUT THE
20400 C PROBLEM THAT AT INSTALATIONS WHERE THE DEFAULT PROTECTION CODE
20500 C SAVED FILES AT LOGOUT TIME THE SYSTEM TENDED TO FILL UP WITH STP
20600 C OUTPUT FILES. A PATCH HAS BEEN IMPLEMENTED TO AVOID THIS PROBLEM
20700 C BY DELETING THE OUTPUT FILE IF AN ASSIGN OR MAKE COMMAND HAS NOT
20800 C BEEN USED. ALSO THE / METHOD OF EXECUTING ANOTHER PROGRAM WITHOUT
20900 C GOING THRU MONITOR HAS BEEN IMPLEMENTED AND PROCEEDS THRU THIS
21000 C SECTION.
21100 C
21200 IF (NPAGE.EQ.0) GO TO 9
21300 C WMU
21400 C WMU
21500 C WMU CALL RELEAS (21)
21600 C WMU NPAGE=(NPAGE+1)*ICOPS+2
21700 C WMU CALL PRINTS(OFLL,2,1,ICOPS,NPAGE)
21800 C WMU
21900 C WMU
22000 C
22100 C AAR
22200 C AAR *** AAR CHANGE 1 ***
22300 C AAR PRINT FILE BY USING LIST OPTION OF CLOSE.
22400 C AAR
22500 C AAR ----
22600 C AAR !
22700 CLOSE(UNIT=21,DISPOSE='LIST')
22800 C AAR !
22900 C AAR ----
23000 C AAR
23100 GO TO 10
23200 C
23300 C FOLLOWING WAS RECOMENDED BY E. I. LILLY COMPANY (DAN MOORE) TO
23400 C DELETE PRINT FILES IF THEY WERE NOT NEEDED.
23500 C
23600 9 CLOSE (UNIT=21,DISPOSE='DELETE')
23700 10 IF(RUNPRG.NE.0)GO TO 77777
23800 C AAR
23900 C AAR *** AAR CHANGE 2 ***
24000 C AAR EXPUNGE DELETED FILES.
24100 C AAR
24200 C AAR ----
24300 C AAR !
24350 C[W1] DON'T HAVE THE SOURCE FOR THIS ANYMORE
24400 C CALL EXPUNG
24500 C AAR !
24600 C AAR ----
24700 C AAR
24800 CALL EXIT
24900 77777 ENCODE(15,8,HEDR) RUNPRG
25000 8 FORMAT('R ',A5,8X)
25100 HEDR(4)=0
25200 C AAR
25300 C AAR ----
25400 C AAR !
25500 CALL EXPUNG
25600 C AAR !
25700 C AAR ----
25800 C AAR
25900 C
26000 CALL RUNUUO(HEDR)
26100 C ****************************************************************
26200 C DUMMIES USED TO PULL IN ROUTINES USED IN CHAINS
26300 C
26400 C=A**.5
26500 WRITE(3) A
26600 READ(1,7,END=10,ERR=10) A
26700 7 FORMAT(G,O)
26800 READ(1#2) A
26900 CLOSE (UNIT=1)
27000 END
27100 SUBROUTINE MAIN(NV,NC,MV,MC,DATA,STD,VMN,COR,SP,IV,NAMES)
27200 DOUBLE PRECISION FILNAM
27300 COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
27400 COMMON /PRNT/ LINPP,ICOPS,RUNPRG
27500 COMMON/EXTRA/HEDR(70),NSZ,RESTRT
27600 COMMON/HDR/DATRN(2),NPAGE,PROG
27700 DIMENSION DATA(MC,MV),STD(1),VMN(1),COR(MV,MV),SP(1)
27800 DIMENSION PR(80),IV(1),FMT(80),NAMES(1),PRGLST(20),NVAL(40)
27900 DATA FMT(1),FMT(2)/'(20F)',' '/
28000 C
28100 C COMMAND STORAGE AREA - EACH ENTRY IS A COMMAND IMPLEMENTED, OR AN
28200 C INTENDED COMMAND
28300 C
28400 DATA PR/4HDATA,5HFETCH,5HBARGR,5HSTORE,4HFORM,4HDESC,4HCORR,
28500 15HBASIC,5HERANA,4HPLOT,5HFRIED,4HSIGN,5HTRANS,4HFREQ,4HXTAB,
28600 25HPCENT,5HZSCOR,5HKENDL,5HTTEST,5HCHISQ,5HSRANK,4HMANN,5HWILCX,
28700 35HPCORR,5HANOV1,4HREGR,5HSTEPR,5HTITLE,5HFACTO,4HSTOP,4HHELP,
28800 44HFINI,4HINFO,5HPRINT,4HTYPE,5HMANIP,5HESTAT,5HASSIG,5HDEASS,
28900 55HCOPYS,5HANOV2,5HACBNK,5HMTA/I,4HPROB,2HDC,2HST,2HGR,2HIA,
29000 62HPC,3HSYS,5HDISCR,5HCORRT,5HCVSMT,5H1WAYR,4HNAME,4HHIST,4H@CMD,
29100 75HXTAB*,5HCRCMD,5HRETUR,4HSAVE,5HPTBIS,4HSIZE,4HSORT,5HMABNK,
29200 85HANOC1,4HKOLM,4HMAKE,12*1/
29300 DATA PRGLST/'FREQ','CORL','BANK','REGR','TAB',15*0/
29400 STLINK='STPK4'
29500 LINK=0
29600 C
29700 C COMMON RE-ENTRY POINT FOR RETURN FROM ALL BRANCHES TO STP
29800 C SUBROUTINES
29900 C
30000 600 CALL TYPEON
30100 WRITE(IDLG,202)
30200 202 FORMAT(//'0WHICH COMMAND? ',$)
30300 READ (ICC,301,END=60) NVAL
30400 301 FORMAT(80A1)
30500 IF(NVAL(1).EQ.'!') GO TO 600
30600 DO 106 I=40,1,-1
30700 IF(NVAL(I).NE.' ') GO TO 107
30800 106 CONTINUE
30900 107 IF(ICC.EQ.2) WRITE(IDLG,103) (NVAL(J),J=1,I)
31000 103 FORMAT('+',40A1/)
31100 C
31200 C CHECK TO SEE IF THIS IS A TRANSFER TO ANOTHER BANK PROGRAM
31300 C
31400 IF(NVAL(1).NE.'/') GO TO 510
31500 ENCODE(5,531,RUNPRG)(NVAL(J),J=2,5)
31600 531 FORMAT(4A1,1X)
31700 DO 536 I=1,20
31800 IF(RUNPRG.EQ.PRGLST(I)) RETURN
31900 536 CONTINUE
32000 WRITE(IDLG,537) RUNPRG
32100 537 FORMAT(' PROGRAM "',A5,'" NOT EQUIPPED WITH BANK')
32200 RUNPRG=0
32300 GO TO 600
32400 C
32500 C CHECK TO SEE IF THIS IS A SPECIFICATION FOR A BANK FILE
32600 C
32700 510 IF(NVAL(1).NE.'@') GO TO 550
32800 ENCODE(10,301,FILNAM)(NVAL(J),J=2,11)
32900 CALL EXIST(FILNAM,IERR)
33000 IF(IERR.EQ.0) GO TO 511
33100 WRITE(IDLG,512) FILNAM
33200 512 FORMAT(' COMMAND FILE "',A10,'" NOT FOUND')
33300 GO TO 600
33400 511 IF(ICC.EQ.2) CALL RELEAS (2)
33500 OPEN (UNIT=2,FILE=FILNAM,ACCESS='SEQIN',DEVICE='DSK')
33600 ICC=2
33700 GO TO 600
33800 C
33900 C JUST A REGULAR COMMAND ENCODE IT AN CHECK TO SEE THAT IT IS CORRECT
34000 C
34100 550 ENCODE(5,301,PROG) (NVAL(J),J=1,5)
34200 DO 509 J=1,80
34300 IF(PROG.EQ.PR(J)) GO TO 520
34400 509 CONTINUE
34500 WRITE (IDLG,101) PROG
34600 101 FORMAT('0COMMAND ',A5,' DOES NOT EXIST'/)
34700 GO TO 600
34800 C
34900 C SWITCHING NEEDED TO BRANCH TO CORRECT LINKAGE - AS SUPPLIED
35000 C BY THE SUBSCRIPT J FOR PR.
35100 C
35200 520 IF((NV*NC).GT.0) GO TO 530
35300 IF(J.EQ.5) GO TO 530
35400 IF(J.LE.2) GO TO530
35500 IF(J.EQ.28) GO TO 530
35600 IF((J.GE.30).AND.(J.LE.33)) GO TO 530
35700 IF(J.EQ.36) GO TO 530
35800 IF(J.EQ.38) GO TO 530
35900 IF(J.EQ.39) GO TO 530
36000 IF(J.EQ.40) GO TO 530
36100 IF((J.GE.42).AND.(J.LE.51)) GO TO 530
36200 IF(J.EQ.63) GO TO 530
36300 IF(J.EQ.68) GO TO 530
36400 WRITE(IDLG,540) PR(J)
36500 540 FORMAT('0IN ORDER TO RUN ',A5,', YOU MUST HAVE SUPPLIED',
36600 1' DATA. FOR DATA'/' CONTROL COMMANDS TYPE "DC" IN RESPONSE',
36700 2' TO "WHICH COMMAND?".')
36800 GO TO 600
36900 530 GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
37000 121,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,
37100 242,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,4
37200 3,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80),J
37300 C
37400 C CALLING FOR LINKAGE - USES OVERLAY PRINCIPLE, TOTAL MAIN
37500 C LINE HELD IN CORE FOR TOTAL PEROID OF RUN - LINK SECTION
37600 C OVERLAYED EACH TIME NEW CHAIN IS CALLED FOR. IF STATEMENTS
37700 C USED TO DETERMINE IF CORRECT LINK IS THE ONE IN CORE AT
37800 C THAT POINT. ONCE THE CORRECT OVERLAY HAS BEEN INTRODUCED
37900 C THE CALL WILL BE THE SAME AS ORDINARY FORTRAN PROGRAM.
38000 C
38100 C IN CALL CHAINB(N,CHNFLE)
38200 C THE N IS THE NUMBER OF THE OVERLAY AS ASSOCIATED WITH THE
38300 C LOADING PROCEEDURE. CHNFLE IS THE NAME OF THE CHAIN FILE
38400 C HERE CALLED "STPK4.CHN" ON THE DISK. THE W.M.U. MODIFICATION
38500 C TO THE LOADER SPECIFIES AREA 1,5 AS CHAIN FILE AREA, IT
38600 C HOWEVER SEARCHES THE USER AREA FIRST.
38700 C
38800 1 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
38900 CALL DDATA(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
39000 LINK=1
39100 GO TO 600
39200 2 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
39300 CALL FETCH(NV,NC,MV,MC,DATA,VMN,COR,STD,FMT,NAMES)
39400 LINK=1
39500 GO TO 600
39600 3 IF(LINK.NE.2) CALL CHAINB(2,STLINK)
39700 CALL BARGR(NV,NC,MV,MC,DATA,IV,NAMES)
39800 LINK=2
39900 GO TO 600
40000 4 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
40100 CALL STORE(NV,NC,MV,MC,DATA,IV,NAMES)
40200 LINK=1
40300 GO TO 600
40400 5 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
40500 CALL FORM(FMT)
40600 LINK=1
40700 GO TO 600
40800 6 IF(LINK.NE.1)CALL CHAINB(1,STLINK)
40900 IF(IOUT.NE.21) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
41000 IF(IOUT.EQ.21) CALL PRNTHD
41100 LINES=2
41200 CALL DESC(NV,NC,MV,MC,VMN,STD,NAMES,LINES)
41300 LINK=1
41400 GO TO 600
41500 7 IF(LINK.NE.1)CALL CHAINB(1,STLINK)
41600 CALL CORR(NV,NC,MV,MC,COR,NAMES)
41700 LINK=1
41800 GO TO 600
41900 8 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
42000 IF(IOUT.NE.21) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
42100 IF(IOUT.EQ.21) CALL PRNTHD
42200 LINES=2
42300 CALL STBAS(NV,NC,MV,MC,DATA,IV,NAMES,LINES)
42400 LINK=1
42500 GO TO 600
42600 9 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
42700 IF(LINK.NE.1) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
42800 IF(IOUT.EQ.21) CALL PRNTHD
42900 LINES=2
43000 CALL ERANA(NV,NC,MV,MC,DATA,VMN,STD,NAMES,LINES)
43100 LINK=1
43200 GO TO 600
43300 10 IF(LINK.NE.10) CALL CHAINB(10,STLINK)
43400 CALL SPPLOT(NV,NC,MV,MC,DATA,SP,IV,NAMES)
43500 LINK=10
43600 GO TO 600
43700 11 IF(LINK.NE.7) CALL CHAINB(7,STLINK)
43800 CALL FRIED(NV,NC,MV,MC,DATA,SP,IV,NAMES)
43900 LINK=7
44000 GO TO 600
44100 12 IF(LINK.NE.7) CALL CHAINB(7,STLINK)
44200 CALL SIGNT(NV,NC,MV,MC,DATA,NAMES)
44300 LINK=7
44400 GO TO 600
44500 13 IF(LINK.NE.13) CALL CHAINB(13,STLINK)
44600 CALL TRANS(NV,NC,MV,MC,DATA,VMN,STD,COR,NAMES,SP,IV)
44700 LINK=13
44800 GO TO 600
44900 14 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
45000 CALL STFREQ(NV,NC,MV,MC,DATA,IV,NAMES)
45100 LINK=1
45200 GO TO 600
45300 15 IF(LINK.NE.10) CALL CHAINB(10,STLINK)
45400 CALL STXTAB(NV,NC,MV,MC,DATA,SP,IV,ISQ,NAMES)
45500 ISQ=0
45600 LINK=10
45700 GO TO 600
45800 16 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
45900 CALL STPCNT(NV,NC,MV,MC,DATA,IV,NAMES)
46000 LINK=3
46100 GO TO 600
46200 17 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
46300 CALL STZSC(NV,NC,MV,MC,DATA,VMN,STD,IV,NAMES)
46400 LINK=3
46500 GO TO 600
46600 18 IF(LINK.NE.4) CALL CHAINB(4,STLINK)
46700 CALL STKTAU(NV,NC,MV,MC,DATA,IV,NAMES)
46800 LINK=4
46900 GO TO 600
47000 19 IF(LINK.NE.8) CALL CHAINB(8,STLINK)
47100 CALL TTEST(NV,NC,MV,MC,DATA,VMN,STD,IV,SP,NAMES)
47200 LINK=8
47300 GO TO 600
47400 20 IF(LINK.NE.11) CALL CHAINB(11,STLINK)
47500 CALL CHI(NV,NC,MV,MC,DATA,IV,SP,NAMES)
47600 LINK=11
47700 GO TO 600
47800 21 IF(LINK.NE.5) CALL CHAINB(5,STLINK)
47900 CALL STSRNK(NV,NC,MV,MC,DATA,IV,SP,NAMES)
48000 LINK=5
48100 GO TO 600
48200 22 IF(LINK.NE.5) CALL CHAINB(5,STLINK)
48300 CALL MANN(NV,NC,MV,MC,DATA,IV,SP,NAMES)
48400 LINK=5
48500 GO TO 600
48600 23 IF(LINK.NE.4) CALL CHAINB(4,STLINK)
48700 CALL WILCX(NV,NC,MV,MC,DATA,IV,SP,NAMES)
48800 LINK=4
48900 GO TO 600
49000 24 IF(LINK.NE.4) CALL CHAINB(4,STLINK)
49100 CALL PCORR(NV,NC,MV,MC,COR,SP,NAMES)
49200 LINK=4
49300 GO TO 600
49400 25 IF(LINK.NE.10) CALL CHAINB(10,STLINK)
49500 CALL ANOV1(NV,NC,MV,MC,DATA,VMN,STD,SP,IV,NAMES)
49600 LINK=10
49700 GO TO 600
49800 26 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
49900 CALL STREGR(NV,NC,MV,MC,VMN,STD,COR,IV,DATA,NAMES)
50000 LINK=3
50100 GO TO 600
50200 27 IF(LINK.NE.4) CALL CHAINB(4,STLINK)
50300 CALL STSTRG(NV,NC,MV,MC,DATA,COR,VMN,STD,IV,NAMES)
50400 LINK=4
50500 GO TO 600
50600 28 IF(LINK.NE.8) CALL CHAINB(8,STLINK)
50700 CALL STHEDR
50800 LINK=8
50900 GO TO 600
51000 29 IF(LINK.NE.6) CALL CHAINB(6,STLINK)
51100 CALL STFACT(NV,NC,MV,MC,DATA,STD,VMN,COR,SP,IV,NAMES)
51200 LINK=6
51300 GO TO 600
51400 30 RESTRT=1
51500 RETURN
51600 31 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
51700 CALL STHELP(1)
51800 LINK=3
51900 GO TO 600
52000 32 RETURN
52100 33 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
52200 CALL STINFO
52300 LINK=3
52400 GO TO 600
52500 34 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
52600 CALL STPRNT(NV,NC,MV,MC,DATA,IV,NAMES)
52700 LINK=3
52800 GO TO 600
52900 35 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
53000 CALL STTYPE(NV,NC,MV,MC,DATA,IV,NAMES)
53100 LINK=3
53200 GO TO 600
53300 36 IF(LINK.NE.8) CALL CHAINB(8,STLINK)
53400 CALL MANIP(NV,NC,MV,MC,DATA,STD,VMN,COR,NAMES,IV)
53500 LINK=8
53600 GO TO 600
53700 37 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
53800 IF(IOUT.NE.21) WRITE(IOUT,102)(HEDR(K),K=1,NSZ)
53900 IF(IOUT.EQ.21) CALL PRNTHD
54000 LINES=2
54100 CALL DESC(NV,NC,MV,MC,VMN,STD,NAMES,LINES)
54200 CALL STBAS(NV,NC,MV,MC,DATA,IV,NAMES,LINES)
54300 CALL ERANA(NV,NC,MV,MC,DATA,VMN,STD,NAMES,LINES)
54400 LINK=1
54500 GO TO 600
54600 38 IOUT=21
54700 PRINT=1
54800 WRITE(IDLG,105)
54900 105 FORMAT(' OUTPUT ASSIGNED TO PRINTER')
55000 GO TO 600
55100 39 IOUT=30
55200 WRITE(IDLG,104)
55300 104 FORMAT(' OUTPUT ASSIGNED TO TERMINAL')
55400 GO TO 600
55500 40 IF(LINK.NE.5) CALL CHAINB(5,STLINK)
55600 CALL STCOPY
55700 LINK=6
55800 GO TO 600
55900 41 IF(LINK.NE.7) CALL CHAINB(7,STLINK)
56000 CALL ANOV2(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
56100 LINK=7
56200 GO TO 600
56300 42 IF(LINK.NE.9) CALL CHAINB(9,STLINK)
56400 CALL ABANK(NV,NC,MV,MC,DATA,VMN,COR,STD,IV,SP,NAMES)
56500 LINK=9
56600 GO TO 600
56700 43 IF(LINK.NE.12) CALL CHAINB(12,STLINK)
56800 CALL TAPEI(NV,NC,MV,MC,DATA,COR,VMN,STD,FMT)
56900 LINK=12
57000 GO TO 600
57100 44 IF(LINK.NE.2) CALL CHAINB(2,STLINK)
57200 CALL PROB
57300 LINK=2
57400 GO TO 600
57500 45 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
57600 CALL STHELP(2)
57700 LINK=3
57800 GO TO 600
57900 46 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
58000 CALL STHELP(3)
58100 LINK=3
58200 GO TO 600
58300 47 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
58400 CALL STHELP(4)
58500 LINK=3
58600 GO TO 600
58700 48 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
58800 CALL STHELP(5)
58900 LINK=3
59000 GO TO 600
59100 49 IF(LINK.NE.3) CALL CHAINB(3,STLINK)
59200 CALL STHELP(6)
59300 LINK=3
59400 GO TO 600
59500 50 CALL EXIT
59600 51 IF(LINK.NE.16) CALL CHAINB(16,STLINK)
59700 CALL DISCR(NV,NC,MV,MC,DATA,IV,SP,NAMES)
59800 LINK=16
59900 GO TO 600
60000 52 IF(LINK.NE.10) CALL CHAINB(10,STLINK)
60100 CALL CORRT(NV,NC,MV,MC,VMN,COR,STD,IV,NAMES)
60200 LINK=10
60300 GO TO 600
60400 53 IF(LINK.NE.12) CALL CHAINB(12,STLINK)
60500 CALL EXPSM(NV,NC,MV,MC,DATA,IV,NAMES)
60600 LINK=12
60700 GO TO 600
60800 54 IF(LINK.NE.12) CALL CHAINB(12,STLINK)
60900 CALL ANVR(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
61000 LINK=12
61100 GO TO 600
61200 55 IF(LINK.NE.5) CALL CHAINB(5,STLINK)
61300 CALL STPNAM(NV,NAMES)
61400 LINK=5
61500 GO TO 600
61600 56 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
61700 CALL HIST(NV,NC,MV,MC,DATA,NAMES)
61800 LINK=1
61900 GO TO 600
62000 57 WRITE(IDLG,100)
62100 GO TO 600
62200 58 IF(IOUT.EQ.21) ISQ=1
62300 GO TO 15
62400 59 WRITE(IDLG,100)
62500 GO TO 600
62600 60 CALL RELEAS(2)
62700 ICC=-4
62800 GO TO 600
62900 62 IF(LINK.NE.2) CALL CHAINB(2,STLINK)
63000 CALL PTBIS(NV,NC,MV,MC,DATA,STD,IV,NAMES)
63100 LINK=2
63200 GO TO 600
63300 63 IF(LINK.NE.2) CALL CHAINB(2,STLINK)
63400 CALL SIZZ
63500 LINK=2
63600 GO TO 600
63700 64 IF(LINK.NE.5) CALL CHAINB(5,STLINK)
63800 CALL SORTCR(NV,NC,MV,MC,DATA,IV,SP,NAMES)
63900 LINK=5
64000 GOTO 600
64100 65 IF(LINK.NE.2) CALL CHAINB(2,STLINK)
64200 CALL MABNK(NV,NC,MV,MC,DATA,NAMES)
64300 LINK=2
64400 GO TO 600
64500 66 IF(LINK.NE.14) CALL CHAINB(14,STLINK)
64600 CALL ANOC1(NV,NC,MV,MC,DATA,VMN,NAMES,IV,SP)
64700 LINK=14
64800 GO TO 600
64900 67 IF(LINK.NE.15) CALL CHAINB(15,STLINK)
65000 CALL KOLMG(NV,NC,MV,MC,DATA,VMN,STD,IV,SP,NAMES)
65100 LINK=15
65200 GO TO 600
65300 68 IF(LINK.NE.1) CALL CHAINB(1,STLINK)
65400 CALL MAKEST
65500 LINK=1
65600 GO TO 600
65700 69 WRITE(IDLG,100)
65800 GO TO 600
65900 70 WRITE(IDLG,100)
66000 GO TO 600
66100 71 WRITE(IDLG,100)
66200 GO TO 600
66300 72 WRITE(IDLG,100)
66400 GO TO 600
66500 73 WRITE(IDLG,100)
66600 GO TO 600
66700 74 WRITE(IDLG,100)
66800 GO TO 600
66900 75 WRITE (IDLG,100)
67000 GO TO 600
67100 76 WRITE(IDLG,100)
67200 GO TO 600
67300 77 WRITE(IDLG,100)
67400 GO TO 600
67500 78 WRITE(IDLG,100)
67600 GO TO 600
67700 79 WRITE(IDLG,100)
67800 GO TO 600
67900 80 WRITE(IDLG,100)
68000 GO TO 600
68100 100 FORMAT('0THIS PORTION NOT COMPLETED YET')
68200 102 FORMAT('1',70A1)
68300 C
68400 C NOTE:
68500 C THE STATEMENT NUMBERS 69-80 ARE USED FOR FUTURE EXPANSION.
68600 C FUTURE EXPANSIONS PRESENTLY BEING CONSIDERED ARE:
68700 C A CONCISE COMMAND LANGUAGE PRESENTED AT THE TIME THE COMMAND IS
68800 C GIVEN, RATHER THAN IN RESPONSE TO QUERIES, AND
68900 C MORE INSTRUCTIONS. (ITEM ANALYSIS AND ALL TESTS IN SEIGAL)
69000 C
69100 END
69200 C *** STAT PACK ***
69300 C FUNCTION IS CALLED FOR IN PROB SUBROUTINE.
69400 C
69500 C CALCULATES THE PROBABILITY. ROUTINE ORIGINALLY WRITTEN
69600 C AT WESTERN BY SAM ANEMA.
69700 C
69800 FUNCTION FISHER(M,N,X)
69900 C
70000 C REFERENCE:
70100 C COMMUNICATIONS OF THE A.C.M.
70200 C FEBRUARY 1971, PAGE 117
70300 C
70400 C COMMENT:
70500 C IF DF1=1 AND DF2>1000, INVERSE INTERPOLATION IS USED;
70600 C FISHER=(1-1000/DF2)*FISHER(INFINITY)+1000/N*FISHER(1000)
70700 C (PER: M. STOLINE - 28 APR 77)
70800 C
70900 IF(X.EQ.0.0)GO TO 321
71000 IF(M.EQ.1)GO TO 200
71100 C**THIS STATEMENT REMOVED BECAUSE THE ROUTINE AT
71200 C**201 IS INCORRECT**RRB**3MAY77**
71300 C** IF((M+N).GT.400)GO TO 201
71400 200 NX=N
71500 IF(N.GT.1000)N=1000
71600 NA=2*(M/2)-M+2
71700 NB=2*(N/2)-N+2
71800 W=X*FLOAT(M)/FLOAT(N)
71900 Z=1.0/(1.0+W)
72000 IF(NA.EQ.1)GO TO 10
72100 IF(NB.EQ.1)GO TO 9
72200 D=Z*Z
72300 P=W*Z
72400 GO TO 100
72500 9 P=SQRT(Z)
72600 D=0.5*Z*P
72700 P=1.0-P
72800 GO TO 100
72900 10 IF(NB.EQ.1)GO TO 15
73000 P=SQRT(W*Z)
73100 D=0.5*P*Z/W
73200 GO TO 100
73300 15 P=SQRT(W)
73400 Y=.3183098862
73500 D=Y*Z/P
73600 P=2.0*Y*ATAN(P)
73700 100 Y=2.0*W/Z
73800 IF(N.LT.(NB+2))GO TO 111
73900 IF(NA.NE.1)GO TO 105
74000 DO 101 J=NB+2,N,2
74100 D=(1.0+FLOAT(NA)/FLOAT(J-2))*D*Z
74200 101 P=P+D*Y/FLOAT(J-1)
74300 GO TO 111
74400 105 IF((ALOG10(Z)*((N-1)/2)).GE.-37) GO TO 106
74500 ZK=0
74600 GO TO 107
74700 106 ZK=Z**((N-1)/2)
74800 107 D=D*ZK*FLOAT(N)/FLOAT(NB)
74900 P=P*ZK+W*Z*(ZK-1.0)/(Z-1.0)
75000 111 CONTINUE
75100 Y=W*Z
75200 Z=2.0/Z
75300 NB=N-2
75400 IF(M.LT.(NA+2)) GO TO 103
75500 DO 102 I=NA+2,M,2
75600 J=I+NB
75700 D=Y*D*FLOAT(J)/FLOAT(I-2)
75800 P=P-Z*D/FLOAT(J)
75900 102 CONTINUE
76000 103 FISHER=1-P
76100 IF(FISHER.LT.0)FISHER=0
76200 GO TO 322
76300 321 FISHER=1.0
76400 322 N=NX
76500 IF(N.LE.1000)RETURN
76600 FP2=(1.-CDFN(SQRT(X)))*2.
76700 FISHER=(1.-1000./N)*FP2+(1000./N)*FISHER
76800 RETURN
76900 201 IND=0
77000 MI=M
77100 NI=N
77200 XI=X
77300 IF(XI.GE.1)GO TO 203
77400 IND=1
77500 ISAVE=NI
77600 NI=MI
77700 MI=ISAVE
77800 XI=1.0/XI
77900 203 Z1=2.0/FLOAT(9*MI)
78000 Z2=2.0/FLOAT(9*NI)
78100 Z=ABS((1.0-Z2)*XI**(.33333333)-1.0+Z1)
78200 Z=Z/SQRT(Z2*XI**(.66666667)+Z1)
78300 C IF(N.GE.4)GO TO 205
78400 IF(NI.GE.4)GO TO 205
78500 Z=Z*(1.0+.08*Z**4)/FLOAT(NI)**3
78600 205 Z=(1.0+Z*(.196854+Z*(.115194+Z*(.000344+Z*.019527))))**4
78700 FISHER=.5/Z
78800 IF(IND.EQ.1)FISHER=1.0-FISHER
78900 RETURN
79000 END
79100 FUNCTION CDFN(X)
79200 C
79300 C CDF OF STANDARD UNIT NORMAL
79400 C
79500 C THIS FUNCTION CALCULATES THE CDF
79600 C PROBABILITY CDFN(Y) ASSOCIATED
79700 C WITH THE INPUTTED VALUE Y FOR THE
79800 C STANDARD UNIT NORMAL DISTRIBUTION.
79900 C
80000 C SOURCE: ABRAMOWITZ, M. AND STEGUN, I.A. (1964),
80100 C "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH
80200 C FORMULAS, GRAPHS, AND MATHEMATICAL TABLES"
80300 C (FORMULA 26.2.17, P.932)
80400 C
80500 T = 1./(1.+(.231642)*ABS(X))
80600 TEMP = (.319382)*T-(.356564)*T**2+(1.781478)*T**3-(1.821256)*T**4
80700 #+ (1.330274)*T**5
80800 Z = (.398942)*EXP(-.5*X**2)
80900 CDFN = Z*TEMP
81000 IF(X.GT.0) CDFN = 1.-CDFN
81100 RETURN
81200 END
81300 C *** STAT PACK ***
81400 C SUBROUTINE TO PRINT PAGE HEADERS
81500 C CALLING SEQUENCE: CALL PRNTHD
81600 C
81700 C NO ARGUMENTS ARE NECESSARY
81800 C
81900 SUBROUTINE PRNTHD
82000 COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
82100 COMMON /PRNT/ LINPP,ICOPS,RUNPRG
82200 COMMON /EXTRA/ HEDR(70),NSZ
82300 COMMON /HDR/ DATRN(2),NPAGE,PROG
82400 NPAGE=NPAGE+1
82500 WRITE(IOUT,1) DATRN,HEDR,PROG,NPAGE
82600 1 FORMAT('1STP-V4',4X,'W.M.U.',3X,2A5,6X,70A1,5X,A5,8X,'PAGE ',I4/)
82700 RETURN
82800 END
82900 C *** STAT PACK ****
83000 C SUBROUTINE TO READ VARIABLE FOR SUBROUTINES
83100 C CALLING SEQUENCE: CALL ALPHA(IVECT,MAX,N,IRET,IHELP,IERR,NAMES,NV)
83200 C WHERE IVECT - VECTOR USED TO SEND BACK VARIABLES TO SUBROUTINE
83300 C MUST BE AT LEAST MAX LONG
83400 C MAX - MAXIMUM NUMBER OF VARIABLES PERMISSABLE IN SUBROUTINE
83500 C N - NUMBER OF VARIABLES ACTUALLY RETURNED
83600 C IRET - IF A ! IS TYPED INDICATE TO SUB. TO RETURN TO
83700 C WHICH COMMAND BY RETURNING A 1
83800 C IHELP - IF HELP IS REQUESTED RETURN A 1 OTHERWISE 0
83900 C IERR - RETURN A 1 IF AN ERROR WAS FOUND OTHERWISE 0
84000 C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
84100 C NV - NUMBER OF VARIABLES
84200 C
84300 C ROUTINE WILL HANDLE BOTH VARIABLE NAMES AND VARIABLE NUMBERS
84400 C RANGES MAY BE INDICATED BY A -, AND ALL IS AVAILABLE AS A
84500 C SPECIAL VARIALBE (IT WILL BE RETURNED AA A -1 IN IVECT)
84600 C
84700 SUBROUTINE ALPHA(IVECT,MAX,N,IRET,IHELP,IERR,NAMES,NV)
84800 DIMENSION IVECT(1),NAMES(1),A(80),B(5)
84900 COMMON /DEV/ICC,IDATA,IOUT,IDLG,IDSK
85000 COMMON /PRNT/ LINPP,ICOPS,RUNPRG
85100 ISMPTY=0
85200 IXTAB=0
85300 IF(IRET.EQ.-99) ISMPTY=1
85400 IF(IRET.EQ.-98) IXTAB=1
85500 IERR=0
85600 IRET=0
85700 IHELP=0
85800 N=0
85900 THRU=0
86000 DO 100 I=1,MAX
86100 100 IVECT(I)=0
86200 READ(ICC,1,END=101) A
86300 1 FORMAT(80A1)
86400 IF(A(1).EQ.';') GO TO 8
86500 IF((A(1).EQ.' ').OR.(A(1).EQ.',').OR.(A(1).EQ.'-')) GO TO 8
86600 IF(A(1).NE.'!') GO TO 2
86700 101 IRET=1
86800 RETURN
86900 2 I=0
87000 3 DO 4 J=1,5
87100 4 B(J)=' '
87200 J=1
87300 I=I+1
87400 NUM=0
87500 5 IF(A(I).EQ.',') GO TO 11
87600 IF(A(I).EQ.';') GO TO 11
87700 IF(A(I).EQ.' ') GO TO 11
87800 IF(A(I).EQ.'-') GO TO 11
87900 IF(NUM.NE.1) GO TO 6
88000 IF((A(I).LE.'9').AND.(A(I).GE.'0')) GO TO 6
88100 WRITE(IDLG,7)I
88200 7 FORMAT(' COMMA MISSING IN POSITION ',I2,' OR INCORRECT NAME')
88300 GO TO 8
88400 6 IF(J.GT.5) GO TO 10
88500 IF(J.GT.1) GO TO 9
88600 IF((A(I).LE.'9').AND.(A(I).GE.'0')) NUM=1
88700 9 B(J)=A(I)
88800 J=J+1
88900 10 I=I+1
89000 IF(I.LT.80) GO TO 5
89100 11 IF(NUM.NE.1) GO TO 14
89200 12 IF(B(5).NE.' ') GO TO 14
89300 DO 13 K=4,1,-1
89400 13 B(K+1)=B(K)
89500 B(1)='0'
89600 GO TO 12
89700 14 IVAL=' '
89800 ENCODE(5,15,IVAL) B
89900 15 FORMAT(5A1)
90000 IF(NUM.EQ.1) GO TO 21
90100 IF(IVAL.EQ.' ') RETURN
90200 IF(IVAL.EQ.'*') GO TO 20
90300 IF(IVAL.EQ.'?') GO TO 20
90400 IF(IVAL.EQ.'ALL') GO TO 20
90500 IF(IVAL.EQ.'HELP') GO TO 24
90600 IF((IVAL.EQ.'EMPTY').AND.(ISMPTY.EQ.1)) GO TO 31
90700 DO 16 K=1,NV
90800 IF(NAMES(K).EQ.IVAL) GOTO 18
90900 16 CONTINUE
91000 WRITE(IDLG,17)IVAL
91100 17 FORMAT(' THE NAME "',A5,'" DOES NOT EXIST')
91200 GO TO 8
91300 18 IF(THRU.EQ.1) GO TO 28
91400 N=N+1
91500 IF(N.LE.MAX) GO TO 19
91600 27 WRITE(IDLG,26) MAX
91700 26 FORMAT(' MAXIMUM OF ',I2,' VARIABLES FOR THIS ANALYSIS')
91800 GO TO 8
91900 19 IVECT(N)=K
92000 30 IF(A(I).EQ.'-') THRU=1
92100 IF((IXTAB.NE.1).OR.(THRU.NE.1)) GO TO 3
92200 WRITE(IDLG,32)
92300 32 FORMAT(' THE - WILL NOT WORK HERE')
92400 GO TO 8
92500 20 K=-1
92600 GO TO 18
92700 C NUMERIC VALUES CHECK TO SEE THAT THEY ARE ALL RIGHT
92800 21 DECODE(5,22,IVAL)K
92900 22 FORMAT(I5)
93000 IF((K.GT.0).AND.(K.LE.NV)) GO TO 18
93100 WRITE(IDLG,23) K
93200 23 FORMAT(' VARIABLE ',I5,' DOES NOT EXIST')
93300 8 IERR=1
93400 25 N=0
93500 RETURN
93600 24 IHELP=1
93700 GO TO 25
93800 31 IVECT(1)=0
93900 RETURN
94000 C
94100 C PART FOR THRU FUNCTION "-"
94200 C
94300 28 THRU=0
94400 INC=1
94500 IF(IVECT(N).EQ.K) GO TO 30
94600 IF(IVECT(N).GT.K) INC=-1
94700 M=N+(K-IVECT(N))*INC
94800 IF(M.GT.MAX) GO TO 27
94900 DO 29 J=N+1,M
95000 29 IVECT(J)=IVECT(J-1)+INC
95100 N=M
95200 GO TO 30
95300 END