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