OMNITAB,T320,CM240000. RUN(S) LGO(INPUT,TMP) REWIND(TMP) EDITSYM(I=TMP,NPL=OPL) EDITSYM(OPL=OPL,NPL=OMNOPL) EDITSYM(OPL=OMNOPL,C) REWIND(COMPILE) REWIND(LGO) RUN(S,,,COMPILE,,LGO,40000) MODE 1. LGO. EXIT. ~eor PROGRAM FIX(INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT) DIMENSION KARD(72) 10 IF (EOF,5) 999,15 15 READ (5,100) KARD,IFIL,ISEQ 20 LFIL = IFIL WRITE (6,110) IFIL 30 WRITE (6,130) KARD,IFIL,ISEQ IF (EOF,5) 999,35 35 READ (5,100) KARD,IFIL,ISEQ IF (IFIL.EQ.LFIL) GO TO 30 40 WRITE (6,120) GO TO 20 100 FORMAT (72A1,A3,A4) 110 FORMAT (6H*DECK,,A3) 120 FORMAT (4H*END) 130 FORMAT (72A1,A3,A4) 999 WRITE (6,120) STOP END ~eor C THIS IS THE MAIN PROGRAM OF OMNITAB OMS 10 C VERSION 5.00 OMNSYM 5/15/70 OMS 20 C OMS 30 CALL OMNIT OMS 40 STOP OMS 50 END OMS 60 SUBROUTINE AARGS AAR 10 C VERSION 5.00 AARGS 5/15/70 AAR 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND AAR 30 COMMON /CONSTS/ PI,E,HALFPI,DEG,RAD,XALOG AAR 40 C AAR 50 C THIS SUBROUTINE ASSEMBLES A FLOATING POINT NUMBER FROM A STRING OFAAR 60 C DIGITS ETC. M INITIALLY POINTS AT THE FIRST NUMBER. IT IS LEFT AAR 70 C POINTING AT THE FIRST CHARACTER AFTER THE NUMBER. AAR 80 C AAR 90 C VALUE RETURNED IN ARG AAR 100 C AAR 110 C KARG = 1 = FLOATING POINT, = 0 = INTEGER, -1 = ERROR. AAR 120 C AAR 130 ARG=KARD(M) AAR 140 SIGN=1. AAR 150 JEXP=0 AAR 160 IXS=1 AAR 170 IEXP=0 AAR 180 KARG=0 AAR 190 C AAR 200 C LOOK BACK FOR MINUS SIGN AND/OR DECIMAL POINT AAR 210 C AAR 220 K=KARD(M-1) AAR 230 IF (K.NE.37) GO TO 10 AAR 240 KARG=1 AAR 250 IEXP=-1 AAR 260 K=KARD(M-2) AAR 270 10 IF (K.EQ.38) SIGN=-1. AAR 280 20 M=M+1 AAR 290 K=KARD(M) AAR 300 IF (K.GE.10) GO TO 30 AAR 310 IEXP=IEXP-KARG AAR 320 ARG=10.*ARG+FLOAT(K) AAR 330 GO TO 20 AAR 340 30 IF (K.NE.37) GO TO 50 AAR 350 C AAR 360 C DECIMAL POINT FOUND AAR 370 C AAR 380 IF (KARG.EQ.0) GO TO 40 AAR 390 CALL ERROR (3) AAR 400 KARG=-1 AAR 410 RETURN AAR 420 40 KARG=1 AAR 430 GO TO 20 AAR 440 C AAR 450 C CHECK FOR EXPONENT E X, E+X, E-X, +X, -X AAR 460 C AAR 470 50 IF (K.NE.14) GO TO 65 AAR 480 M=M+1 AAR 490 K=KARD(M) AAR 500 IF (K.NE.44) IF (K-10) 70,65,65 AAR 505 60 M=M+1 AAR 510 K=KARD(M) AAR 520 IF (K-10) 70,90,90 AAR 530 65 IF (K.NE.38) IF (K-39) 90,60,90 AAR 540 IXS=-1 AAR 550 GO TO 60 AAR 560 70 KARG=KARG+1 AAR 570 80 JEXP=10*JEXP+K AAR 580 M=M+1 AAR 590 K=KARD(M) AAR 600 IF (K.LT.10) GO TO 80 AAR 610 C AAR 620 C DONE WITH ARGUMENT AAR 630 C AAR 640 90 IF (KARG.NE.0) GO TO 110 AAR 650 100 ARG=SIGN*ARG AAR 660 RETURN AAR 670 110 KARG=1 AAR 680 IEXP=IXS*JEXP+IEXP AAR 690 C AAR 700 C THE FOLLOWING CODING YIELDS MORE ACCURATE RESULTS THEN THE AAR 710 C OBVIOUS ARG = ARG * 10. * IEXP AAR 720 JEXP=IABS(IEXP) AAR 730 IF (JEXP.GT.IFIX(XALOG)) GO TO 140 AAR 740 IF (IEXP) 120,100,130 AAR 750 120 ARG=ARG/FEXP2(10.0,FLOAT(JEXP)) AAR 760 GO TO 100 AAR 770 130 ARG=ARG*FEXP2(10.0,FLOAT(JEXP)) AAR 780 GO TO 100 AAR 790 140 CALL ERROR (102) AAR 800 ARG=0. AAR 810 GO TO 100 AAR 820 END AAR 830 SUBROUTINE ABRIDG ABR 10 C VERSION 5.00 ABRIDG 5/15/70 ABR 20 C ABR 30 C THE COMMAND ABRIDGE MAY BE USE IN THE FOLLOWING WAYS ABR 40 C ABRIDGE ROW,, OF COL ++,++, (USE RPRINT UNLESS IOSWT HAS BEEN ABR 50 C SET BY FIXED OR FLOATING) ABR 60 C ABRIDGE // ROW,, OF COL ++,++ (USE SEPCIFIED FORMAT) ABR 70 C ABRIDGE WITH FLOATING PT. ARGS USES RPRINT ABR 80 C IOSWT IS NOT RESET ABR 90 C ABR 100 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ABR 110 COMMON /BLOCRC/ NRC,RC(12600) ABR 120 DIMENSION ARGS(100) ABR 130 EQUIVALENCE (ARGS(1),RC(12501)) ABR 140 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) ABR 150 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH ABR 160 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NABR 170 1ARGS,VMXYZ(8),NERROR ABR 180 COMMON /KFMT/ KFMT(100) ABR 190 IF (NARGS.NE.0) GO TO 15 ABR 200 10 CALL ERROR (205) ABR 210 RETURN ABR 220 15 IF (L2.EQ.1) IF (IOSWT) 70,70,80 ABR 225 CALL PREPAK (4,IND,L2,IND,KFMT) ABR 230 IF (IND.NE.0) GO TO 90 ABR 240 IP=1 ABR 250 IF (NARGS.LE.1) GO TO 10 ABR 260 20 LL=IARGS(1) ABR 270 IARGS(1)=1 ABR 280 IF (LL.LE.0.OR.LL.GT.NROW) GO TO 10 ABR 290 CALL CHKCOL (I) ABR 300 IF (I.NE.0) GO TO 10 ABR 310 IF (NERROR.NE.0) RETURN ABR 320 DO 30 I=2,NARGS ABR 330 J=IARGS(I)+LL ABR 340 30 ARGS(I)=RC(J-1) ABR 350 IF (NPAGE.EQ.0) CALL PAGE(0) ABR 355 GO TO (40,50), IP ABR 360 40 WRITE (IPRINT,KFMT) (ARGS(I),I=2,NARGS) ABR 370 GO TO 60 ABR 380 50 WRITE (IPRINT,IFMTX) (ARGS(I),I=2,NARGS) ABR 390 60 RETURN ABR 400 70 IF(NPAGE.EQ.0) CALL PAGE(0) ABR 410 CALL RPRINT ABR 420 RETURN ABR 430 C USE SPECIFIED FIXED OR FLOATING FORMAT ABR 470 80 IP=2 ABR 480 GO TO 20 ABR 490 90 CALL ERROR (222) ABR 500 GO TO 80 ABR 510 END ABR 520 SUBROUTINE ACCDIG (AX,X,AD,N) ACC 10 C VERSION 5.00 ACCDIG 5/15/70 ACC 20 C RETURNS NUMBER OF ACCURATE DIGITS, AD, IN AX AN APPROXIMATION TO XACC 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/29/69 ACC 40 DIMENSION AX(1),X(1),AD(1) ACC 50 DATA ADMAX /8.0/ ACC 60 DO 100 I=1,N ACC 70 DIFF = AX(I)-X(I) ACC 80 IF (DIFF) 20,10,20 ACC 90 10 AD(I) = ADMAX ACC 100 GO TO 100 ACC 110 20 AD(I) = -FLOG10(ABS(DIFF)) + FLOG10(ABS(X(I)) ) ACC 120 AD(I) = AMIN1(ADMAX,AD(I) ) ACC 130 AD(I) = AMAX1(-ADMAX,AD(I)) ACC 140 100 CONTINUE ACC 150 RETURN ACC 160 END ACC 170 SUBROUTINE ADRESS (I,J) ADR 10 C VERSION 5.00 ADRESS 5/15/80 ADR 20 COMMON /BLOCRC/ NRC,RC(12600) ADR 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NADR 40 1ARGS,VMXYZ(8),NERROR ADR 50 DIMENSION ARGS(100) ADR 60 EQUIVALENCE (ARGS(1),RC(12501)) ADR 70 C ADR 80 C CALCULATE ADDRESS OF ARGUMENT( I ). IF ARGUMENT( I ) IS A ADR 90 C FLOATING POINT NUMBER, J = (I+ NRC). IF ILLEGAL COLUMN NUMBERADR 100 C J = 0. IF OK, J = ADDRESS ADR 110 C ADR 120 IF (KIND(I).EQ.0) GO TO 10 ADR 130 J=-(I+NRC) ADR 150 GO TO 30 ADR 160 10 IF (IARGS(I).GE.1.AND.IARGS(I).LE.NCOL) GO TO 20 ADR 170 J=0 ADR 180 GO TO 30 ADR 190 20 J=NROW*(IARGS(I)-1)+1 ADR 200 30 RETURN ADR 210 END ADR 220 SUBROUTINE AERR (I) AER 10 C VERSION 5.00 AERR 5/15/70 AER 20 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST AER 30 COMMON /BLOCKX/ INDEX(6,8),LEVEL AER 40 COMMON /SPRV/ NERCON,NERR,ISWERR AER 50 C AER 60 C WHEN ARITHMETIC TROUBLES DEVELOP, THIS ROUTINE TALLIES THEM AND THAER 70 C PRINTS THE RESULTS WHEN THE COMMAND IS DONE. AER 80 C AER 90 C ARITHMETIC MESSAGES MUST HAVE THE FOLLOWING TYPE OF FORMAT: AER 100 C 1) THE FIRST TWO CHARACTERS MUST BE ** AER 110 C 2) MESSAGE PLUS OTHER INFO MUST NOT BE LONGER THAN 84 CHARACTERSAER 120 C 3) IF MESSAGE IS LESS THEN 84 CHAR , ADD NX AT END OF FORMAT AER 130 C AER 140 C IF MORE THEN 10 ARITHMETIC ERROR MESSAGES ARE NEEDED THEN AER 150 C DIMENSION OF MESS(10) MUST BE CHANGED AND KMESS MUST BE SET - AER 160 C TO DIMENSION SIZE OF MESS. AER 170 C ALSO COMPUTED GO TO MUST BE CHANGED. SET NOTEAER 180 DIMENSION MESS(10) AER 190 DATA KMESS/10/ AER 200 IF (I) 160,30,10 AER 210 C AER 220 C DATA COMING IN AER 230 C AER 240 10 J=MIN0(I,KMESS) AER 250 MESS(J)=MESS(J)+1 AER 260 20 RETURN AER 270 C AER 280 C DUMP RESULTS, END OF COMMAND AER 290 C AER 300 30 IF(LLIST.LT.2.OR.LLIST.EQ.4) GO TO 160 AER 310 DO 150 J=1,KMESS AER 320 IF (MESS(J).EQ.0) GO TO 150 AER 330 WRITE (ISCRAT,250) AER 340 WRITE (ISCRAT,180) MESS(J) AER 350 C AER 360 C THIS COMPUTED GO TO MUST BE CHANGED IF MORE THAT 10 ARITHMETIC AER 370 C ERRORS ARE ADDED AER 380 C AER 390 GO TO (40,50,60,70,80,90,100,110,120,130), J AER 400 40 WRITE (ISCRAT,101) AER 410 GO TO 140 AER 420 50 WRITE (ISCRAT,102) AER 430 GO TO 140 AER 440 60 WRITE (ISCRAT,103) AER 450 GO TO 140 AER 460 70 WRITE (ISCRAT,104) MESS(J) AER 470 GO TO 140 AER 480 80 WRITE (ISCRAT,105) MESS(J) AER 490 GO TO 140 AER 500 90 WRITE (ISCRAT,106) MESS(J) AER 505 GO TO 140 AER 510 100 WRITE (ISCRAT,107) MESS(J) AER 515 GO TO 140 AER 517 110 WRITE (ISCRAT,108) MESS(J) AER 520 GO TO 140 AER 525 120 WRITE (ISCRAT,109) MESS(J) AER 530 GO TO 140 AER 535 130 WRITE (ISCRAT,240) J AER 540 140 IF (LEVEL.NE.0) CALL RNDOWN AER 550 WRITE (ISCRAT,250) AER 560 MESS(J)=0 AER 570 150 CONTINUE AER 580 IF (LEVEL.NE.0) GO TO 20 AER 590 ISWERR=0 AER 600 NERR=0 AER 610 GO TO 20 AER 620 C AER 630 C INITIALIZATION SECTION AER 640 C AER 650 160 DO 170 J=1,KMESS AER 660 170 MESS(J)=0 AER 670 ISWERR=0 AER 680 NERR=0 AER 690 GO TO 20 AER 700 C AER 710 180 FORMAT (51H** ARITHMETIC FAULT IN ABOVE COMMAND, ZERO RETURNED,I4,AER 720 16H TIMES,23X) AER 730 101 FORMAT (42H** NEGATIVE ARGUMENT TO SQRT, LOG OR RAISE,42X) AER 740 102 FORMAT (43H** EVALUATION OF EXPONENT PRODUCES OVERFLOW,41X) AER 750 103 FORMAT (45H** ARGUMENT OUT OF BOUNDS TO INVERSE FUNCTION,39X) AER 760 104 FORMAT (51H**ARGUMENT TOO LARGE FOR SIN OR COS, ZERO. RETURNED,I4,AER 770 16H TIMES,23X) AER 780 105 FORMAT (61H**BESSEL ARGUMENTS SCALED TO AVOID OVER/UNDER FLOW.RE AER 790 1TURNED,I4,6H TIMES,13X) AER 800 240 FORMAT (16H** ERROR MESSAGE,I2,66X) AER 810 250 FORMAT (84X) AER 820 106 FORMAT (33H** DIVISION BY ZERO, RESULT SET=0,I4,6H TIMES,41X) AER 830 107 FORMAT(44H** TRIG FUNCTIONS NOT DEFINED, RESULTS SET=0,I4, 6H TIMEAER 840 1S, 30X) AER 850 108 FORMAT(66H** ONE OF THE VALUES COMPARED IS ZERO, ABSOLUTE TOLERANCAER 860 1E WAS USED,I4,6H TIMES,8X) AER 870 109 FORMAT(71H* X FOR ELLIPTICAL INTEGRALS IS = 1.0 OR GREATER. RESULTAER 880 1 IS SET TO 0.0,I4,6H TIMES,3X) AER 890 END AER 900 SUBROUTINE ALLSUB ALL 10 C VERSION 5.00 ALLSUB 5/15/70 ALL 20 COMMON /BLOCRC/ NRC,RC(12600) ALL 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NALL 40 1ARGS,VWXYZ(8),NERROR ALL 50 DIMENSION ARGS(100) ALL 60 EQUIVALENCE (ARGS(1),RC(12501)) ALL 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ALL 80 COMMON /SCRAT/ NS,NS2,A(13500) ALL 90 DIMENSION SCRA(1) ALL 100 EQUIVALENCE (SCRA,A) ALL 110 EQUIVALENCE (L11,LL1), (L22,LL2) ALL 120 C PROGRAM BY PHILOP J. WALSH (NBS 453.40) MAY, 1967 ALL 130 C ALL 140 C ALL 150 C COMMAND IS OF THE FORM XXXX OF ORDER ++ OF COL ++, STORE IN ++ ALL 160 C XXXX MAY BE (A) NLSUB FOR NORMALIZED LAGUERRE POLYNOMIALS ALL 170 C (B) LSUB FOR LAGUERRE POLYNOMIALS ALL 180 C (C) HSUB FOR HERMITE POLYNOMIALS ALL 190 C (D) USUB FOR CHEBYSHEV POLYNOMIALS ALL 200 C (E) PSUB FOR LEGENDRE POLYNOMIALS ALL 210 C (F) TSUB FOR CHEBYSHEV POLYNOMIALS ALL 220 C SEE RECURSIVE FORMULAE FOR THESE POLYNOMIALS FURTHER IN CODE ALL 230 C EACH OF THE COMMANDS REQUIRE THREE ARGUMENTS ALL 240 IF (NARGS.EQ.3) GO TO 10 ALL 250 CALL ERROR (10) ALL 260 GO TO 210 ALL 270 10 IF (KIND(1)+KIND(3).EQ.0) GO TO 30 ALL 280 20 CALL ERROR (3) ALL 290 GO TO 210 ALL 300 C CHECK THAT X IS WITHIN WORKSHEET AND GET ADDRESS OF ARGUMENT COLUMALL 310 30 CALL ADRESS (2,L11) ALL 320 IF (L11) 20,40,50 ALL 330 40 CALL ERROR (11) ALL 340 GO TO 210 ALL 350 50 IARGS(4)=IARGS(1)+IARGS(3)-1 ALL 360 KIND(4)=0 ALL 370 CALL ADRESS (4,L22) ALL 380 IF (L22.LE.0) GO TO 40 ALL 390 CALL ADRESS (3,L22) ALL 400 IF (NRMAX.NE.0) GO TO 60 ALL 410 CALL ERROR (9) ALL 420 GO TO 210 ALL 430 60 IF (NERROR.NE.0) GO TO 210 ALL 440 IJK=LL1 ALL 450 IJ=LL2 ALL 460 DO 110 I=1,NRMAX ALL 470 SCRA(1)=RC(IJK) ALL 480 GO TO (70,70,80,80,90,90), L2 ALL 490 70 RC(IJ)=1.-SCRA(1) ALL 500 GO TO 100 ALL 510 80 RC(IJ)=2.*SCRA(1) ALL 520 GO TO 100 ALL 530 90 RC(IJ)=SCRA(1) ALL 540 100 IJK=IJK+1 ALL 550 110 IJ=IJ+1 ALL 560 IF (IARGS(1).EQ.1) GO TO 210 ALL 570 N=IARGS(1)-1 ALL 580 DO 200 J=1,NRMAX ALL 590 IJK=LL1+J ALL 600 IJ=LL2+J ALL 610 SCRA(1)=1.0 ALL 620 SCRA(2)=RC(IJK-1) ALL 630 SCRA(3)=RC(IJ-1) ALL 640 SCRA(4)=1.0 ALL 650 SCRA(5)=2.0 ALL 660 DO 190 I=1,N ALL 670 IARGS(4)=IARGS(3)+I ALL 680 CALL ADRESS (4,LL22) ALL 690 GO TO (120,130,140,150,160,170), L2 ALL 700 C L2 = 1 NLSUB NORMALIZED LAGUERRE POLYNOMIALS ALL 710 C RECURSION FORMULA L(N+1) = (1.+2.*N-X)*L(N)-N**2 *L(N-1) ALL 720 C L(0) = 1. ALL 730 C L(1) = -X+1. ALL 740 C L(2) = X**2 - 4.0*X +2. ALL 750 C L(3) =-X**3 + 9.0*X**2-18.0*X+6. ALL 760 C ALL 770 C L(N)= EXP(X)*(DN/DXN(X**N*EXP(-X))) ALL 780 C ALL 790 120 SCRA(4)=I ALL 800 SCRA(6)=1.0+2.0*SCRA(4) ALL 810 SCRA(7)=SCRA(4)*SCRA(4) ALL 820 SCRA(8)=(SCRA(6)-SCRA(2))*SCRA(3)-SCRA(7)*SCRA(1) ALL 830 GO TO 180 ALL 840 C L2 = 2 LSUB LAGUERRE POLYNOMIALS ALL 850 C RECURSION FORMULA L(N+1)=(((2.*N+1)-X)*L(N)-N*L(N-1))/ ALL 860 C (N+1) ALL 870 C ALL 880 C L(0) = 1. ALL 890 C L(1) = -X+1. ALL 900 C L(2) = .5 (XX*2 - 4.*X +2) ALL 910 C L(3) = (-X**3 + 9.*X**2 - 18.* X + 6.)/6. ALL 920 C ALL 930 C * SEE ABRAMOWITZ. M. AND STEGUN, I.A., HANDBOOK OF MATHEMATICAL ALL 940 C FUNCTIONS, NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS ALL 950 C SERIES 55, SUPERINTENDENT OF DOCUMENTS, U.S. GOVERNMENT ALL 960 C PRINTING OFFICE, WASHINGTON, D.C. 20402 ALL 970 C ALL 980 C * SEE HILSENRATH,ZIEGLER,MESSINA,WALSH,HERBOLD,, OMNITAB, NBS ALL 990 C HANDBOOK 101 (MARCH 4, 1966) - FOR FORMULAE USED ALL1000 130 SCRA(4)=I ALL1010 SCRA(6)=SCRA(4)+1.0 ALL1020 SCRA(7)=SCRA(4)+SCRA(6) ALL1030 SCRA(8)=((SCRA(7)-SCRA(2))*SCRA(3)-SCRA(4)*SCRA(1))/SCRA(6) ALL1040 GO TO 180 ALL1050 C L2 = 3 HSUB HERMITE POLYNOMIALS ALL1060 C RECURSION FORMULA H(N+1) = 2.0*X*H(N)-2.0*N*H(N-1) ALL1070 C ALL1080 C H(0) = 1. ALL1090 C H(1) = 2.0*X ALL1100 C H(2) = 4.0*X**2-2. ALL1110 C H(3) = 8.0*X**3-12.*X ALL1120 140 SCRA(8)=2.0*(SCRA(2)*SCRA(3)-SCRA(4)*SCRA(1)) ALL1130 SCRA(4)=SCRA(4)+1.0 ALL1140 GO TO 180 ALL1150 C L2 = 4 USUB CHEBYSHEV POLYNOMIALS ALL1160 C ALL1170 C RECURSION FORMULA U(N) = 2.0*X*U(N-1)-U(N-2) ALL1180 C ALL1190 C U(0) = 1. ALL1200 C U(1) = 2.0*X ALL1210 C U(2) = 4.0*X**2-1.0 ALL1220 C U(3) = 8.0*X**3-4.0*X ALL1230 C ALL1240 150 SCRA(8)=2.0*SCRA(2)*SCRA(3)-SCRA(1) ALL1250 GO TO 180 ALL1260 C L2 = 5 PSUB LEGENDRE POLYNOMIALS ALL1270 C ALL1280 C RECUSION FORMULA P(N+1) =X*P(N)+(N/N+1)*(X*P(N)-P(N-1)) ALL1290 C ALL1300 C P(0) = 1. ALL1310 C P(1) = X. ALL1320 C P(2) = (3./2.)*X**2-(1./2.) ALL1330 C P(3) = 2.5*X**3-1.5*X ALL1340 C ALL1350 160 SCRA(6)=SCRA(4)/SCRA(5) ALL1360 SCRA(8)=(1.0+SCRA(6))*SCRA(2)*SCRA(3)-SCRA(6)*SCRA(1) ALL1370 SCRA(4)=SCRA(5) ALL1380 SCRA(5)=SCRA(5)+1.0 ALL1390 GO TO 180 ALL1400 C L2 = 6 TSUB CHEBYSHEV POLYNOMIALS ALL1410 C ALL1420 C RECURSION FORMULA ALL1430 C T(0) = 1. ALL1440 C T(1) = X ALL1450 C T(2) = 2.*X**2-1. ALL1460 C T(3) = 4.*X**3-3.*X ALL1470 170 SCRA(8)=2.0*SCRA(2)*SCRA(3)-SCRA(1) ALL1480 180 CONTINUE ALL1490 LJMN=LL22+J ALL1500 RC(LJMN-1)=SCRA(8) ALL1510 SCRA(1)=SCRA(3) ALL1520 SCRA(3)=SCRA(8) ALL1530 190 CONTINUE ALL1540 200 CONTINUE ALL1550 210 RETURN ALL1560 END ALL1570 SUBROUTINE APRINT APR 10 C VERSION 5.00 APRINT 5/15/70 APR 20 COMMON /BLOCRC/ NRC,RC(12600) APR 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NAPR 40 1ARGS,VWXYZ(8),NERROR APR 50 DIMENSION ARGS(100) APR 60 EQUIVALENCE (ARGS(1),RC(12501)) APR 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG APR 80 COMMON /ABCDEF/ L(48) APR 90 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH APR 100 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) APR 110 COMMON /SCRAT/ NS,NS2,A(13500) APR 120 COMMON /KFMT/ KFMT(100) APR 130 DIMENSION IFRV(3) APR 140 DATA IFRV(1),IFRV(2),IFRV(3)/3H1X,,3HI5,,3H2X,/ APR 150 C L1 = 4 APRINT APR 160 C L1 = 7 MPRINT APR 170 C MPRINT PRINTS ROW/COL TITLE, APRINT DOES NOT. APR 180 C ALL READABLE IF POSIBLE. OTHERWISE ALL FLOATING. APR 190 C WRITTTEN BY DAVID HOGBEN, SEL, NBS. 8/18/69. APR 200 C ***** APR 210 C 6 FORMAT STATEMENTS FOLLOW WHICH MAY NEED MODIFY IF CHANGES MADE APR 220 C ***** APR 230 IF (NARGS.EQ.4) GO TO 30 APR 240 10 CALL ERROR (205) APR 250 20 RETURN APR 260 30 J=1 APR 270 I=4 APR 280 CALL CKIND (I) APR 290 IF (I.NE.0) GO TO 10 APR 300 K=IARGS(1) APR 310 CALL MTXCHK (J) APR 320 IF (J.NE.0) GO TO 10 APR 330 IF (NERROR.NE.0) RETURN APR 340 C CHECK TO SEE IF NPAGE=0. IF YES, BEGIN A NEW PAGE. CALL PAGE(0) APR 350 IF (NPAGE.EQ.0) CALL PAGE(0) APR 360 C IF L2=1 IOSWT=0 USE READABLE FORMAT APR 370 IF (L2.EQ.1.AND.IOSWT.EQ.0) GO TO 190 APR 380 C IF L2=1 IOSWT=1 USE FIXED OR FLOATING APR 390 IF (L2.EQ.1.AND.IOSWT.EQ.1) GO TO 60 APR 400 C IF (L2.NE.1) USE SPECIFIED FORMAT APR 410 C FORMAT SHOULD SPECIFY FORMAT FOR ONLY ONE ROW APR 420 CALL PREPAK (4,IND,L2,IND,KFMT) APR 430 IF (IND.NE.0) GO TO 50 APR 440 IA=IARGS(3) APR 450 J1=IARGS(1) APR 460 J2=J1+(IARGS(4)-1)*NROW APR 470 DO 40 I=1,IA APR 480 WRITE (IPRINT,KFMT) (RC(J),J=J1,J2,NROW) APR 490 J1=J1+1 APR 500 J2=J2+1 APR 510 40 CONTINUE APR 520 RETURN APR 530 C NO FORMAT IS FOUND SO USE READABLE FORMAT APR 540 50 CALL ERROR (222) APR 550 GO TO 190 APR 560 C FIXED OR FLOATING FORMAT USED APR 570 60 DO 70 I=1,100 APR 580 70 KFMT(I)=L(45) APR 590 IF (L1.EQ.7) GO TO 90 APR 600 DO 80 I=1,6 APR 610 80 KFMT(I)=IFMTX(I) APR 620 GO TO 110 APR 630 90 KFMT(1)=IFMTX(1) APR 640 KFMT(2)=IFRV(1) APR 650 KFMT(3)=IFRV(2) APR 660 KFMT(4)=IFRV(3) APR 670 DO 100 I=2,6 APR 680 100 KFMT(I+3)=IFMTX(I) APR 690 110 KA=IARGS(1) APR 700 LL=IARGS(3) APR 710 IBB=IARGS(4) APR 720 IBBP=8 APR 730 IF (L1.EQ.7) IBBP=7 APR 740 I1A=IARGS(2) APR 750 120 IF (IBB.GT.IBBP) GO TO 130 APR 760 IB=IBB APR 770 IBB=0 APR 780 GO TO 140 APR 790 130 IBB=IBB-IBBP APR 800 IB=IBBP APR 810 140 KB=(IB-1)*NROW+KA APR 820 KBP=KB+NROW APR 830 I2A=I1A+IB-1 APR 840 IF (L1.EQ.4) GO TO 150 APR 850 WRITE (IPRINT,280) L(28),L(25),L(33),L(37),L(13),L(25),L(22),(JJ,JAPR 860 1J=I1A,I2A) APR 870 MRV=K APR 880 150 DO 180 M=1,LL APR 890 IF (L1.EQ.4) GO TO 160 APR 900 WRITE (IPRINT,KFMT) MRV,(RC(K),K=KA,KB,NROW) APR 910 MRV=MRV+1 APR 920 GO TO 170 APR 930 160 WRITE (IPRINT,KFMT) (RC(K),K=KA,KB,NROW) APR 940 170 KA=KA+1 APR 950 KB=KB+1 APR 960 180 CONTINUE APR 970 IF (IBB.EQ.0) RETURN APR 980 WRITE (IPRINT,330) APR 990 C PRINT NEXT SET OF COLUMNS APR1000 KA=KBP APR1010 I1A=I2A+1 APR1020 GO TO 120 APR1030 C THE NEXT CARD MUST BE CHANGED IF WIDTH OF COLUMN CHANGED APR1040 C THE CARD AFTER IT MUST BE CHANGED IF NUMBER OF COLUMNS CHANGES APR1050 C 2 CALLS TO RFORMT LATER NEED TO BE CHANGED IF NO. OF SD NOT 8. APR1060 C NWMX IS DETERMINED BY 120/8-2 WHERE 120 IS THE NUMBER OF APR1070 C CHARACTERS PER PRINTED LINE APR1080 190 NWMX=13 APR1100 MCOL=8-L1/7 APR1110 NSTART=IARGS(1) APR1120 KSTART=K-1 APR1130 KR=IARGS(3) APR1140 KC=IARGS(4) APR1150 K1=1 APR1160 K2=NSTART APR1170 DO 210 I=1,KC APR1180 DO 200 J=1,KR APR1190 A(K1)=RC(K2) APR1200 K1=K1+1 APR1210 200 K2=K2+1 APR1220 210 K2=K2+NROW-KR APR1230 KSIZE=KR*KC APR1240 CALL RFORMT (A(1),KSIZE,8,NWIDTH,NDECS,NWMX+1,A(1),A(1),0,0) APR1250 C MINUMUM OF TWO BLANK SPACES ON LEFT APR1260 NBLANK=NWMX+2-NWIDTH APR1270 I1=1 APR1280 I1A=IARGS(2) APR1290 K1=NSTART-1 APR1300 C LOOP ON BLOCKS APR1310 220 I2=I1+MCOL-1 APR1320 I2=MIN0(I2,KC) APR1330 I2A=IARGS(2)+I2-1 APR1340 K2=K1+(I2-I1)*NROW APR1350 K4=K2 APR1360 IF (L1.EQ.4) GO TO 230 APR1370 WRITE (IPRINT,280) L(28),L(25),L(33),L(37),L(13),L(25),L(22),(JJ,JAPR1380 1J=I1A,I2A) APR1390 C LOOP ON ROWS APR1400 230 DO 270 JJ=1,KR APR1410 K1=K1+1 APR1420 K2=K2+1 APR1430 JJJ=KSTART+JJ APR1440 IF (NWIDTH.LE.NWMX.OR.L1.NE.7) GO TO 240 APR1450 C WRITE FLOATING IF MPRINT (L1=7) AND NWIDTH GT NWMAX APR1460 WRITE (IPRINT,300) JJJ,(RC(K3),K3=K1,K2,NROW) APR1470 GO TO 270 APR1480 240 LL=1 APR1490 K=K1 APR1500 C LOOP ON COLUMNS APR1510 DO 250 II=I1,I2 APR1520 CALL RFORMT (A,1,8,NWIDTH,NDECS,0,RC(K),A(LL),NBLANK,0) APR1530 K=K+NROW APR1540 250 LL=LL+NWMX+2 APR1550 NL=LL-1 APR1560 IF (L1.EQ.7) GO TO 260 APR1570 WRITE (IPRINT,310) (A(LL),LL=2,NL) APR1580 GO TO 270 APR1590 260 WRITE (IPRINT,290) JJJ,(A(LL),LL=2,NL) APR1600 270 CONTINUE APR1610 K1=K4+NROW APR1620 I1=I1+MCOL APR1630 I1A=I1A+MCOL APR1640 IF (I2.GE.KC) GO TO 20 APR1650 C LOOP ON BLOCKS APR1660 C PUT IN BLANK LINE BETWEEN BLOCKS APR1670 WRITE (IPRINT,320) APR1680 GO TO 220 APR1690 C APR1700 280 FORMAT (1X,7A1,7(6X,I5,4X)) APR1710 290 FORMAT (1X,I5,2X,112A1) APR1720 300 FORMAT (1X,I5,2X,1P7E15.6) APR1730 310 FORMAT (1X,119A1) APR1740 320 FORMAT (1H ) APR1750 330 FORMAT (1X) APR1760 END APR1770 SUBROUTINE ARITH ARI 10 C VERSION 5.00 ARITH 5/15/70 ARI 20 COMMON /BLOCRC/ NRC,RC(12600) ARI 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NARI 40 1ARGS,VWXYZ(8),NERROR ARI 50 DIMENSION ARGS(100) ARI 60 EQUIVALENCE (ARGS(1),RC(12501)) ARI 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ARI 80 DIMENSION II(5),KK(5) ARI 90 EQUIVALENCE (II(1),I1),(II(2),I2),(II(3),I3), ARI 100 1 (II(4),I4),(II(5),I5) ARI 105 C ARI 110 C THIS SUBROUTINE PERFORMS ADD,SUB,MULT,DIV AND RAISE FOR ARI 120 C THREE, FOUR AND FIVE ARGUMENTS ARI 130 C L2=1 ADD ARI 140 C L2=2 SUBTRACT ARI 150 C L2=3 MULTIPLY ARI 160 C L2=4 DIVIDE ARI 170 C L2=5 RAISE ARI 180 C L2=6 ACCURATE DIGITS ARI 190 C ARI 200 IF(NARGS.LT.3.OR.NARGS.GT.5) CALL ERROR(10) ARI 210 IF (NARGS.EQ.4)CALL ERROR (29) ARI 215 IF(KIND(NARGS).NE.0) CALL ERROR (20) ARI 220 IF (L2.NE.6) GO TO 5 ARI 222 IF (NARGS.EQ.3) GO TO 5 ARI 224 CALL ERROR (212) ARI 226 NARGS=3 ARI 228 5 DO 30 I=1,NARGS ARI 230 KK(I)=1 ARI 240 CALL ADRESS (I,II(I)) ARI 250 IF(II(I)) 20,10,30 ARI 260 10 CALL ERROR(11) ARI 270 RETURN ARI 280 20 KK(I)=0 ARI 290 II(I)=-II(I) ARI 300 30 CONTINUE ARI 310 IF(NRMAX.LE.0) CALL ERROR(9) ARI 320 IF(NERROR.NE.0) RETURN ARI 330 JJ=II(NARGS)+NRMAX-1 ARI 380 IF (NARGS.NE.3) GO TO 120 ARI 390 DO 110 I=I3,JJ ARI 400 GO TO (50,60,70,80,90,95),L2 ARI 410 50 RC(I)=RC(I1)+RC(I2) ARI 420 GO TO 100 ARI 430 60 RC(I)=RC(I2)-RC(I1) ARI 440 GO TO 100 ARI 450 70 RC(I)=RC(I1)*RC(I2) ARI 460 GO TO 100 ARI 470 80 IF(RC(I2).NE.0.0) GO TO 85 ARI 480 RC(I)=0.0 ARI 490 CALL ERROR (106) ARI 500 GO TO 100 ARI 510 85 RC(I)=RC(I1)/RC(I2) ARI 520 GO TO 100 ARI 530 90 RC(I)=FEXP2(RC(I1),RC(I2)) ARI 540 GO TO 100 ARI 545 95 CALL ACCDIG(RC(I1),RC(I2),RC(I),1) ARI 547 100 I1=I1+KK(1) ARI 550 110 I2=I2+KK(2) ARI 560 RETURN ARI 570 120 IF(NARGS.EQ.5) GO TO 130 ARI 580 I5=I4 ARI 590 KK(5)=KK(4) ARI 600 130 DO 200 I=I5,JJ ARI 610 GO TO (140,150,160,170,180),L2 ARI 620 140 X=RC(I1)+RC(I2) ARI 630 GO TO 190 ARI 640 150 X=RC(I2)-RC(I1) ARI 650 GO TO 190 ARI 660 160 X=RC(I1)*RC(I2) ARI 670 GO TO 190 ARI 680 170 IF(RC(I2).NE.0.0) GO TO 175 ARI 690 X=0.0 ARI 700 CALL ERROR(106) ARI 710 GO TO 190 ARI 720 175 X=RC(I1)/RC(I2) ARI 730 GO TO 190 ARI 740 180 X=FEXP2(RC(I1),RC(I2)) ARI 750 190 RC(I)=X*RC(I3)+RC(I4) ARI 760 I1=I1+KK(1) ARI 765 I2=I2+KK(2) ARI 770 I3=I3+KK(3) ARI 775 I4=I4+KK(4) ARI 780 200 CONTINUE ARI 785 RETURN ARI 790 END ARI 800 SUBROUTINE ARYVEC ARY 10 C VERSION 5.00 ARYVEC 5/15/70 ARY 20 C SUBROUTINE ARYVEC R.VARNER 9/27/67 ARY 30 C * ARY 40 C SUBROUTINE TO MULTIPLY MATRIX TIME VECTOR ARY 50 C OR VECTOR TRANSPOSE TIME MATRIX ARY 60 C L2=1 MULTIPLY MATRIX TIME VECTOR ARY 70 C GENERAL FORM OF COMMAND ARY 80 C M(AV) A (,) N,K VECTOR IN COL I STORE IN COLUMN J ARY 90 C M(AV) A (,) N,K VECTOR IN COL I STORE IN ROW K COL J ARY 100 C N AND K MUST BE SPECIFIED ARY 110 C L2=2 MULTIPLY VECTOR TRANSPOSE TIMES MATRIX ARY 120 C GENERAL FORM OF COMMAND ARY 130 C M(V,A) A (,) N,K VECTOR IN COL I STORE IN ROW J ARY 140 C M(V,A) A (,) N,K VECTOR IN COL I STORE IN ROW K COL J ARY 150 C N AND K MUST BE SPECIFIED ARY 160 C IF ONLY ROW IS GIVEN FOR STORAGE COL 1 IS ASSUMED ARY 170 C * ARY 180 COMMON /BLOCRC/ NRC,RC(12600) ARY 200 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NARY 210 1ARGS,VWXYZ(8),NERROR ARY 220 DIMENSION ARGS(100) ARY 230 EQUIVALENCE (ARGS(1),RC(12501)) ARY 240 COMMON /SCRAT/ NS,NS2,A(13500) ARY 250 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ARY 260 DIMENSION X(1) ARY 270 DOUBLE PRECISION X,SUM ARY 280 EQUIVALENCE (X,A) ARY 290 C * ARY 310 C CHECK FOR CORRECT NUMBER OF ARGUMENTS ARY 320 C * ARY 330 IF (NARGS.NE.6.AND.NARGS.NE.7) CALL ERROR (10) ARY 340 C * ARY 350 C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS ARY 360 C * ARY 370 J=NARGS ARY 380 CALL CKIND (J) ARY 390 IF (J.NE.0) CALL ERROR (3) ARY 400 C * ARY 410 C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE ARY 420 C * ARY 430 GO TO (10,20), L2 ARY 440 10 IADD=IARGS(4) ARY 450 IADD2=IARGS(3) ARY 460 ICOMP=NROW ARY 470 GO TO 30 ARY 480 20 IADD=IARGS(3) ARY 490 IADD2=IADD ARY 500 ICOMP=NCOL ARY 510 IF (NARGS.NE.6) GO TO 30 ARY 520 IF (IARGS(6).GT.NROW.OR.IARGS(4).GT.NCOL) CALL ERROR (17) ARY 530 C * ARY 540 C COMPUTE ADDRESS OF COLUMNS ARY 550 C * ARY 560 30 IARGS(10)=IARGS(NARGS) ARY 570 IARGS(8)=1 ARY 580 GO TO (70,40), L2 ARY 590 40 IF (NARGS.EQ.7) GO TO 50 ARY 600 J=2 ARY 610 IROWSV=IARGS(6) ARY 620 GO TO 60 ARY 630 50 IARGS(12)=IARGS(4) ARY 640 IARGS(11)=1 ARY 650 IARGS(9)=IARGS(6) ARY 660 J=3 ARY 670 60 IARGS(7)=IARGS(3) ARY 680 GO TO 90 ARY 690 70 J=3 ARY 700 IARGS(12)=1 ARY 710 IARGS(11)=IARGS(3) ARY 720 IARGS(7)=IARGS(4) ARY 730 IF (NARGS.EQ.6) GO TO 80 ARY 740 IARGS(9)=IARGS(6) ARY 750 GO TO 90 ARY 760 80 IARGS(9)=1 ARY 770 90 IARGS(6)=IARGS(5) ARY 780 IARGS(5)=1 ARY 790 CALL MTXCHK (J) ARY 800 IF (J-1) 120,100,110 ARY 810 100 CALL ERROR (3) ARY 820 RETURN ARY 830 110 CALL ERROR (17) ARY 840 RETURN ARY 850 C * ARY 860 C CHECK FOR PREVIOUS ERRORS ARY 870 C * ARY 880 120 IF (NERROR.NE.0) RETURN ARY 890 GO TO (130,140), L2 ARY 900 130 ICS=IARGS(9) ARY 910 IAP=IARGS(1) ARY 920 IP=IARGS(3) ARY 930 JP=IARGS(4) ARY 940 IAD1=NROW ARY 950 IAD2=1 ARY 960 IBP=IARGS(5) ARY 970 GO TO 170 ARY 980 140 IBP=IARGS(1) ARY 990 IAP=IARGS(5) ARY1000 IP=IARGS(4) ARY1010 IF (NARGS.EQ.7) GO TO 150 ARY1020 JP=IARGS(3) ARY1030 ICS=IROWSV ARY1040 GO TO 160 ARY1050 150 JP=IARGS(3) ARY1060 ICS=IARGS(9) ARY1070 160 IAD1=1 ARY1080 IAD2=NROW ARY1090 170 IC=1 ARY1100 DO 210 I=1,IP ARY1110 IA=IAP ARY1120 IB=IBP ARY1130 IS=NS2 ARY1140 DO 180 J=1,JP ARY1150 X(IS)=RC(IA)*RC(IB) ARY1160 IS=IS-1 ARY1170 IA=IA+IAD1 ARY1180 180 IB=IB+1 ARY1190 CALL SORTSM (JP,SUM) ARY1200 A(IC)=SUM ARY1210 IC=IC+1 ARY1220 GO TO (190,200), L2 ARY1230 190 IAP=IAP+1 ARY1240 GO TO 210 ARY1250 200 IBP=IBP+NROW ARY1260 210 CONTINUE ARY1270 C * ARY1280 C STORE RESULT IN WORKSHEET ARY1290 C * ARY1300 IS=1 ARY1310 DO 220 I=1,IP ARY1320 RC(ICS)=A(IS) ARY1330 IS=IS+1 ARY1340 ICS=ICS+IAD2 ARY1350 220 CONTINUE ARY1360 RETURN ARY1370 END ARY1380 SUBROUTINE ASTER AST 10 C VERSION 5.00 ASTER 5/15/70 AST 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND AST 30 DIMENSION NAM(2) AST 40 C AST 50 C ASTERISKS HAVE BEEN FOUND. LOOK FOR A SPECIAL FORM OF ARGUMENT. AST 60 C AST 70 C FORMS CAN BE... AST 80 C AST 90 C *PHYSCON* A PHYSICAL CONSTANT NAME, FL.PT. AST 100 C **VARCON** A -VARIABLE- CONSTANT TO BE USED AS AN INTERGER(TRUN)AST 110 C *VARCON* A -VARIABLE- COSNTANT TO BE USED AS A FT.PT. NUMBER AST 120 C **ROW,COLUMN** A WORKSHEET ENTRY TO BE TRUNCATED AND USED AS INTAST 130 C *ROW,COLUMN* A WORKSHEET ENTRY TO BE USED AS FLOATING POINT AST 140 C AST 150 C NONBLA IS A FUNCTION WHICH RETURNS THE NEXT NON-BLANK CHARACTER AST 160 C IN THE CARD AND ALSO POINTS M AT IT AST 170 C AST 180 C KARD = 1, SINGLE *. KARG = 0, DOUBLE *. AST 190 C AST 200 L=KARG AST 210 K=NONBLA(M) AST 220 IF (K.NE.40) GO TO 20 AST 230 C AST 240 C A LONG LINE OF ASTERISKS FOUND, SKIP OVER THEM AND IGNORE AST 250 C AST 260 KARG=7 AST 270 10 M=M+1 AST 280 IF (KARD(M)-40) 100,10,100 AST 290 20 IF (K.GE.36) GO TO 60 AST 300 IF (K.GE.10) GO TO 40 AST 310 C AST 320 C NUMBER IS FIRST NON-BLANK CHARACTER, SET N = COMMA AST 330 C AST 340 N=43 AST 350 30 CALL AARGS AST 360 IF (KARG.NE.0) GO TO 60 AST 370 IF (NONBLA(M).EQ.N) IF (N-40) 35,37,35 AST 375 GO TO 60 AST 380 35 IF (NONBLA(M+1).GE.10) GO TO 60 AST 390 C AST 400 C SET N = ASTERISK AST 410 C AST 420 N=40 AST 430 T=ARG AST 440 GO TO 30 AST 450 37 ARG2=ARG AST 460 ARG=T AST 470 KARG=5 AST 480 GO TO 90 AST 490 C AST 500 C LETTER FOUND FIRST AST 510 C AST 520 40 CALL NNAME (NAM(1)) AST 530 CALL PHYCON (NAM(1)) AST 540 IF (ARG.EQ.0.) GO TO 50 AST 550 C AST 560 C PHYSICAL CONSTANT FOUND, SET KARG = 1 AST 570 C AST 580 KARG=1 AST 590 IF (L) 60,60,80 AST 600 C AST 610 C NAME NOT A PHYSICAL CONSTANT LIST, TRY VARIABLE LIST AST 620 C AST 630 50 CALL VARCON (NAM(1)) AST 640 IF (ARG.NE.0.) GO TO 70 AST 650 60 KARG=1 AST 660 RETURN AST 670 70 KARG=3 AST 680 80 IF (NONBLA(M).NE.40) GO TO 60 AST 690 90 M=M+1 AST 700 C AST 710 C CHECK THAT THE NUMBER OF ASTERISK AT THE END OF THE EXPRESSION AST 720 C IS THE SAME AS THE BEGINNING. L=0 MEANS 2, L=1 MEANS 1 AST 730 C AST 740 IF (L.NE.0) IF (KARD(M)-40) 95,60,95 AST 750 IF (KARD(M).NE.40.OR.KARD(M+1).EQ.40) GO TO 60 AST 760 95 M=M+1 AST 770 KARG=KARG+L AST 780 100 RETURN AST 790 END AST 800 SUBROUTINE BEGIN BEG 10 C VERSION 5.00 BEGIN 5/15/70 BEG 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND BEG 30 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG BEG 40 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) BEG 50 COMMON /BLOCRC/ NRC,RC(12600) BEG 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NBEG 70 1ARGS,VWXYZ(8),NERROR BEG 80 DIMENSION ARGS(100) BEG 90 EQUIVALENCE (ARGS(1),RC(12501)) BEG 100 C BEG 110 C THIS SUBROUTINE CONTAINS THE CODING FOR BEGIN AND SCAN BEG 120 C BEG 140 IF (L2.EQ.1) GO TO 20 BEG 150 C BEG 160 C SCAN (CARD UP TO AND INCLUDING CARD COLUMN ++ ) BEG 170 IF (NARGS.GT.1) CALL ERROR (221) BEG 180 IF (NARGS.GE.1.AND.KIND(1).EQ.0.AND.IARGS(1).GE.6.AND.IARGS(1).LE.BEG 190 180) GO TO 10 BEG 200 K=205 BEG 210 GO TO 30 BEG 220 10 KRDEND=IARGS(1) BEG 230 GO TO 40 BEG 240 C BEG 250 C BEGIN STORING INSTRUCTIONS AT NUMBER ++ BEG 260 C IF NO NUMBER IS GIVEN, 1 IS ASSUMED BEG 270 C BEG 280 20 IF (MODE.EQ.1) GO TO 50 BEG 290 K=5 BEG 300 30 CALL ERROR (K) BEG 310 40 RETURN BEG 320 50 IF (NARGS-1) 70,90,60 BEG 330 60 K=10 BEG 340 GO TO 30 BEG 350 70 NSTMT=0 BEG 360 80 MODE=3 BEG 370 GO TO 40 BEG 380 90 IF (KIND(1).EQ.0) GO TO 100 BEG 390 K=20 BEG 400 GO TO 30 BEG 410 100 IF (IARGS(1).GT.0.AND.IARGS(1).LT.1000) GO TO 110 BEG 420 K=7 BEG 430 GO TO 30 BEG 440 110 NSTMT=10*(IARGS(1)-1) BEG 450 GO TO 80 BEG 460 END BEG 470 SUBROUTINE BEJN (IST,R,Z) BEJ 10 C VERSION 5.00 BEJN 5/15/70 BEJ 20 C IF IST=0 ENTRY IS FOR BEJN BEJ 30 C IF IST=1 ENTRY IS FOR BEIN BEJ 40 DIMENSION R(1) BEJ 50 DOUBLE PRECISION X,R,Z,A,B,C,D,E,F,G,P,Q,Y BEJ 60 Y=1.D0 BEJ 70 IF (IST.NE.0) Y=-1.D0 BEJ 80 X=Z BEJ 90 DO 10 N=1,100 BEJ 100 10 R(N)=0.0 BEJ 110 LA=0 BEJ 120 IF (X.LE.60.) GO TO 30 BEJ 130 LA=1 BEJ 140 IF (X.LE.100.) GO TO 20 BEJ 150 CALL ERROR (225) BEJ 160 GO TO 130 BEJ 170 20 X=X/2.D0 BEJ 180 30 A=X/2.D0 BEJ 190 IF (X.GT.15.) GO TO 100 BEJ 200 B=1.D0 BEJ 210 C=1.D0 BEJ 220 DO 40 N=1,100 BEJ 230 J=N BEJ 240 B=B*A/C BEJ 250 C=C+1.D0 BEJ 260 IF (B.LE..5D-30) GO TO 50 BEJ 270 40 CONTINUE BEJ 280 50 D=B*A/C BEJ 290 A=A**2 BEJ 300 K=X+6.D0 BEJ 310 E=K BEJ 320 F=K+J BEJ 330 G=F+1.D0 BEJ 340 P=1.D0 BEJ 350 Q=1.D0 BEJ 360 DO 60 N=1,K BEJ 370 P=1.D0-P*A/(E*F)*Y BEJ 380 Q=1.D0-Q*A/(E*G)*Y BEJ 390 E=E-1.D0 BEJ 400 F=F-1.D0 BEJ 410 60 G=G-1.D0 BEJ 420 R(J+1)=B*P BEJ 430 R(J+2)=D*Q BEJ 440 70 DO 80 N=1,J BEJ 450 K=J-N+1 BEJ 460 A=K BEJ 470 80 R(K)=2.D0*A*R(K+1)/X-R(K+2)*Y BEJ 480 IF (LA.EQ.0) GO TO 130 BEJ 490 LA=LA-1 BEJ 500 A=R(1)*R(100) BEJ 510 B=.0D0 BEJ 520 DO 90 N=1,99 BEJ 530 K=100-N BEJ 540 A=A+R(N+1)*R(K) BEJ 550 90 B=B+R(N)*R(K) BEJ 560 J=98 BEJ 570 R(100)=A BEJ 580 R(99)=B BEJ 590 X=Z BEJ 600 GO TO 70 BEJ 610 100 K=1.5*X BEJ 620 B=1.D0 BEJ 630 C=K BEJ 640 DO 110 N=1,K BEJ 650 B=A*B/C BEJ 660 110 C=C-1.D0 BEJ 670 P=2.D-9 BEJ 680 IF (LA.EQ.1) P=5.D-20 BEJ 690 C=K+1 BEJ 700 DO 120 N=1,30 BEJ 710 J=K+N BEJ 720 B=B*A/C BEJ 730 C=C+1.D0 BEJ 740 IF (B.LT.P) GO TO 50 BEJ 750 IF (J.EQ.98) GO TO 50 BEJ 760 120 CONTINUE BEJ 770 GO TO 50 BEJ 780 130 RETURN BEJ 790 END BEJ 800 SUBROUTINE BESSEL BES 10 C VERSION 5.00 BESSEL 5/15/70 BES 20 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NBES 30 1ARGS,VWXYZ(8),NERROR BES 40 COMMON /BLOCRC/ NRC,RC(12600) BES 50 EQUIVALENCE (ARGS(1),RC(12501)) BES 60 DIMENSION ARGS(100) BES 70 COMMON /SCRAT/ NS,NS2,A(13500) BES 80 DOUBLE PRECISION DBEJ,X,Y,E,P,Q,S,T,BINTJ0,COMELL,Z,DXEX,XEX BES 90 DOUBLE PRECISION FDCOS,FDEXP BES 100 DOUBLE PRECISION AA(1000),B(1000),W(100) BES 110 EQUIVALENCE (A(1),AA), (A(2001),B), (A(4001),W) BES 120 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG BES 130 DIMENSION R(1), IA(1), KI(1) BES 140 EQUIVALENCE (R,RC), (IA,IARGS), (KI,KIND), (NR,NRMAX) BES 150 COMMON /ABEKI/ X,Y,P,Q,S,T BES 160 DOUBLE PRECISION DSNCOS,DXEXP BES 170 COMMON /CONSLB/ XTRIG,XEXP BES 180 COMMON /DCONLB/ DSNCOS,DXEXP BES 190 C BES 200 C WJG PATCH )())()()())()()()()()()()()()()()()() BES 210 C BES 220 XEX=XEXP-3.0 BES 225 DXEX=DXEXP-4.0D0 BES 227 IF (NARGS.GE.2) GO TO 10 BES 230 CALL ERROR (10) BES 240 RETURN BES 250 C BES 260 C END PATCH )()()()()()()()()()()()()()() BES 270 C BES 280 10 IF (L2.GT.28) GO TO 250 BES 290 N=0 BES 300 L=L2/2 BES 310 L=2*L BES 320 IF (L.EQ.L2) N=1 BES 330 IF (L2.GT.12) GO TO 110 BES 340 IF (NARGS.GT.2) CALL ERROR (10) BES 350 CALL ADRESS (NARGS,J) BES 360 IF (J.LE.0) CALL ERROR (11) BES 370 LT=1 BES 380 IF (KI(1).EQ.1) GO TO 20 BES 390 CALL ADRESS (1,JA) BES 400 IF (JA.LE.0) CALL ERROR (11) BES 410 LT=2 BES 420 20 M=1 BES 430 IF (NERROR.NE.0) RETURN BES 440 IF (L2.GT.2) M=5 BES 450 IF (L2.GT.4) M=3 BES 460 IF (L2.GT.6) M=7 BES 470 IF (L2.GT.8) M=3 BES 480 IF (L2.GT.10) M=7 BES 490 L=0 BES 500 IF (L2.GT.4) L=1 BES 510 IF (L2.GT.8) L=2 BES 520 IF (LT.EQ.1) GO TO 70 BES 530 DO 50 I=1,NR BES 540 X=R(JA) BES 550 JA=JA+1 BES 560 Y=1.D0 BES 570 IF (L.EQ.0) GO TO 33 BES 580 IF (L.EQ.2) GO TO 30 BES 590 IF(DABS(X).LT.XEX) GO TO 33 BES 600 C IF 1X1 IS GREATER THEN XEXP AND LESS THEN DXEXP THE RESULTS BES 610 C WILL BE SCALED BY EXP (X) OR EXP(-X) BES 620 C IF 1X1 IS GREATER THEN DXEXP THE SUBROUTINE DBEJ DOES THE SCALINGBES 630 C AND A MESSAGE IS PRINTED. BES 640 C THIS APPLIES TO THE FOLLOWING COMMANDS BIZERO, BIONE, BKZERO, BES 650 C BKONE BES 660 CALL ERROR (105) BES 670 30 IF (DABS(X).GT.DXEX) GO TO 33 BES 680 Y=FDEXP(X) BES 690 IF (M.EQ.3) Y=1.D0/Y BES 700 33 IF (M.EQ.5.OR.M.EQ.7) IF(X) 35,35,40 BES 705 GO TO 40 BES 710 35 R(J)=0. BES 720 CALL ERROR (101) BES 730 GO TO 50 BES 740 C L2=1,M=1,N=0,LT=2,L=0 :BJZERO OF ++ STORE IN ++ BES 750 C L2=2,M=1,N=1,LT=2,L=0 :BJONE OF ++ STORE IN ++ BES 760 C L2=3,M=5,N=0,LT=2,L=0 :BYZERO OF ++ STORE IN ++ BES 770 C L2=4,M=5,N=1,LT=2,L=0 :BYONE OF ++ STORE IN ++ BES 780 C L2=5,M=3,N=0,LT=2,L=1 :BIZERO OF ++ STORE IN ++ BES 790 C L2=6,M=3,N=1,LT=2,L=1 :BIONE OF ++ STORE IN ++ BES 800 C L2=7,M=7,N=0,LT=2,L=1 :BKZERO OF ++ SOTRE IN ++ BES 810 C L2=8,M=7,N=1,LT=2,L=1 :BKONE OF ++ STORE IN ++ BES 820 C L2=9,M=3,N=0,LT=2,L=2 :EXJZERO OF ++ STORE IN ++ BES 830 C L2=10,M=3,N=1,LT=2,L=2 :EXIONE OF ++ STORE IN ++ BES 840 C L2=11,M=7,N=0,LT=2,L=2 :EXKZERO OF ++ STORE IN ++ BES 850 C L2=12,M=7,N=1,LT=2,L=2 :EXKONE OF ++ STORE IN ++ BES 860 40 R(J)=Y*DBEJ(X,N,M) BES 870 50 J=J+1 BES 880 60 RETURN BES 890 70 X=ARGS(1) BES 900 Y=1.D0 BES 910 IF (L.EQ.0) GO TO 90 BES 920 IF (L.EQ.2) GO TO 80 BES 930 IF (DABS(X).LT.XEX) GO TO 90 BES 940 C SEE COMMENTS ABOVE ON BOUNDS OF X BEFORE DBEJ IS CALLED BES 950 CALL ERROR (105) BES 960 80 IF (DABS(X).GT.DXEX) GO TO 90 BES 970 Y=FDEXP(X) BES 980 IF (M.EQ.3) Y=1.D0/Y BES 990 C L2=1,M=1,N=0,LT=1,L=0 :BJZERO OF ++ STORE IN ++ BES1000 C L2=2,M=1,N=1, LT=1,L=0 :BJONE OF ++ STORE IN ++ BES1010 C L2=3,M=5,N=0,LT=1,L=0 :BYZERO OF ++ STORE IN ++ BES1020 C L2=4,M=5,N=1,LT=1,L=0 :BYONE OF ++ STORE IN ++ BES1030 C L2=5,M=3,N=0,LT=1,L=1 :BIZERO OF ++ STORE IN ++ BES1040 C L2=6,M=3,N=1,LT=1,L=1 :BIONE OF ++ STORE IN ++ BES1050 C L2=6,M=3,N=1,LT=1,L=1 :BIONE OF ++ STORE IN ++ BES1060 C L2=7,M=7,N=0,LT=1,L=1 :BKZERO OF ++ SOTRE IN ++ BES1070 C L2=8,M=7,N=1,LT=1,L=1 :BKONE OF ++ STORE IN ++ BES1080 C L2=9,M=3,N=0,LT=1,L=2 :EXJZERO OF ++ STORE IN ++ BES1090 C L2=10,M=3,N=1,LT=1,L=2 :EXIONE OF ++ STORE IN ++ BES1100 C L2=11,M=7,N=0,LT=1,L=2 :EXKZERO OF ++ STORE IN ++ BES1110 C L2=12,M=7,N=1,LT=1,L=2 :EXKONE OF ++ STORE IN ++ BES1120 90 X=Y*DBEJ(X,N,M) BES1130 DO 100 I=1,NR BES1140 R(J)=X BES1150 100 J=J+1 BES1160 GO TO 60 BES1170 110 IF (L2.GT.20) GO TO 210 BES1180 IF (NARGS.GT.3) CALL ERROR (10) BES1190 M=1 BES1200 IF (L2.GT.14) M=2 BES1210 IF (L2.GT.16) M=1 BES1220 IF (L2.GT.18) M=2 BES1230 L=0 BES1240 IF (L2.GT.16) L=1 BES1250 Y=.785398163397D0 BES1260 LV=0 BES1270 JX=0 BES1280 120 CALL ADRESS (NARGS,J2) BES1290 IF (J2.LE.0) CALL ERROR (11) BES1300 CALL ADRESS (NARGS-1,J1) BES1310 IF (J1.LE.0) CALL ERROR (11) BES1320 LT=0 BES1330 IF (KI(1).EQ.1) GO TO 130 BES1340 CALL ADRESS (1,JA) BES1350 IF (JA.LE.0) CALL ERROR (11) BES1360 LT=1 BES1370 130 K=0 BES1380 KA=0 BES1390 IF (LT+LV.EQ.0) GO TO 200 BES1400 IF (LV.EQ.0) GO TO 230 BES1410 IF (LT.EQ.0) GO TO 240 BES1420 140 IF (NERROR.NE.0) RETURN BES1430 DO 190 I=1,NRMAX BES1440 IF (KA.EQ.0) X=R(JA) BES1450 JA=JA+1 BES1460 E=1.D0 BES1470 IF (JX.NE.0) Y=R(JB) BES1480 JB=JB+1 BES1490 C L2=15,M=2,N=0,L=0 :KBKZERO OF $$ PUT REAL IN ++ IMAGINARY ++ BES1500 C L2=16,M=2,N=1,L=0 :KBKONE OF $$ PUT REAL IN ++ IMAGINARY ++ BES1510 C L2=19,M=2,N=0,L=1 :KEXKZR OF $$ PUT REAL IN ++ IMAGINARY ++ BES1520 C L2=20,M=2,N=1,L=1 :KEXKONE OF $$ PUT REAL IN ++ IMAGINARY ++ BES1530 C L2=23,M=2,N=0,L=0 :CKZERO OF $$ OHI $$ UT REAL ++ IMAG ++ BES1540 C L2=24,7=2,N=1,L=0 :CKONE OF $$ PHI $$ PUT REAL ++ IMAG ++ BES1550 C L2=27,M=2,N=0,L=1 :CEKZERO OF $$ PHI $$ PUT REAL ++ IMAG ++ BES1560 C L2=28,M=2,N=1,L=1 :CEKONE OF $$ PHI $$ PUT REAL ++ IMAG ++ BES1570 IF (M.EQ.2) CALL CBEK BES1580 C L2=13,M=2,N=0,L=0 :KBIZERO OF $$ PUT REAL IN ++ IMAGINARY ++ BES1590 C L2=14,M=2,N=1,L=0 :KBIONE OF $$ PUT REAL IN ++ IMAGINARY ++ BES1600 C L2=18,M=2,N=0,L=1 :KEXIONE OF $$ PUT REAL IN ++ IMAGINARY ++ BES1610 C L2=20,M=2,N=0,L=0 :CIZERO OF $$ OHI $$ UT REAL ++ IMAG ++ BES1620 C L2=21,7=2,N=1,L=0 :CIONE OF $$ PHI $$ PUT REAL ++ IMAG ++ BES1630 C L2=25,M=2,N=0,L=1 :CEIZERO OF $$ HI $$ UT REAL ++ IMAG ++ BES1640 C L2=26,M=2,N=1,L=1 :CEIONE OF $$ PHI $$ PUT REAL ++ IMAG ++ BES1650 IF (M.EQ.1) CALL CBEI BES1660 Z=X*FDCOS(Y) BES1670 IF (L.EQ.1) GO TO 150 BES1680 IF (DABS(Z).LT.XEX) GO TO 160 BES1690 CALL ERROR (105) BES1700 150 E=FDEXP(Z) BES1710 IF (M.EQ.1) E=1.D0/E BES1720 160 IF (N.EQ.0) GO TO 170 BES1730 C STORE INTO WORK SHEET RESULTS OF COMMANDS KBIONE, KBKONE BES1740 C KEXIONE, KEXKONE, CIONE, CEIONE, CEKONE BES1750 R(J1)=E*S BES1760 R(J2)=E*T BES1770 GO TO 180 BES1780 C STORE INTO WORK SHEET RESULTS OF COMMANDS KBIZERO, KBKZERO, BES1790 C KEXIZER, KEXKZER, CIZERO, CEIZERO, CEKZERO BES1800 170 R(J1)=E*P BES1810 R(J2)=E*Q BES1820 180 J1=J1+1 BES1830 190 J2=J2+1 BES1840 RETURN BES1850 200 IF (JX.EQ.0) GO TO 240 BES1860 Y=ARGS(2) BES1870 X=ARGS(1) BES1880 KA=1 BES1890 JX=0 BES1900 GO TO 140 BES1910 210 IF (NARGS.GT.4) CALL ERROR (10) BES1920 JX=1 BES1930 LV=0 BES1940 IF (KI(2).EQ.1) GO TO 220 BES1950 CALL ADRESS (2,JB) BES1960 IF (JB.LE.0) CALL ERROR (11) BES1970 LV=1 BES1980 220 M=1 BES1990 IF (L2.GT.22) M=2 BES2000 IF (L2.GT.24) M=1 BES2010 IF (L2.GT.26) M=2 BES2020 L=0 BES2030 IF (L2.GT.24) L=1 BES2040 GO TO 120 BES2050 230 IF (JX.EQ.0) GO TO 140 BES2060 Y=ARGS(2) BES2070 JX=0 BES2080 GO TO 140 BES2090 240 KA=1 BES2100 X=ARGS(1) BES2110 GO TO 140 BES2120 250 IF (L2.GT.32) GO TO 350 BES2130 260 IF (NARGS.GT.2) CALL ERROR (10) BES2140 CALL ADRESS (NARGS,J) BES2150 IF (J.LE.0) CALL ERROR (11) BES2160 LT=0 BES2170 IF (KI(1).EQ.1) GO TO 270 BES2180 CALL ADRESS (1,JA) BES2190 IF (JA.LE.0) CALL ERROR (11) BES2200 LT=1 BES2210 270 IF (NERROR.NE.0) RETURN BES2220 IF (LT.EQ.0) X=ARGS(1) BES2230 IF (L2.GT.37) GO TO 310 BES2240 IF (L2.EQ.32) GO TO 310 BES2250 IF (L2.GT.29) GO TO 290 BES2260 DO 280 N=1,NR BES2270 IF (LT.EQ.1) X=R(JA) BES2280 JA=JA+1 BES2290 C L2=29 :INTJO OF $$ STORE IN ++ BES2300 R(J)=BINTJ0(X,W,Z) BES2310 280 J=J+1 BES2320 RETURN BES2330 290 K=1 BES2340 IF (L2.EQ.31) K=2 BES2350 DO 300 N=1,NR BES2360 IF (LT.EQ.1) X=R(JA) BES2370 JA=JA+1 BES2380 C L2=30,K=1 :ELLIPTICAL FIRST OF $$ STORE IN ++ BES2390 C L2=31,K=2 :ELLIPTICAL SECOND OF $$ STORE IN ++ BES2400 R(J)=COMELL(X,K) BES2410 300 J=J+1 BES2420 RETURN BES2430 310 IF (LT.EQ.1) CALL ERROR (20) BES2440 Z=X BES2450 K=NR BES2460 IF (K.LE.100) GO TO 330 BES2470 K=100 BES2480 JA=J+100 BES2490 DO 320 I=K,NR BES2500 R(JA)=0.0 BES2510 320 JA=JA+1 BES2520 C L2=32 :BESJN X= ** STORE IN ++ BES2530 330 IF (L2.EQ.32) CALL BEJN (0,W,Z) BES2540 C L2=38 :BESIN X= ** STORE IN ++ BES2550 IF (L2.EQ.38) CALL BEJN (1,W,Z) BES2560 IF (L2.EQ.39) GO TO 460 BES2570 DO 340 N=1,K BES2580 R(J)=W(N) BES2590 340 J=J+1 BES2600 RETURN BES2610 350 IF (L2.GT.34) GO TO 390 BES2620 L=NR BES2630 IF (NR.GT.1000) L=1000 BES2640 IF (NARGS.GT.2) CALL ERROR (10) BES2650 CALL ADRESS (NARGS,J) BES2660 IF (J.LE.0) CALL ERROR (11) BES2670 IF (KI(1).EQ.1) CALL ERROR (20) BES2680 CALL ADRESS (1,JA) BES2690 IF (JA.LE.0) CALL ERROR (11) BES2700 IF (NERROR.NE.0) RETURN BES2710 IF (L2.EQ.33) GO TO 360 BES2720 C L2=34 :ZEROS BJZERO STORE IN ++ AND ++ BES2730 CALL BEZONE (AA,B,1,L) BES2740 GO TO 370 BES2750 C L2=33 :ZEROS BJONE STORE IN ++ AND ++ BES2760 360 CALL BEZERO (AA,B,1,L) BES2770 370 DO 380 N=1,L BES2780 R(JA)=AA(N) BES2790 R(J)=B(N) BES2800 JA=JA+1 BES2810 380 J=J+1 BES2820 RETURN BES2830 390 IF (L2.GT.36) GO TO 430 BES2840 IF (NARGS.GT.2) CALL ERROR (10) BES2850 CALL ADRESS (NARGS,J) BES2860 IF (J.LE.0) CALL ERROR (11) BES2870 LT=0 BES2880 IF (KI(1).EQ.1) GO TO 400 BES2890 CALL ADRESS (1,JA) BES2900 IF (JA.LE.0) CALL ERROR (11) BES2910 LT=1 BES2920 400 IF (LT.EQ.0) X=ARGS(1) BES2930 IF (NERROR.NE.0) RETURN BES2940 K=0 BES2950 IF (L2.EQ.36) K=1 BES2960 DO 420 N=1,NR BES2970 IF (LT.NE.0) X=R(JA) BES2980 JA=JA+1 BES2990 C L2=35,K=0 :STRUVE ZERO OF $$ STORE IN ++ BES3000 C L2=36,K=1 :STRUVE ONE OF $$ STORE IN ++ BES3010 CALL STRUVE (X,Y,Z,W) BES3020 IF (K.EQ.0) GO TO 410 BES3030 C STORE RESULTS FOR STRUVE ONE BES3040 R(J)=Z BES3050 GO TO 420 BES3060 C STORE RESULTS OF STRUVE ZERO BES3070 410 R(J)=Y BES3080 420 J=J+1 BES3090 RETURN BES3100 430 IF (L2.GT.37) GO TO 260 BES3110 IF (NARGS.GT.3) CALL ERROR (10) BES3120 CALL ADRESS (NARGS,J) BES3130 IF (J.LE.0) CALL ERROR (11) BES3140 IF (KI(1).EQ.1) CALL ERROR (20) BES3150 CALL ADRESS (1,JA) BES3160 IF (JA.LE.0) CALL ERROR (11) BES3170 JB=IA(2) BES3180 IF (KI(2).NE.0) CALL ERROR (3) BES3190 IF (NERROR.NE.0) RETURN BES3200 K=IA(2) BES3210 LNR=NRMAX BES3220 IF (LNR.GT.1000) LNR=1000 BES3230 DO 440 N=1,LNR BES3240 AA(N)=R(JA) BES3250 440 JA=JA+1 BES3260 C L2=37 :HARMONIC OF ++ ,, STORE IN ++ BES3270 CALL FOURIA (AA,B(1),B(2),K,L) BES3280 DO 450 N=1,JB BES3290 R(J)=B(N) BES3300 450 J=J+1 BES3310 RETURN BES3320 460 IF (X.LT.XEXP) GO TO 470 BES3330 CALL ERROR (225) BES3340 RETURN BES3350 C L2=39 :BESKN X= ** STORE IN ++ BES3360 470 AA(1)=DBEJ(X,0,7) BES3370 AA(2)=DBEJ(X,1,7) BES3380 R(J)=AA(1) BES3390 R(J+1)=AA(2) BES3400 J=J+2 BES3410 DO 480 I=3,K BES3420 Z=I-2 BES3430 AA(I)=AA(I-2)+2.*Z*AA(I-1)/X BES3440 R(J)=AA(I) BES3450 IF (AA(I).GT.3.E37) GO TO 490 BES3460 480 J=J+1 BES3470 RETURN BES3480 490 DO 500 JA=I,K BES3490 R(J)=0.0 BES3500 500 J=J+1 BES3510 RETURN BES3520 END BES3530 SUBROUTINE BEZERO (A,B,M,L) BEZ 10 C VERSION 5.00 BEZERO 5/15/70 BEZ 20 DOUBLE PRECISION A(1),B(1),X,Y,AA,AB,AC,FDSQRT BEZ 30 KB=1 BEZ 40 N=M BEZ 50 10 J=4*N-1 BEZ 60 IF (J.GT.44) GO TO 130 BEZ 70 GO TO (20,30,40,50,60,70,80,90,100,110,120), N BEZ 80 20 X=2.404825577D0 BEZ 90 Y=.5191474973D0 BEZ 100 GO TO 140 BEZ 110 30 X=5.5200781103D0 BEZ 120 Y=-.3402648065D0 BEZ 130 GO TO 140 BEZ 140 40 X=8.6537279129D0 BEZ 150 Y=.2714522999D0 BEZ 160 GO TO 140 BEZ 170 50 X=11.7915344391D0 BEZ 180 Y=-.2324598314D0 BEZ 190 GO TO 140 BEZ 200 60 X=14.9309177086D0 BEZ 210 Y=.2065464331D0 BEZ 220 GO TO 140 BEZ 230 70 X=18.0710639679D0 BEZ 240 Y=-.187728803D0 BEZ 250 GO TO 140 BEZ 260 80 X=21.2116366299D0 BEZ 270 Y=.1732658942D0 BEZ 280 GO TO 140 BEZ 290 90 X=24.3524715308D0 BEZ 300 Y=-.1617015507D0 BEZ 310 GO TO 140 BEZ 320 100 X=27.493479132D0 BEZ 330 Y=.1521812138D0 BEZ 340 GO TO 140 BEZ 350 110 X=30.6346064684D0 BEZ 360 Y=-.1441659777D0 BEZ 370 GO TO 140 BEZ 380 120 X=33.7758202136D0 BEZ 390 Y=-.1372969434D0 BEZ 400 GO TO 140 BEZ 410 130 X=J BEZ 420 X=X*3.1415926536D0 BEZ 430 AA=1.D0/X**2 BEZ 440 AB=1.D0+2.D0*AA*(1.D0-AA*(31.D0-AA*(3779.D0-AA*6277237.D0/7.D0)/ BEZ 450 15.D0)/3.D0) BEZ 460 J=N/2 BEZ 470 J=2*J BEZ 480 AC=1.D0 BEZ 490 IF (J.EQ.N) AC=-1.D0 BEZ 500 Y=AC*1.595769122D0*(1.D0-AA**2*56.D0/3.D0)/FDSQRT(X) BEZ 510 X=X*AB/4.D0 BEZ 520 140 A(KB)=X BEZ 530 B(KB)=Y BEZ 540 N=N+1 BEZ 550 KB=KB+1 BEZ 560 IF (KB.LE.L) GO TO 10 BEZ 570 RETURN BEZ 580 END BEZ 590 SUBROUTINE BEZONE (A,B,M,L) BEQ 10 C VERSION 5.00 BEZONE 5/15/70 BEQ 20 DOUBLE PRECISION A(1),B(1),R,S,T,X,Y,FDSQRT BEQ 30 KB=1 BEQ 40 N=M BEQ 50 10 J=4*N+1 BEQ 60 IF (J.GT.46) GO TO 130 BEQ 70 GO TO (20,30,40,50,60,70,80,90,100,110,120), N BEQ 80 20 X=3.8317059702D0 BEQ 90 Y=-.4027593957D0 BEQ 100 GO TO 140 BEQ 110 30 X=7.0155866698D0 BEQ 120 Y=.3001157525D00 BEQ 130 GO TO 140 BEQ 140 40 X=10.1734681351D0 BEQ 150 Y=-.2497048771D0 BEQ 160 GO TO 140 BEQ 170 50 X=13.3236919363D0 BEQ 180 Y=.2183595072D0 BEQ 190 GO TO 140 BEQ 200 60 X=16.4706300509D0 BEQ 210 Y=-.1964653715D0 BEQ 220 GO TO 140 BEQ 230 70 X=19.6158585105D0 BEQ 240 Y=.180063375D0 BEQ 250 GO TO 140 BEQ 260 80 X=22.7600843806D0 BEQ 270 Y=-.1671846005D0 BEQ 280 GO TO 140 BEQ 290 90 X=25.9036720876D0 BEQ 300 Y=.1567249863D0 BEQ 310 GO TO 140 BEQ 320 100 X=29.0468285349D0 BEQ 330 Y=-.1480111100D0 BEQ 340 GO TO 140 BEQ 350 110 X=32.1896799110D0 BEQ 360 Y=.1406057982D0 BEQ 370 GO TO 140 BEQ 380 120 X=35.3323075501D0 BEQ 390 Y=-.1342112403D0 BEQ 400 GO TO 140 BEQ 410 130 X=J BEQ 420 X=X*3.1415926536D0 BEQ 430 R=1.D0/X**2 BEQ 440 S=1.D0-6.D0*R*(1.D0-R*(1.D0-R*(157.2D0-130080.6D0*R/7.D0))) BEQ 450 J=N/2 BEQ 460 J=2*J BEQ 470 T=1.D0 BEQ 480 IF (J.NE.N) T=-1.D0 BEQ 490 Y=T*1.595769122D0*(1.D0+R**2*24.D0*(1.D0-81.6D0*R))/FDSQRT(X) BEQ 500 X=S*X/4.D0 BEQ 510 140 A(KB)=X BEQ 520 B(KB)=Y BEQ 530 N=N+1 BEQ 540 KB=KB+1 BEQ 550 IF (KB.LE.L) GO TO 10 BEQ 560 RETURN BEQ 570 END BEQ 580 FUNCTION BINTJ0 (X,A,Z) BIN 10 C VERSION 5.00 BINTJ0 5/15/70 BIN 20 DIMENSION A(1) BIN 30 DOUBLE PRECISION BINTJ0,A,Z,X,B,C,DBEJ BIN 40 Z=DABS(X) BIN 50 IF (Z.GT.100.) GO TO 20 BIN 60 CALL BEJN (0,A,Z) BIN 70 IF (Z.GT.60.) GO TO 30 BIN 80 B=.0D0 BIN 90 DO 10 N=2,100,2 BIN 100 10 B=B+A(N) BIN 110 B=2.D0*B BIN 120 GO TO 40 BIN 130 20 A(1)=DBEJ(Z,0,1) BIN 140 A(2)=DBEJ(Z,1,1) BIN 150 30 C=1.D0/Z**2 BIN 160 B=1.D0*A(2)*(1.D0-C*(1.D0-C*(9.D0-C*(225.D0-C*11025.D0)))) BIN 170 C=1.D0-C*(3.D0-C*(45.D0-C*(1575.D0-99225.D0*C))) BIN 180 B=B-A(1)*C/Z BIN 190 40 BINTJ0=B BIN 200 RETURN BIN 210 END BIN 220 SUBROUTINE BJORCK (X,B,NP,A,F) BJO 10 C VERSION 5.00 BJORCK 5/15/70 BJO 20 C INPUT IS X,B AND NP. BJO 30 C OUTPUT IS F. BJO 40 C THIS SUBROUTINE WAS ADAPTED BY ROY H. WAMPLER AND M. STUART SCOTT,BJO 50 C NATIONAL BUREAU OF STANDARDS, WASHINGTON, D. C., JULY 1969, FROM BJO 60 C A SUBROUTINE CALLED 'BJORCK' WHICH WAS WRITTEN BY WILLIAM J. HALL,BJO 70 C NATIONAL BUREAU OF STANDARDS. BOULDER, COL. THIS ROUTINE USES THEBJO 80 C MODIFIED GRAM-SCHMIDT ALGORITHM GIVEN BY AKE BJORCK IN 'SOLVING BJO 90 C LINEAR LEAST SQUARES PROBLEMS BY GRAM-SCHMIDT ORTHOGINALIZATION' BJO 100 C 'BIT' VOL. 7 (1967), PAGES 1-21. BJO 110 DOUBLE PRECISION C,D,R,Y,FDSQRT BJO 115 DIMENSION X(1), B(1), A(3,1) BJO 120 DIMENSION C(3,3), D(3), R(3), Y(4) BJO 130 C BJO 140 C INITIALIZE A AND FORM SUM OF SQUARES OF THE B VECTOR BJO 150 Y(4)=0.D0 BJO 160 DO 10 I=1,NP BJO 170 A(1,I)=1.0 BJO 180 A(2,I)=X(I) BJO 190 A(3,I)=X(I)*X(I) BJO 200 10 Y(4)=Y(4)+B(I)*B(I) BJO 210 NF=3 BJO 220 D(1)=0.D0 BJO 230 Y(1)=0.D0 BJO 240 DO 20 I=1,NP BJO 250 D(1)=A(1,I)*A(1,I)+D(1) BJO 260 20 Y(1)=A(1,I)*B(I)+Y(1) BJO 270 Y(1)=Y(1)/D(1) BJO 280 IR=0 BJO 290 DO 60 K=2,NF BJO 300 DO 40 J=K,NF BJO 310 IR=IR+1 BJO 320 R(IR)=0.D0 BJO 330 DO 30 I=1,NP BJO 340 30 R(IR)=A(K-1,I)*A(J,I)+R(IR) BJO 350 R(IR)=R(IR)/D(K-1) BJO 360 DO 40 I=1,NP BJO 370 40 A(J,I)=A(J,I)-A(K-1,I)*R(IR) BJO 380 D(K)=0.D0 BJO 390 Y(K)=0.D0 BJO 400 DO 50 I=1,NP BJO 410 B(I)=B(I)-A(K-1,I)*Y(K-1) BJO 420 Y(K)=A(K,I)*B(I)+Y(K) BJO 430 50 D(K)=A(K,I)*A(K,I)+D(K) BJO 440 60 Y(K)=Y(K)/D(K) BJO 450 IRS=-NF BJO 460 DO 90 K=1,NF BJO 470 IRS=IRS+NF-K+1 BJO 480 IR=IRS BJO 490 DO 90 JJ=1,K BJO 500 J=K-JJ+1 BJO 510 C(K,J)=Y(J) BJO 520 IF (JJ-1) 90,90,70 BJO 530 70 DO 80 I=2,JJ BJO 540 C(K,J)=C(K,J)-C(K,K-I+2)*R(IR) BJO 550 80 IR=IR-1 BJO 560 90 IR=IR-NF+K BJO 570 DO 100 I=1,NF BJO 580 100 Y(I)=Y(I)*FDSQRT(D(I)) BJO 590 F=Y(3)*Y(3)*FLOAT(NP-3)/(Y(4)-Y(1)*Y(1)-Y(2)*Y(2)-Y(3)*Y(3)) BJO 600 RETURN BJO 610 END BJO 620 C BLOCK DATA BLOCK BLO 10 C VERSION 5.00 BLOCK 5/15/70 BLO 20 BLOCK DATA BLO 30 COMMON / ABCDEF / L( 48 ) BLO 40 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH BLO 50 COMMON/FMAT/IFMTX( 6),IOSWT,IFMTS( 6),LHEAD(96) BLO 60 C BLOCK BLO 70 C ABCDEF BLO 80 C L(1) =1H0 L(2) =1H1 L(3) =1H2 L(4) =1H3 L(5) =1H4 BLO 90 C L(6) =1H5 L(7) =1H6 L(8) =1H7 L(9) =1H8 L(10)=1H9 BLO 100 C L(11)=1HA L(12)=1HB L(13)=1HC L(14)=1HD L(15)=1HE BLO 110 C L(16)=1HF L(17)=1HG L(18)=1HH L(19)=1HI L(20)=1HJ BLO 120 C L(21)=1HK L(22)=1HL L(23)=1HM L(24)=1HN L(25)=1HO BLO 130 C L(26)=1HP L(27)=1HQ L(28)=1HR L(29)=1HS L(30)=1HT BLO 140 C L(31)=1HU L(32)=1HV L(33)=1HW L(34)=1HX L(35)=1HY BLO 150 C L(36)=1HZ L(37)=1H/ L(38)=1H. L(39)=1H- L(40)=1H+ BLO 160 C L(41)=1H* L(42)=1H( L(43)=1H) L(44)=1H, L(45)=1H BLO 170 C L(46)=1H= L(47)=1H$ L(48)=1H' BLO 180 DATA L(1),L(2),L(3),L(4),L(5),L(6),L(7),L(8),L(9),L(10)/ BLO 190 1 1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ BLO 200 DATA L(11),L(12),L(13),L(14),L(15),L(16),L(17),L(18),L(19),L(20)/BLO 210 1 1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ/ BLO 220 DATA L(21),L(22),L(23),L(24),L(25),L(26),L(27),L(28),L(29),L(30)/BLO 230 1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT/ BLO 240 DATA L(31),L(32),L(33),L(34),L(35),L(36),L(37),L(38),L(39),L(40)/BLO 250 1 1HU,1HV,1HW,1HX,1HY,1HZ,1H/,1H.,1H-,1H+/ BLO 260 DATA L(41),L(42),L(43),L(44),L(45),L(46),L(47),L(48)/ BLO 270 1 1H*,1H(,1H),1H,,1H ,1H=,1H$,1H'/ BLO 280 C NOCARD CONTAINS THE MESSAGE WRITTEN SAVED FROM THE OMNITAB CARD BLO 290 DATA NOCARD(1),NOCARD(2),NOCARD(3),NOCARD(4),NOCARD(5),NOCARD(6), BLO 300 1NOCARD(7),NOCARD(8),NOCARD(9),NOCARD(10),NOCARD(11),NOCARD(12), BLO 310 2NOCARD(13),NOCARD(14),NOCARD(15),NOCARD(16),NOCARD(17),NOCARD(18),BLO 320 3NOCARD(19),NOCARD(20),NOCARD(21),NOCARD(22),NOCARD(23),NOCARD(24),BLO 330 4NOCARD(25),NOCARD(26),NOCARD(27),NOCARD(28),NOCARD(29),NOCARD(30),BLO 340 5NOCARD(31),NOCARD(32),NOCARD(33),NOCARD(34),NOCARD(35),NOCARD(36),BLO 350 6NOCARD(37),NOCARD(38),NOCARD(39),NOCARD(40)/ BLO 360 71H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H , BLO 370 81H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H , BLO 380 9 1H ,1H ,1H ,1H ,1HO,1HM,1HN,1HI/ BLO 390 DATA NOCARD(41),NOCARD(42),NOCARD(43),NOCARD(44),NOCARD(45), BLO 400 1 NOCARD(46),NOCARD(47),NOCARD(48),NOCARD(49),NOCARD(50), BLO 410 2 NOCARD(51),NOCARD(52),NOCARD(53),NOCARD(54),NOCARD(55), BLO 420 3 NOCARD(56),NOCARD(57),NOCARD(58),NOCARD(59),NOCARD(60), BLO 430 4 NOCARD(61),NOCARD(62),NOCARD(63),NOCARD(64),NOCARD(65), BLO 440 5 NOCARD(66),NOCARD(67),NOCARD(68),NOCARD(69),NOCARD(70), BLO 450 6 NOCARD(71),NOCARD(72),NOCARD(73),NOCARD(74),NOCARD(75), BLO 460 7 NOCARD(76),NOCARD(77),NOCARD(78),NOCARD(79),NOCARD(80)/ BLO 470 81HT,1HA,1HB,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H , BLO 480 91H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H , BLO 490 A1H ,1H ,1H ,1H ,1H ,1H ,1H ,1H / BLO 500 C IFMTS CONTAINS FORMAT USED BY PRINT BLO 510 DATA IFMTS(1),IFMTS(2),IFMTS(3),IFMTS(4),IFMTS(5),IFMTS(6)/ BLO 520 1 1H(,2H1P,2H8E,3H15.,1H6,1H)/ BLO 530 END BLO 540 SUBROUTINE CBEI CBI 10 C VERSION 5.00 CBEI 5/15/70 CBI 20 C COMPUTES I0(Z) AND I1(Z) FOR COMPLEX ARGUMENT R*E(IS)=Z CBI 30 COMMON /ABEKI/ R,S,A,B,C,D CBI 40 DOUBLE PRECISION A,B,C,D,R,S CBI 50 DOUBLE PRECISION E,F,G,H,P,Q,T,X,Y,Z,V,U,W,AA CBI 60 DOUBLE PRECISION FDSIN,FDCOS,FDEXP,FDSQRT CBI 70 E=FDCOS(S) CBI 80 F=FDSIN(S) CBI 90 IF (R.GT.15.5) GO TO 30 CBI 100 P=1.D0-2.D0*F**2 CBI 110 AA=P CBI 120 Q=2.D0*E*F CBI 130 W=Q CBI 140 A=1.D0 CBI 150 B=0.D0 CBI 160 C=1.D0 CBI 170 U=0.D0 CBI 180 G=1.D0 CBI 190 T=2.D0 CBI 200 X=(R/2.D0)**2 CBI 210 V=X CBI 220 Y=X CBI 230 DO 10 N=1,60 CBI 240 Z=1.D0/G**2 CBI 250 H=1.D0/(G*T) CBI 260 A=A+X*Z*P CBI 270 B=B+X*Z*Q CBI 280 C=C+V*H*P CBI 290 U=U+V*H*Q CBI 300 X=X*Y*Z CBI 310 IF (X.LT..5D-10) GO TO 20 CBI 320 V=V*Y*H CBI 330 Z=P CBI 340 P=Z*AA-Q*W CBI 350 Q=Q*AA+Z*W CBI 360 G=G+1.D0 CBI 370 10 T=T+1.D0 CBI 380 20 D=R*(C*F+U*E)/2.D0 CBI 390 C=R*(C*E-U*F)/2.D0 CBI 400 GO TO 60 CBI 410 30 Z=FDEXP(R*E)/FDSQRT(6.283185307D0*R) CBI 420 X=S/2.D0-R*F CBI 430 Y=Z*FDCOS(X) CBI 440 Z=Z*FDSIN(X) CBI 450 W=-1.D0 CBI 460 G=1.D0 CBI 470 H=3.D0 CBI 480 P=E CBI 490 Q=F CBI 500 T=1.D0 CBI 510 U=0.D0 CBI 520 V=1.D0 CBI 530 X=0.D0 CBI 540 A=1.D0 CBI 550 B=1.D0/(8.D0*R) CBI 560 C=B CBI 570 D=B CBI 580 DO 40 N=1,20 CBI 590 AA=B*G**2/A CBI 600 T=T+AA*P CBI 610 U=U+AA*Q CBI 620 AA=C*W*H/A CBI 630 V=V+AA*P CBI 640 X=X+AA*Q CBI 650 B=B*D*G**2/A CBI 660 IF (B.LT..5D-10) GO TO 50 CBI 670 C=C*D*W*H/A CBI 680 W=W+2.D0 CBI 690 G=G+2.D0 CBI 700 H=H+2.D0 CBI 710 A=A+1.D0 CBI 720 AA=P*E-Q*F CBI 730 Q=F*P+E*Q CBI 740 40 P=AA CBI 750 50 A=Y*T-Z*U CBI 760 B=-(Y*U+T*Z) CBI 770 C=Y*V-Z*X CBI 780 D=-(Y*X+Z*V) CBI 790 60 RETURN CBI 800 END CBI 810 SUBROUTINE CBEK CBK 10 C VERSION 5.00 CBEK 5/15/70 CBK 20 C COMPUTES K0(Z) AND K1(Z) FOR COMPLEX ARGUMENT Z=R*E(IS) CBK 30 COMMON /ABEKI/ R,S,A,B,C,D CBK 40 DOUBLE PRECISION A,B,C,D,R,S CBK 50 DOUBLE PRECISION E,F,G,H,P,Q,T,U,V,W,X,Y,Z,AA(40),AB(40),AC,AD,AE CBK 60 DOUBLE PRECISION FDLOG,FDCOS,FDEXP,FDSIN,FDSQRT CBK 70 COMMON /SCRAT/ NS,NS2,SCRAT(13500) CBK 80 EQUIVALENCE (SCRAT(1700),AA), (SCRAT(1800),AB) CBK 90 IF (R.LE.0.0) GO TO 80 CBK 100 E=FDCOS(S) CBK 110 F=FDSIN(S) CBK 120 IF (R.GT.8.) GO TO 40 CBK 130 P=1.D0-2.D0*F**2 CBK 140 Q=2.D0*E*F CBK 150 W=P CBK 160 Z=Q CBK 170 X=(R/2.D0)**2 CBK 180 Y=X CBK 190 V=X CBK 200 G=E*(4.D0*E**2-3.D0) CBK 210 H=F*(3.D0-4.D0*F**2) CBK 220 T=FDLOG(R/2.D0)+.5772156649D0 CBK 230 A=-T CBK 240 B=-S CBK 250 C=E*(T-0.5D0)-S*F CBK 260 U=F*(T-0.5D0)+S*E CBK 270 AC=1.D0 CBK 280 AD=2.D0 CBK 290 AA(1)=1.D0 CBK 300 AB(1)=1.25D0 CBK 310 DO 10 N=2,40 CBK 320 AE=N CBK 330 AA(N)=AA(N-1)+1.D0/AE CBK 340 10 AB(N)=AA(N)+1.D0/(2.D0*(AE+1.D0)) CBK 350 DO 20 N=1,40 CBK 360 AE=T-AA(N) CBK 370 D=P*AE-S*Q CBK 380 AE=Q*AE+S*P CBK 390 A=A-D*X/AC**2 CBK 400 B=B-AE*X/AC**2 CBK 410 AE=T-AB(N) CBK 420 D=G*AE-H*S CBK 430 AE=H*AE+G*S CBK 440 C=C+D*Y/(AC*AD) CBK 450 U=U+AE*Y/(AC*AD) CBK 460 X=X*V/AC**2 CBK 470 IF (X.LT..5D-10) GO TO 30 CBK 480 Y=Y*V/(AC*AD) CBK 490 AC=AC+1.D0 CBK 500 AD=AD+1.D0 CBK 510 AE=P CBK 520 P=AE*W-Q*Z CBK 530 Q=Q*W+AE*Z CBK 540 AE=G CBK 550 G=AE*W-H*Z CBK 560 20 H=H*W+AE*Z CBK 570 30 C=E/R+R*C/2.D0 CBK 580 D=-F/R+R*U/2.D0 CBK 590 GO TO 70 CBK 600 40 U=FDEXP(-R*E)*FDSQRT(1.5707963268D0/R) CBK 610 V=R*F+S/2.D0 CBK 620 Y=U*FDCOS(V) CBK 630 Z=U*FDSIN(V) CBK 640 W=-1.D0 CBK 650 G=1.D0 CBK 660 H=3.D0 CBK 670 P=E CBK 680 Q=F CBK 690 T=1.D0 CBK 700 U=0.D0 CBK 710 V=1.D0 CBK 720 X=0.D0 CBK 730 A=1.D0 CBK 740 B=1.D0/(8.D0*R) CBK 750 C=B CBK 760 D=B CBK 770 AC=-1.D0 CBK 780 DO 50 N=1,12 CBK 790 AD=AC*B*G**2/A CBK 800 AE=AC*C*W*H/A CBK 810 T=T+AD*P CBK 820 U=U-AD*Q CBK 830 V=V+AE*P CBK 840 X=X-AE*Q CBK 850 AD=B CBK 860 B=B*D*G**2/A CBK 870 IF (B.GT.AD) GO TO 60 CBK 880 IF (B.LT..5D-10) GO TO 60 CBK 890 C=C*D*W*H/A CBK 900 W=W+2.D0 CBK 910 H=H+2.D0 CBK 920 G=G+2.D0 CBK 930 A=A+1.D0 CBK 940 AC=-1.D0*AC CBK 950 AD=P CBK 960 P=AD*E-Q*F CBK 970 50 Q=Q*E+AD*F CBK 980 60 A=Y*T+U*Z CBK 990 B=Y*U-T*Z CBK1000 C=Y*V+X*Z CBK1010 D=Y*X-V*Z CBK1020 70 RETURN CBK1030 80 A=0.D0 CBK1040 B=-.785398163397D0 CBK1050 C=0.D0 CBK1060 D=0.D0 CBK1070 CALL ERROR (101) CBK1080 RETURN CBK1090 END CBK1100 SUBROUTINE CHANGE CHA 10 C VERSION 5.00 CHANGE 5/15/70 CHA 20 C CHA 30 C CHANGE SIGNS OF COLS ++, ++, ++, ETC. CHA 40 C CHA 50 COMMON /BLOCRC/ NRC,RC(12600) CHA 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCHA 70 1ARGS,VWXYZ(8),NERROR CHA 80 DIMENSION ARGS(100) CHA 90 EQUIVALENCE (ARGS(1),RC(12501)) CHA 100 IF (NARGS) 50,50,10 CHA 110 10 DO 30 I=1,NARGS CHA 120 CALL ADRESS (I,J) CHA 130 IF (J) 40,60,20 CHA 140 20 IF (NERROR.NE.0) RETURN CHA 150 DO 30 N=1,NRMAX CHA 160 JJ=J+N-1 CHA 170 30 RC(JJ)=-RC(JJ) CHA 180 GO TO 70 CHA 190 40 CALL ERROR (3) CHA 200 GO TO 70 CHA 210 50 CALL ERROR (10) CHA 220 GO TO 70 CHA 230 60 CALL ERROR (11) CHA 240 70 RETURN CHA 250 END CHA 260 SUBROUTINE CHKCOL (J) CHK 10 C VERSION 5.00 CHKCOL 5/15/70 CHK 20 COMMON /BLOCRC/ NRC,RC(12600) CHK 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCHK 40 1ARGS,VWXYZ(8),NERROR CHK 50 DIMENSION ARGS(100) CHK 60 EQUIVALENCE (ARGS(1),RC(12501)) CHK 70 C CHK 80 C THIS ROUTINE CHECKS THAT ALL ,NARGS, ARGUMENTS ARE LEGAL CHK 90 C COLUMN NUMBERS AND CONVERTS THEM IN IARGS TO THEIR BEGINNING CHK 100 C ADDRESSES. CHK 110 IF (NARGS.GT.0) GO TO 20 CHK 120 10 J=1 CHK 130 GO TO 40 CHK 140 20 DO 30 I=1,NARGS CHK 150 CALL ADRESS (I,IARGS(I)) CHK 160 IF (IARGS(I).LE.0) GO TO 10 CHK 170 30 CONTINUE CHK 180 J=0 CHK 190 40 RETURN CHK 200 END CHK 210 SUBROUTINE CKIND (J) CKI 10 C VERSION 5.00 CKIND 5/15/70 CKI 20 C CKIND CKI 30 C S PEAVY 5/22/67 CKI 40 C THE FIRST J VALUES OF KIND ARE CHECKED CKI 50 C IF ALL ARE =0 THEN J=0 CKI 60 C IF ALL ARE =1 THEN J=1 CKI 70 C IF SOME ARE 0 AND SOME 1 J=2 CKI 80 COMMON /BLOCRC/ NRC,RC(12600) CKI 90 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCKI 100 1ARGS,VWXYZ(8),NERROR CKI 110 DIMENSION ARGS(100) CKI 120 EQUIVALENCE (ARGS(1),RC(12501)) CKI 130 JA=J CKI 140 J=0 CKI 150 DO 10 I=1,JA CKI 160 IF (KIND(I).NE.0) GO TO 20 CKI 170 10 CONTINUE CKI 180 RETURN CKI 190 20 J=1 CKI 200 DO 30 I=1,JA CKI 210 IF (KIND(I).NE.1) GO TO 40 CKI 220 30 CONTINUE CKI 230 RETURN CKI 240 40 J=2 CKI 250 RETURN CKI 260 END CKI 270 SUBROUTINE CMPARA (X1,X2,X3,Y1,Y2,Y3,X,Y) CMP 10 C VERSION 5.00 CMPARA 5/15/70 CMP 20 C PROGRAM CMPARA WRITTEN BY MRS. CARLA MESSINA NBS-NSRDS JUNE 68CMP 30 C CMPARA IS USED BY THE INSTRUCTION MAXMIN IN PROGRAM CMSEPA CMP 40 A=((Y2-Y3)*(X2-X1)-(Y2-Y1)*(X2-X3))/((X2-X1)*(X2**2-X3**2)-(X2-X3)CMP 50 1*(X2**2-X1**2)) CMP 60 B=((Y2-Y1)-A*(X2**2-X1**2))/(X2-X1) CMP 70 C=-A*X3**2-B*X3+Y3 CMP 80 X=-B/(2.*A) CMP 90 Y=A*X**2+B*X+C CMP 100 RETURN CMP 110 END CMP 120 SUBROUTINE CMSEPA CMS 10 C VERSION 5.00 CMSEPA 5/15/70 CMS 20 COMMON /BLOCRC/ NRC,RC(12600) CMS 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCMS 40 1ARGS,VWXYZ(8),NERROR CMS 50 DIMENSION ARGS(100) CMS 60 EQUIVALENCE (ARGS(1),RC(12501)) CMS 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG CMS 80 COMMON /SCRAT/ NS,NS2,A(13500) CMS 90 C L2=2 SEPARATE FROM COL ++ EVERY ,, ROW START WITH ROW ,, STORE INCMS 100 C L2=3 INSERT IN COL ++ FROM COL ++ AT EVERY ,, ROW STARTING AS ,, CMS 120 C STORE IN COL ++ CMS 130 C L2=4 MAXMIN X IN ++ Y IN ++, XMAX IN ++ YMAX IN ++, XMIN ++ YMIN CMS 140 C PROGRAM CMSEPA WRITTEN BY MRS. CARLA MESSINA NBS-NSRDS JUNE 196CMS 150 GO TO (10,10,30,310), L2 CMS 160 10 NARGS=NARGS+1 CMS 170 J=NARGS CMS 180 DO 20 I=2,NARGS CMS 190 IARGS(J)=IARGS(J-1) CMS 200 KIND(J)=KIND(J-1) CMS 210 20 J=J-1 CMS 220 30 CALL CKIND (J) CMS 230 IF (J) 40,70,40 CMS 240 40 K=3 CMS 250 50 CALL ERROR (K) CMS 260 60 RETURN CMS 270 70 IF (NARGS-5) 80,100,80 CMS 280 80 K=10 CMS 290 IF (L2-2) 90,90,50 CMS 300 90 NARGS=NARGS-1 CMS 310 GO TO 50 CMS 320 100 M=IARGS(3) CMS 330 N=IARGS(4) CMS 340 DO 120 I=3,4 CMS 350 IF (IARGS(I)) 130,130,110 CMS 360 110 IF (IARGS(I)-NROW) 120,120,130 CMS 370 120 IARGS(I)=IARGS(1) CMS 380 CALL CHKCOL (J) CMS 390 IF (J) 40,140,40 CMS 400 130 K=16 CMS 410 GO TO 50 CMS 420 140 IF (NERROR.NE.0) GO TO 60 CMS 430 IF (NRMAX) 150,150,160 CMS 440 150 K=9 CMS 450 GO TO 50 CMS 460 160 DO 170 I=1,NARGS CMS 470 170 IARGS(I)=IARGS(I)-1 CMS 480 L=IARGS(5) CMS 490 IF (L2-2) 180,180,210 CMS 500 C SEPARATE CMS 510 180 DO 190 I=1,NRMAX CMS 520 J=IARGS(1)+I CMS 530 190 A(I)=RC(J) CMS 540 DO 200 K=N,NRMAX,M CMS 550 L=L+1 CMS 560 200 RC(L)=A(K) CMS 570 GO TO 60 CMS 580 C INSERT CMS 590 210 M=M-1 CMS 600 IF (M) 130,130,220 CMS 610 220 N=N-1 CMS 620 IF(N) 130,130,230 CMS 630 230 KA=0 CMS 640 I=IARGS(1) CMS 650 DO 240 K=1,N CMS 660 I=I+1 CMS 670 KA=KA+1 CMS 680 240 A(KA)=RC(I) CMS 690 NN=KA+IARGS(1) CMS 700 MM=IARGS(2) CMS 710 DO 260 K=N,NRMAX,M CMS 720 KA=KA+1 CMS 730 MM=MM+1 CMS 740 A(KA)=RC(MM) CMS 750 DO 250 LL=1,M CMS 760 KA=KA+1 CMS 770 NN=NN+1 CMS 780 250 A(KA)=RC(NN) CMS 790 260 CONTINUE CMS 800 I=(NRMAX-N)/M+1 CMS 810 IF (I+NRMAX-NROW) 270,270,280 CMS 820 270 NRMAX=NRMAX+I CMS 830 GO TO 290 CMS 840 280 NRMAX=NROW CMS 850 CALL ERROR (219) CMS 860 290 DO 300 K=1,NRMAX CMS 870 L=L+1 CMS 880 300 RC(L)=A(K) CMS 890 GO TO 60 CMS 900 310 IF (NARGS-6) 80,320,80 CMS 910 320 CALL CHKCOL (J) CMS 920 IF (J) 40,330,40 CMS 930 330 IF (NERROR.NE.0) GO TO 60 CMS 940 KA=0 CMS 950 IUP=-1 CMS 960 IF (NRMAX) 150,150,340 CMS 970 340 IF (NRMAX-2) 350,350,390 CMS 980 350 IF (KA) 370,370,360 CMS 990 360 CALL ERROR (220) CMS1000 370 IF (IUP) 380,60,60 CMS1010 380 K=219 CMS1020 GO TO 50 CMS1030 390 DO 400 K=1,NRMAX CMS1040 I=IARGS(1)+K-1 CMS1050 J=IARGS(2)+K-1 CMS1060 A(K)=RC(I) CMS1070 K2=K+NRMAX CMS1080 400 A(K2)=RC(J) CMS1090 I1=IARGS(3)-1 CMS1100 J1=IARGS(4)-1 CMS1110 K1=IARGS(5)-1 CMS1120 L1=IARGS(6)-1 CMS1130 IF (NRMAX-4) 410,520,520 CMS1140 410 K2=NRMAX+1 CMS1150 IF (A(K2)-A(K2+1)) 420,380,430 CMS1160 420 IF (A(K2+1)-A(K2+2)) 380,380,440 CMS1170 430 IF (A(K2+1)-A(K2+2)) 450,380,380 CMS1180 440 IUP=IUP+1 CMS1190 450 IUP=IUP+1 CMS1200 IF (A(1)-A(2)) 460,480,460 CMS1210 460 IF (A(1)-A(3)) 470,480,470 CMS1220 470 IF (A(2)-A(3)) 490,480,490 CMS1230 480 KA=1 CMS1240 GO TO 350 CMS1250 490 CALL CMPARA (A(1),A(2),A(3),A(K2),A(K2+1),A(K2+2),X1,Y1) CMS1260 IF (IUP) 500,500,510 CMS1270 500 RC(K1+1)=X1 CMS1280 RC(L1+1)=Y1 CMS1290 GO TO 60 CMS1300 510 RC(I1+1)=X1 CMS1310 RC(L1+1)=Y1 CMS1320 GO TO 60 CMS1330 520 I=NRMAX-2 CMS1340 DO 730 K=1,I CMS1350 IEQUAL=1 CMS1360 K2=K+NRMAX CMS1370 IF (A(K2)-A(K2+1)) 530,610,540 CMS1380 530 IF (A(K2+1)-A(K2+2)) 730,730,550 CMS1390 540 IF (A(K2+1)-A(K2+2)) 560,730,730 CMS1400 550 IUP=1 CMS1410 GO TO 570 CMS1420 560 IUP=0 CMS1430 570 IF (A(K)-A(K+1)) 580,600,580 CMS1440 580 IF (A(K)-A(K+2)) 590,600,590 CMS1450 590 IF (A(K+1)-A(K+2)) 680,600,680 CMS1460 600 KA=KA+1 CMS1470 GO TO 730 CMS1480 610 IF (K-1) 730,730,620 CMS1490 620 IEQUAL=2 CMS1500 IF (A(K-1)-A(K)) 630,600,630 CMS1510 630 IF (A(K-1)-A(K+1)) 640,600,640 CMS1520 640 IF (A(K-1)-A(K+2)) 650,600,650 CMS1530 650 IF (A(K2-1)-A(K2)) 660,730,670 CMS1540 660 IF (A(K2+1)-A(K2+2)) 730,730,550 CMS1550 670 IF (A(K2+1)-A(K2+2)) 560,730,730 CMS1560 680 CALL CMPARA (A(K),A(K+1),A(K+2),A(K2),A(K2+1),A(K2+2),X1,Y1) CMS1570 IF (IEQUAL-2) 700,690,690 CMS1580 690 CALL CMPARA (A(K-1),A(K),A(K+1),A(K2-1),A(K2),A(K2+1),X2,Y2) CMS1590 X1=0.5*(X1+X2) CMS1600 Y1=0.5*(Y1+Y2) CMS1610 700 IF (IUP) 710,710,720 CMS1620 710 IUP=0 CMS1630 K1=K1+1 CMS1640 L1=L1+1 CMS1650 RC(K1)=X1 CMS1660 RC(L1)=Y1 CMS1670 GO TO 730 CMS1680 720 I1=I1+1 CMS1690 J1=J1+1 CMS1700 RC(I1)=X1 CMS1710 RC(J1)=Y1 CMS1720 730 CONTINUE CMS1730 GO TO 350 CMS1740 END CMS1750 SUBROUTINE COALES COA 10 C VERSION 5.00 COALES 5/15/70 COA 20 C ACOALESCE AND AAVERAGE COMMANDS COA 30 C WRITTEN BY R. MCCLENON, NSRDS-NBS, NOV. 1969 COA 40 C L1 = ACOALESCE L2 = AVERAGE COA 50 C COMMAND FORM IS -- COA 60 C ACOALESCE MATRIX STARTING IN R++ C++ COA 70 C ACOALESCE ON FIRST COL OF ARRAY IN ,, ++ R=,, C=,, START STORING COA 80 C IN ,, ++ COA 90 C AAVERAGE ON FIRST COL OF ARRAY IN ,, ++ R=,, C=,, START STORING COA 100 C IN ,, ++ COA 110 C OR COA 120 C ACOALESCE ON ** IN FIRST COL OF ,, ++ R=,, C=,, START STORING COA 130 C IN ,, ++ COA 140 C AAVERAGE ON ** IN FIRST COL OF ,, ++ R=,, C=,, START STORING COA 150 C IN ,, ++ COA 160 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG COA 170 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCOA 180 1ARGS,VWXYZ(8),NERROR COA 190 COMMON /SCRAT/ NS,NS2,A(13500) COA 200 COMMON /BLOCRC/ NRC,RC(12600) COA 210 DIMENSION ARGS(100) COA 220 EQUIVALENCE (ARGS(1),RC(12501)) COA 230 L2=L2-8 COA 240 IF (NARGS-6) 410,10,20 COA 250 10 KL=1 COA 260 I=6 COA 270 CALL CKIND(I) COA 280 IF (I-1) 60,420,420 COA 290 20 KL=2 COA 300 DO 30 J=2,7 COA 310 IF (KIND(J)) 420,30,420 COA 320 30 CONTINUE COA 330 IF (NARGS-8) 40,410,410 COA 340 40 IF (KIND(1)) 420,420,50 COA 350 50 Y=ARGS(1) COA 360 60 KL5=KL+5 COA 370 DO 70 J=KL,KL5 COA 380 IF (IARGS(J)) 430,430,70 COA 390 70 CONTINUE COA 400 LROW=IARGS(KL+2) COA 410 LCOL=IARGS(KL+3) COA 420 KROW=IARGS(KL) COA 430 KCOL=IARGS(KL+1) COA 440 IF (KROW+LROW-NROW-1) 80,80,440 COA 450 80 IF (KCOL+LCOL-NCOL-1) 90,90,440 COA 460 90 MROW=IARGS(KL+4) COA 470 MCOL=IARGS(KL+5) COA 480 IF (MROW+LROW-NROW-1) 100,100,440 COA 490 100 IF (MCOL+LCOL-NCOL-1) 110,110,440 COA 500 110 IF (NERROR) 400,120,400 COA 510 120 KRR=KROW+LROW-1 COA 520 KCC=KCOL+LCOL-1 COA 530 MRR=MROW+LROW-1 COA 540 MCC=MCOL+LCOL-1 COA 550 N=0 COA 560 IF (KL-1) 230,230,130 COA 570 130 DO 140 J=2,LCOL COA 580 140 A(J)=0.0 COA 590 A(1)=Y COA 600 DO 170 J=1,LROW COA 610 I=KROW+J-1 COA 620 II=NROW*(KCOL-1)+I COA 630 IF (RC(II)-Y) 170,150,170 COA 640 150 DO 160 JJ=2,LCOL COA 650 I=II+(JJ-1)*NROW COA 660 160 A(JJ)=A(JJ)+RC(I) COA 670 N=N+1 COA 680 170 CONTINUE COA 690 IF (N) 460,460,180 COA 700 180 M=1 COA 710 GO TO (190,200), L2 COA 720 190 DIV=1.0 COA 730 GO TO 210 COA 740 200 DIV=N COA 750 210 DO 220 JJ=2,LCOL COA 760 220 A(JJ)=A(JJ)/DIV COA 770 GO TO 380 COA 780 230 MAT=LCOL*LROW COA 790 IF (MAT-NS+LROW) 240,240,450 COA 800 240 M1=MAT+1 COA 810 M2=MAT+LROW COA 820 DO 250 J=M1,M2 COA 830 250 A(J)=0. COA 840 M=0 COA 850 DO 370 J=1,LROW COA 860 M1=MAT+J COA 870 IF (A(M1)) 370,260,370 COA 880 260 K1=LCOL*M+1 COA 890 K2=LCOL*(M+1) COA 900 DO 270 K=K1,K2 COA 910 270 A(K)=0.0 COA 920 N=0 COA 930 L=NROW*(KCOL-1)+J COA 940 Y=RC(L) COA 950 A(K1)=Y COA 960 DO 300 JJ=J,LROW COA 970 II=NROW*(KCOL-1)+KROW+JJ-1 COA 980 IF (RC(II)-Y) 300,280,300 COA 990 280 K3=K1+1 COA1000 M1=MAT+JJ COA1010 A(M1)=1.0 COA1020 DO 290 K=K3,K2 COA1030 I=II+(K-K1)*NROW COA1040 290 A(K)=A(K)+RC(I) COA1050 N=N+1 COA1060 300 CONTINUE COA1070 IF (N) 370,370,310 COA1080 310 M=M+1 COA1090 320 GO TO (330,340), L2 COA1100 330 DIV=1.0 COA1110 GO TO 350 COA1120 340 DIV=N COA1130 350 DO 360 K=K3,K2 COA1140 360 A(K)=A(K)/DIV COA1150 370 CONTINUE COA1160 380 DO 390 J=1,M COA1170 DO 390 JJ=1,LCOL COA1180 I=LCOL*(J-1)+JJ COA1190 II=NROW*(MCOL-2+JJ)+J+MROW-1 COA1200 RC(II)=A(I) COA1210 390 CONTINUE COA1220 400 RETURN COA1230 410 CALL ERROR (10) COA1240 GO TO 400 COA1250 420 CALL ERROR (20) COA1260 GO TO 400 COA1270 430 CALL ERROR (11) COA1280 GO TO 400 COA1290 440 CALL ERROR (17) COA1300 GO TO 400 COA1310 450 CALL ERROR (23) COA1320 GO TO 400 COA1330 460 CALL ERROR (203) COA1340 M=1 COA1350 GO TO 380 COA1360 END COA1370 FUNCTION COMELL (Z,I) COM 10 C VERSION 5.00 COMELL 5/15/70 COM 20 C COMPLETE ELLIPTIC INTEGRALS - FIRST AND SECOND KIND COM 30 DOUBLE PRECISION Z,X,A,B,C,D,E,P,Q COM 40 DOUBLE PRECISION FDLOG,FDSQRT,COMELL COM 50 X=Z COM 60 IF (DABS(Z).LT.1.D0) GO TO 10 COM 70 IF(DABS(Z).EQ.1.D0.AND.I.EQ.2) GO TO 10 COM 80 CALL ERROR (109) COM 83 Z=0.0D0 COM 85 RETURN COM 90 10 A=X COM 100 B=FDSQRT(1.D0-A) COM 110 IF (X.GT..996D0) GO TO 50 COM 120 B=(1.D0-B)/(1.D0+B) COM 130 A=B**2 COM 140 B=1.D0+B COM 150 C=1.D0 COM 160 D=C COM 170 E=2.D0 COM 180 IF (I.EQ.1) GO TO 20 COM 190 B=1.D0/B COM 200 D=-1.D0 COM 210 20 P=A COM 220 DO 30 N=1,90 COM 230 C=C+P*(D/E)**2 COM 240 P=P*A*(D/E)**2 COM 250 IF (P.LT..1D-9) GO TO 40 COM 260 D=D+2.D0 COM 270 30 E=E+2.D0 COM 280 40 A=B*C*1.570796326D0 COM 290 GO TO 70 COM 300 50 A=FDLOG(4.0D0/B) COM 310 Q=B**2 COM 320 IF (I.GT.1) GO TO 60 COM 330 B=.25D0*(A-1.D0) COM 340 C=.140625D0*(A-1.666666666D0) COM 350 D=9.765625D-2*(A-1.233333333D0) COM 360 E=1255.D0*(A-1.27904761904D0)/16348.D0 COM 370 A=A+Q*(B+Q*(C+Q*(D+Q*E))) COM 380 GO TO 70 COM 390 60 B=.5D0*(A-.5D0) COM 400 C=.1875D0*(A-1.083333333D0) COM 410 D=.11717875D0*(A-1.2D0) COM 420 E=175.D0*(A-1.251190476D0)/2048.D0 COM 430 A=1.+Q*(B+Q*(C+Q*(D+Q*E))) COM 440 70 COMELL=A COM 450 RETURN COM 460 C COM 470 END COM 490 SUBROUTINE COMPLX COX 10 C VERSION 5.00 COMPLX 5/15/70 COX 20 C ***** COMMON ***** COX 30 COMMON /BLOCRC/ NRC,RC(12600) COX 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCOX 50 1ARGS,VWXYZ(8),NERROR COX 60 DIMENSION ARGS(100) COX 70 EQUIVALENCE (ARGS(1),RC(12501)) COX 80 COMMON /SCRAT/ NS,NS2,A(13500) COX 90 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG COX 100 COMMON /CONSTS/ PI,E,HALFPI,DEG,RAD,XALOG COX 110 C ***** COX 120 DIMENSION KK(6) COX 130 EQUIVALENCE (I1,IARGS(1)), (I2,IARGS(2)), (I3,IARGS(3)), (I4,IARGSCOX 140 1(4)), (I5,IARGS(5)), (I6,IARGS(6)) COX 150 DOUBLE PRECISION D(5),X,Y,FDCOS,FDSIN,FDSQRT COX 160 C ***** COX 170 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/24/70. COX 180 C CADD (E), (E), TO (E),(E) AND PUT IN COLUMNS (C),(C) COX 190 C CSUBTRACT (E),(E), FROM (E),(E) AND PUT IN COLUMNS (C),(C) COX 200 C CMULTIPLY (E),(E) BY (E),(E) AND PUT IN COLUMNS (C),(C) COX 210 C CDIVIDE (E),(E) BY (E),(E) AND PUT IN COLUMNS (C),(C) COX 220 C CRECTANGULAR R IN (E) THETA IN (E), PUT X IN COL (C), Y IN COL (C)COX 230 C CPOLAR OF X IN (E) Y IN (E) PUT R IN COL (C) THETA IN COL (C) COX 240 C COX 250 C FIRST ARGUMENT OF EACH PAIR IS REAL, SECOND IS IMAGINARY COX 260 C COX 270 C VALUES OF L2 ARE *** COX 280 C 1=CADD, 2=CSUB, 3=CMULT, 4=CDIV, 5=CRECTAN, 6CPOLAR COX 290 C COX 300 C NARGS = 6 FOR ADD,SUB,MULT,DIV COX 310 C NARGS = 4 FOR CRECTANGULAR AND CPOLAR COX 320 C ***** COX 330 C ERROR CHECKING COX 340 10 IF (NARGS.NE.6.AND.L2.LT.5) CALL ERROR (10) COX 350 IF (NARGS.NE.4.AND.L2.GT.4) CALL ERROR (10) COX 360 IF (KIND(NARGS).NE.0.AND.KIND(NARGS-1).NE.0) CALL ERROR (20) COX 370 IF (NRMAX.EQ.0) CALL ERROR (9) COX 380 DO 30 I=1,NARGS COX 390 KK(I)=1 COX 400 CALL ADRESS (I,IARGS(I)) COX 410 IF (IARGS(I)) 20,40,30 COX 420 20 KK(I)=0 COX 430 IARGS(I)=-IARGS(I) COX 440 30 CONTINUE COX 450 GO TO 50 COX 460 40 CALL ERROR (11) COX 470 50 IF (NERROR.NE.0) RETURN COX 480 JJ=IARGS(NARGS)+NRMAX-1 COX 490 IF (L2.GT.4) GO TO 140 COX 500 DO 130 I=I6,JJ COX 510 DO 60 J=1,4 COX 520 MM=IARGS(J) COX 530 60 D(J)=RC(MM) COX 540 GO TO (70,80,90,100), L2 COX 550 C CADD COX 560 70 X=D(1)+D(3) COX 570 Y=D(2)+D(4) COX 580 GO TO 120 COX 590 C CSUBTRACT COX 600 80 X=D(3)-D(1) COX 610 Y=D(4)-D(2) COX 620 GO TO 120 COX 630 C CMULTIPLY COX 640 90 X=D(1)*D(3)-D(2)*D(4) COX 650 Y=D(1)*D(4)+D(3)*D(2) COX 660 GO TO 120 COX 670 C CDIVIDE COX 680 C ZERO RETURNED IF DIVISION BY ZERO, DIAGNOSTIC GIVEN. ERROR(104). COX 690 100 D(5)=D(3)**2+D(4)**2 COX 700 IF (D(5).GT.0.) GO TO 110 COX 710 CALL ERROR(106) COX 720 X=0.0D0 COX 730 Y=0.0D0 COX 740 GO TO 120 COX 750 110 X=(D(1)*D(3)+D(2)*D(4))/D(5) COX 760 Y=(D(3)*D(2)-D(1)*D(4))/D(5) COX 770 120 RC(I5)=FDPCON(X) COX 780 RC(I)=FDPCON(Y) COX 790 I1=I1+KK(1) COX 800 I2=I2+KK(2) COX 810 I3=I3+KK(3) COX 820 I4=I4+KK(4) COX 830 130 I5=I5+KK(5) COX 840 RETURN COX 850 C CRECTANGULAR AND CPOLAR COX 860 140 MM=L2-4 COX 870 DO 260 I=I4,JJ COX 880 D(1)=RC(I1) COX 890 D(2)=RC(I2) COX 900 GO TO (150,190), MM COX 910 C CRECTANGULAR - R,THETA TO X,Y COX 920 150 IF (RC(I1)) 180,160,180 COX 930 160 X=0.0D0 COX 940 170 Y=0.0D0 COX 950 GO TO 250 COX 960 180 X=D(1)*FDCOS(D(2)) COX 970 Y=D(1)*FDSIN(D(2)) COX 980 GO TO 250 COX 990 C CPOLAR X,Y TO R,THETA COX1000 190 IF (RC(I2)) 220,200,220 COX1010 200 IF (RC(I1)) 210,160,210 COX1020 C Y=0, X NE 0 COX1030 210 X=DABS(D(1)) COX1040 GO TO 170 COX1050 220 IF (RC(I1)) 240,230,240 COX1060 C X=0, Y NE 0 COX1070 230 X=DABS(D(2)) COX1080 C IF X=0.0, THEN THETA=HALFPI*SIGN(Y) COX1090 Y=SIGN(HALFPI,RC(I2)) COX1100 GO TO 250 COX1110 240 X=FDSQRT(D(1)**2+D(2)**2) COX1120 Y=DATAN2(D(2),D(1)) COX1130 250 RC(I3)=FDPCON(X) COX1140 RC(I)=FDPCON(Y) COX1150 I1=I1+KK(1) COX1160 I2=I2+KK(2) COX1170 260 I3=I3+KK(3) COX1180 RETURN COX1190 END COX1200 SUBROUTINE CORREL COR 10 C VERSION 5.00 CORREL 5/15/70 COR 20 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NCOR 30 1ARGS,VWXYZ(8),NERROR COR 40 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG COR 50 COMMON /BLOCRC/ NRC,RC(12600) COR 60 DIMENSION ARGS(100) COR 70 EQUIVALENCE (ARGS(1),RC(12501)) COR 80 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH COR 90 COMMON /SCRAT/ NS,NS2,A(13500) COR 100 DIMENSION ERR(3), AVG(100), SD(100), T(100) COR 110 EQUIVALENCE (A(13301),AVG(1)), (A(13401),SD(1),T(1)) COR 120 L2=L2-10 COR 122 IF (L2.EQ.1.OR.NARGS.NE.IARGS(1) +1) GO TO 10 COR 124 CALL ERROR (233) COR 126 RETURN COR 128 10 MVAR=99 COR 130 IF (NARGS.LT.3) CALL ERROR (10) COR 140 NVAR=IARGS(1) COR 150 IF (NVAR.LT.2.OR.NVAR.GT.MVAR) CALL ERROR (3) COR 160 KEEP=(NARGS-NVAR+1)/2 COR 170 IF (KEEP.LT.1.OR.KEEP.GT.3.OR.MOD(NARGS-NVAR,2).EQ.0) CALL ERROR (COR 180 110) COR 190 GO TO (40,30,20), KEEP COR 200 20 K2=IARGS(NVAR+4) COR 210 IF (K2.LT.1.OR.K2.GT.NROW) CALL ERROR (16) COR 220 IARGS(NVAR+4)=1 COR 230 30 K1=IARGS(NVAR+2) COR 240 IF (K1.LT.1.OR.K1.GT.NROW) CALL ERROR (16) COR 250 IARGS(NVAR+2)=1 COR 260 40 CALL CHKCOL (J) COR 270 IF (J.EQ.0) GO TO 50 COR 280 CALL ERROR (11) COR 290 RETURN COR 300 50 GO TO (80,70,60), KEEP COR 310 60 IARGS(NVAR+4)=IARGS(NVAR+5)+K2-1 COR 320 70 IARGS(NVAR+2)=IARGS(NVAR+3)+K1-1 COR 330 80 LOTTE=NVAR*NVAR COR 340 KURT=2*LOTTE COR 350 C LOT IS SPACE IN ARRAY A RESERVED FOR RANKED DATA COR 360 LOT=MAX0(NRMAX*(NVAR+1),3*LOTTE+8*NVAR+8,4*LOTTE) COR 370 IF (NRMAX.LT.3) CALL ERROR (9) COR 380 IF (NRMAX*NVAR.GT.NRC) CALL ERROR (15) COR 390 IF (MAX0(LOT+LOTTE+100,NRMAX*4+3*LOTTE).GT.NS) CALL ERROR (23) COR 400 IF (NERROR.NE.0) RETURN COR 410 NVA=NVAR-1 COR 420 IF (L2.EQ.2) GO TO 130 COR 430 C RANKS OF OBSERVATIONS COR 440 IND=NVAR*NRMAX+1 COR 450 DO 90 I=1,NVAR COR 460 K1=(I-1)*NRMAX+1 COR 470 K2=IARGS(I+1) COR 480 90 CALL RANKX (NRMAX,RC(K2),A(IND),A(K1),T(I)) COR 490 C SPEARMAN RANK CORRELATION COEFFICIENT COR 500 F=((NRMAX-1)*NRMAX*(NRMAX+1))/6 COR 510 I1=LOT+LOTTE COR 520 A(I1)=1. COR 530 DO 120 J=1,NVA COR 540 IND=(J-1)*NVAR+LOT COR 550 I1=IND+J COR 560 A(I1)=1. COR 570 IJ=J+1 COR 580 DO 120 I=IJ,NVAR COR 590 I1=IND+I COR 600 I2=(I-1)*NVAR+J+LOT COR 610 K1=2.*T(I)+0.4 COR 620 K2=2.*T(J)+0.4 COR 630 IF (IFIX(F)-K1.GT.0.AND.IFIX(F)-K2.GT.0) GO TO 100 COR 640 A(I1)=0. COR 650 GO TO 120 COR 660 100 D=0. COR 670 DO 110 K=1,NRMAX COR 680 K1=(I-1)*NRMAX+K COR 690 K2=(J-1)*NRMAX+K COR 700 110 D=D+(A(K1)-A(K2))*(A(K1)-A(K2)) COR 710 A(I1)=(F-D-T(I)-T(J))/(FSQRT(F-2.*T(I))*FSQRT(F-2.*T(J))) COR 720 IF (ABS(A(I1)).GT.1.) A(I1)=AINT(A(I1)) COR 730 120 A(I2)=A(I1) COR 740 C MEANS OF OBSERVATIONS COR 750 130 DO 150 I=1,NVAR COR 760 AVG(I)=0. COR 770 SUMPOS=0. COR 780 SUMNEG=0. COR 790 DO 140 J=1,NRMAX COR 800 I1=IARGS(I+1)-1+J COR 810 SUMPOS=SUMPOS+AMAX1(RC(I1),0.) COR 820 140 SUMNEG=SUMNEG+AMAX1(-RC(I1),0.) COR 830 150 AVG(I)=(SUMPOS-SUMNEG)/FLOAT(NRMAX) COR 840 C STANDARD DEVIATION COR 850 DO 170 I=1,NVAR COR 860 SD(I)=0. COR 870 DO 160 J=1,NRMAX COR 880 I1=IARGS(I+1)-1+J COR 890 160 SD(I)=SD(I)+(RC(I1)-AVG(I))*(RC(I1)-AVG(I)) COR 900 170 SD(I)=FSQRT(SD(I)) COR 910 C SIMPLE CORRELATION COEFFICIENT COR 920 A(LOTTE)=1. COR 930 Z=FLOAT(NRMAX-2) COR 940 DO 200 J=1,NVA COR 950 IND=(J-1)*NVAR COR 960 I1=IND+J COR 970 A(I1)=1. COR 980 IJ=J+1 COR 990 DO 200 I=IJ,NVAR COR1000 I1=IND+I COR1010 I2=(I-1)*NVAR+J COR1020 IF (SD(I).GT.0..AND.SD(J).GT.0.) GO TO 180 COR1030 A(I1)=0. COR1040 GO TO 200 COR1050 180 SUMPOS=0. COR1060 SUMNEG=0. COR1070 DO 190 K=1,NRMAX COR1080 K1=IARGS(I+1)-1+K COR1090 K2=IARGS(J+1)-1+K COR1100 CP=(RC(K1)-AVG(I))*(RC(K2)-AVG(J)) COR1110 SUMPOS=SUMPOS+AMAX1(CP,0.) COR1120 190 SUMNEG=SUMNEG+AMAX1(-CP,0.) COR1130 A(I1)=(SUMPOS-SUMNEG)/(SD(I)*SD(J)) COR1140 IF (ABS(A(I1)).GT.1.) A(I1)=AINT(A(I1)) COR1150 200 A(I2)=A(I1) COR1160 IF (NVAR.LE.2) GO TO 210 COR1170 C PARTIAL CORRELATION COEFFICIENT COR1180 CALL INVCOR (A(1),NVAR,NVAR,A(LOTTE+1),NVAR+2,A(1),1,ERR,IND) COR1190 IF (IND.EQ.0) GO TO 220 COR1200 WRITE (IPRINT,480) COR1210 210 KEEP=MIN0(KEEP,2) COR1220 A(LOTTE+1)=0. COR1230 IF (L2.EQ.1) GO TO 300 COR1240 GO TO 420 COR1250 220 DO 230 J=2,NVAR COR1260 K1=2*(J-1) COR1270 K2=LOTTE+(J-1)*NVAR COR1280 DO 230 I=1,NVAR COR1290 I1=K2+I COR1300 I2=I1+K1 COR1310 230 A(I1)=A(I2) COR1320 DO 240 J=1,NVA COR1330 IND=LOTTE+(J-1)*NVAR COR1340 K1=IND+J COR1350 IJ=J+1 COR1360 DO 240 I=IJ,NVAR COR1370 K2=LOTTE+(I-1)*NVAR+I COR1380 I1=IND+I COR1390 I2=LOTTE+(I-1)*NVAR+J COR1400 A(I1)=-A(I1)/(FSQRT(A(K1))*FSQRT(A(K2))) COR1410 IF (ABS(A(I1)).GT.1.) A(I1)=AINT(A(I1)) COR1420 240 A(I2)=A(I1) COR1430 DO 250 I=1,NVAR COR1440 I1=LOTTE+(I-1)*NVAR+I COR1450 250 A(I1)=1. COR1460 IF (L2.EQ.2) GO TO 420 COR1470 IF (NRMAX.LE.NVAR) GO TO 300 COR1480 C SIGNIFICANCE LEVEL OF PARTIAL CORRELATION COEFFICIENT COR1490 Z=FLOAT(NRMAX-NVAR) COR1500 DO 290 J=1,NVAR COR1510 IJ=(J-1)*NVAR+LOTTE COR1520 IND=IJ+KURT COR1530 DO 290 I=J,NVAR COR1540 I1=IND+I COR1550 I2=(I-1)*NVAR+J+3*LOTTE COR1560 K1=IJ+I COR1570 IF (A(K1)) 270,260,270 COR1580 260 A(I1)=1. COR1590 GO TO 290 COR1600 270 IF (ABS(A(K1)).LT.1.) GO TO 280 COR1610 A(I1)=0. COR1620 GO TO 290 COR1630 280 F=A(K1)*A(K1) COR1640 F=Z*F/(1.-F) COR1650 CALL PROB (1.,Z,F,A(I1)) COR1660 290 A(I2)=A(I1) COR1670 300 Z=FLOAT(NRMAX-2) COR1680 DO 340 J=1,NVAR COR1690 IJ=(J-1)*NVAR COR1700 IND=IJ+KURT COR1710 DO 340 I=J,NVAR COR1720 I1=IND+I COR1730 I2=(I-1)*NVAR+J+KURT COR1740 K1=IJ+I COR1750 IF (A(K1)) 320,310,320 COR1760 310 A(I1)=1. COR1770 GO TO 340 COR1780 320 IF (ABS(A(K1)).LT.1.) GO TO 330 COR1790 A(I1)=0. COR1800 GO TO 340 COR1810 330 F=A(K1)*A(K1) COR1820 F=Z*F/(1.-F) COR1830 CALL PROB (1.,Z,F,A(I1)) COR1840 340 A(I2)=A(I1) COR1850 C FIRST PRINTING STAGE (SCC,PCC,SIGNIFICANCE LEVELS, SRCC) COR1860 NLA=1 COR1870 CALL PAGE (4) COR1880 WRITE (IPRINT,490) NVAR,NRMAX COR1890 CALL MIST (NVAR,A(1),1,NLA,1) COR1900 CALL MIST (NVAR,A(KURT+1),1,NLA,2) COR1910 IF (A(LOTTE+1).LE.0.) GO TO 350 COR1920 CALL MIST (NVAR,A(LOTTE+1),1,NLA,3) COR1930 F=ABS(AMAX1(ERR(1),ERR(2),ERR(3))) COR1940 C FOLLOWING STATEMENT WILL BE RESTORED LATER COR1950 C WRITE (IPRINT, 45) F COR1960 C 45 FORMAT (/1H , 72HERROR BOUND FOR INVERSION OF MATRIX OF SIMPLE COR1970 C 1RELATION COEFFICIENTS =, E14.4) COR1980 NLA=NLA+2 COR1990 IF (NRMAX.LE.NVAR) GO TO 350 COR2000 CALL MIST (NVAR,A(3*LOTTE+1),1,NLA,4) COR2010 350 CALL MIST (NVAR,A(LOT+1),1,NLA,5) COR2020 IF (NRMAX.GT.3) GO TO 360 COR2030 WRITE (IPRINT,500) NRMAX COR2040 GO TO 420 COR2050 360 Z=FLOAT(NRMAX-3) COR2060 IND=3*LOTTE+NRMAX+1 COR2070 DO 400 J=1,NVAR COR2080 I1=IARGS(J+1) COR2090 IJ=(J-1)*NVAR COR2100 DO 400 I=1,NVAR COR2110 IF (I.NE.J) GO TO 370 COR2120 I2=KURT+IJ+J COR2130 A(I2)=1. COR2140 GO TO 400 COR2150 370 I2=IARGS(I+1)-1 COR2160 DO 380 K=1,NRMAX COR2170 K1=K+I2 COR2180 K2=K+3*LOTTE COR2190 380 A(K2)=RC(K1) COR2200 I2=KURT+IJ+I COR2210 CALL BJORCK (RC(I1),A(3*LOTTE+1),NRMAX,A(IND),F) COR2220 IF (F.GT.0.) GO TO 390 COR2230 A(I2)=1. COR2240 GO TO 400 COR2250 390 CALL PROB (1.,Z,F,A(I2)) COR2260 400 CONTINUE COR2270 CALL MIST (NVAR,A(KURT+1),0,NLA,6) COR2280 C CONFIDENCE LIMITS FOR SIMPLE CORRELATION COEFFICIENT COR2290 F=FSQRT(FLOAT(NRMAX-3)) COR2300 HL1=2.5758293/F COR2310 HL2=1.9599640/F COR2320 A(3*LOTTE)=99. COR2330 A(5*LOTTE)=95. COR2340 DO 410 J=1,NVA COR2350 IND=(J-1)*NVAR COR2360 K1=IND+J+KURT COR2370 K2=K1+KURT COR2380 A(K1)=99. COR2390 A(K2)=95. COR2400 IJ=J+1 COR2410 DO 410 I=IJ,NVAR COR2420 C INDEX OF SCC COR2430 I1=IND+I COR2440 C INDICES OF UPPER,LOWER SCC CONFIDENCE LIMITS (99 PER CENT LEVEL) COR2450 K1=(I-1)*NVAR+J+KURT COR2460 K2=K1+KURT COR2470 Z=.5*FLOG((1.+A(I1))/(1.-A(I1))) COR2480 A(K1)=AMIN1(FTANH(Z+HL1),1.) COR2490 A(K2)=AMAX1(FTANH(Z-HL1),-1.) COR2500 C INDICES OF UPPER, LOWER SCC CONFIDENCE LIMTS (95 PER CENT LEVEL) COR2510 K1=I1+KURT COR2520 K2=K1+KURT COR2530 A(K1)=AMIN1(FTANH(Z+HL2),1.) COR2540 410 A(K2)=AMAX1(FTANH(Z-HL2),-1.) COR2550 CALL MIST (NVAR,A(KURT+1),0,NLA,7) COR2560 420 GO TO (470,450,430), KEEP COR2570 C STORE SIMPLE AND PARTIAL CORRELATION COEFFICIENTS IN WORKSHEET COR2580 430 I1=MIN0(NVAR,NCOL-(IARGS(NVAR+5)-1)/NROW) COR2590 I2=MIN0(NVAR,NROW-(IARGS(NVAR+4)-IARGS(NVAR+5))) COR2600 IF (I1.LT.NVAR.OR.I2.LT.NVAR) CALL ERROR (213) COR2610 DO 440 J=1,I1 COR2620 DO 440 I=1,I2 COR2630 K1=(J-1)*NVAR+I+LOTTE COR2640 K2=IARGS(NVAR+4)-1+(J-1)*NROW+I COR2650 440 RC(K2)=A(K1) COR2660 450 I1=MIN0(NVAR,NCOL-(IARGS(NVAR+3)-1)/NROW) COR2670 I2=MIN0(NVAR,NROW-(IARGS(NVAR+2)-IARGS(NVAR+3))) COR2680 IF (I1.LT.NVAR.OR.I2.LT.NVAR) CALL ERROR (213) COR2690 DO 460 J=1,I1 COR2700 DO 460 I=1,I2 COR2710 K1=(J-1)*NVAR+I COR2720 K2=IARGS(NVAR+2)-1+(J-1)*NROW+I COR2730 460 RC(K2)=A(K1) COR2740 470 RETURN COR2750 C COR2760 480 FORMAT (1H ,32X,54HMATRIX IS SINGULAR. NO PARTIAL CORRELATIONS COCOR2770 1MPUTED.) COR2780 490 FORMAT (/30X,24HCORRELATION ANALYSIS FOR,I3,15H VARIABLES WITH,I5,COR2790 113H OBSERVATIONS) COR2800 500 FORMAT (1H ,18X,83HNONLINEARITY TEST AND APPROXIMATION OF CONFIDENCOR2810 1CE INTERVALS NOT DEFINED FOR NRMAX =,I2) COR2820 END COR2830 SUBROUTINE CSPINV (A,M,KK,ISIG) CSP 10 C VERSION 5.00 CSPINV 5/15/70 CSP 20 C 7058MI MATRIX INVERSION WITH MINIMUM ROUNDOFF ERROR ACCUMULATION.CSP 30 COMMON/CONLB2/ER,ISIGD CSP 35 DIMENSION A(1) CSP 40 DATA ONE/1.0/,ZERO/0.0/ CSP 50 ISIG=0 CSP 60 N=M CSP 70 NN=KK CSP 80 N2=N+N CSP 90 DO 30 J=1,N CSP 100 NJCOL=(N+J-1)*NN CSP 110 DO 30 I=1,N CSP 120 KINJ=NJCOL+I CSP 130 IF (I-J) 10,20,10 CSP 140 10 A(KINJ)=ZERO CSP 150 GO TO 30 CSP 160 20 A(KINJ)=ONE CSP 170 30 CONTINUE CSP 180 C DETERMINE MAXIMUM ABS OF VARIABLE BEING ELIMINATED. THIS BECOMES CSP 190 L=0 CSP 200 40 L=L+1 CSP 210 LCOL=NN*L-NN CSP 220 KLL=LCOL+L CSP 230 IF (L-N) 50,100,200 CSP 240 C FIND THE LARGEST ELMENT IN THE LTH COLUMN. CSP 250 50 J1=L CSP 260 C=ABS(A(KLL)) CSP 270 L1=L+1 CSP 280 DO 70 I=L1,N CSP 290 KIL=LCOL+I CSP 300 X=ABS(A(KIL)) CSP 310 IF (C-X) 60,70,70 CSP 320 C RECORD THE NUMBER OF THE ROW HAVING THE GREATER ELEMENT. CSP 330 60 J1=I CSP 340 C C BECOMES THE GREATER. CSP 350 C=X CSP 360 70 CONTINUE CSP 370 C INTERCHANGE ROW J1 WITH ROW L. J1 IS THE ROW WITH THE LARGEST ELEMCSP 380 C TEST TO SEE IF INTERCHANGING IS NECESSARY. CSP 390 IF (J1-L) 80,100,80 CSP 400 80 DO 90 J=L,N2 CSP 410 JCOL=NN*J-NN CSP 420 KJIJ=JCOL+J1 CSP 430 HOLD=A(KJIJ) CSP 440 KLJ=JCOL+L CSP 450 A(KJIJ)=A(KLJ) CSP 460 A(KLJ)=HOLD CSP 470 90 CONTINUE CSP 480 C IF THE LARGEST ABSOLUTE ELEMENT IN A COLUMN IS MACHINE ZERO WE CSP 490 C HAVE A SINGULAR MATRIX CSP 495 100 IF (ABS(A(KLL))-ER) 110,110,120 CSP 500 110 ISIG=4 CSP 510 GO TO 200 CSP 520 C ZERO ALL THE ELEMENTS IN THE LTH COLUMN BUT THE PIVOTAL ELEMENT. CSP 530 120 L1=1 CSP 540 L2=L-1 CSP 550 IF (L2) 130,130,150 CSP 560 130 IF (L-N) 140,170,140 CSP 570 140 L1=L+1 CSP 580 L2=N CSP 590 150 DO 160 I=L1,L2 CSP 600 KIL=LCOL+I CSP 610 Z=-A(KIL)/A(KLL) CSP 620 DO 160 J=L,N2 CSP 630 JCOL=NN*J-NN CSP 640 KIJ=JCOL+I CSP 650 KLJ=JCOL+L CSP 660 160 A(KIJ)=A(KIJ)+Z*A(KLJ) CSP 670 IF (N-L2) 40,40,130 CSP 680 C DIVIDE BY DIAGONAL ELEMENTS. CSP 690 170 DO 180 I=1,N CSP 700 KKK=NN*I-NN+I CSP 710 ZZ=A(KKK) CSP 720 DO 180 J=1,N2 CSP 730 KKI=NN*J-NN+I CSP 740 180 A(KKI)=A(KKI)/ZZ CSP 750 C RETURN AFTER PUTTING A INVERSE INTO B CSP 760 DO 190 J=1,N CSP 770 JCOL=NN*J-NN CSP 780 NJCOL=NN*N+JCOL CSP 790 DO 190 I=1,N CSP 800 KIJ=JCOL+I CSP 810 KINJ=NJCOL+I CSP 820 190 A(KIJ)=A(KINJ) CSP 830 200 RETURN CSP 840 END CSP 850 FUNCTION DBEJ (X,N,M) DBE 10 C VERSION 5.00 DBEJ 5/15/70 DBE 20 DOUBLE PRECISION DBEJ,E,H,X,A,B,C,D,Y,S(120),T(120) DBE 30 DOUBLE PRECISION FDSIN,FDCOS,FDLOG,FDSQRT,FDEXP DBE 40 COMMON /SCRAT/ NS,NS2,SCRAT(13500) DBE 50 EQUIVALENCE (SCRAT(1201),S), (SCRAT(1451),T) DBE 60 DOUBLE PRECISION DSNCOS,DXEXP DBE 70 COMMON /DCONLB/ DSNCOS,DXEXP DBE 80 10 IF (DABS(X).GT.16.5) GO TO 90 DBE 90 A=(X/2.D0)**2 DBE 100 J=X/.4+6.8 DBE 110 B=J DBE 120 C=J+N DBE 130 D=-1.D0 DBE 140 IF (M.GT.1) D=1.D0 DBE 150 IF (M.GT.3) GO TO 30 DBE 160 Y=1.D0 DBE 170 DO 20 I=1,J DBE 180 Y=1.D0+Y*A/(B*C)*D DBE 190 B=B-1.D0 DBE 200 20 C=C-1.D0 DBE 210 IF (N.GT.0) Y=X*Y/2.D0 DBE 220 GO TO 200 DBE 230 30 E=1.0D0 DBE 240 S(1)=.5772156649015D0 DBE 250 S(61)=S(1)-.5D0 DBE 260 DO 40 I=2,60 DBE 270 S(I)=S(I-1)-1.D0/E DBE 280 S(I+60)=S(I)-1.D0/(2.D0*(E+1.D0)) DBE 290 40 E=E+1.D0 DBE 300 E=FDLOG(X/2.D0) DBE 310 DO 50 I=1,120 DBE 320 50 T(I)=S(I)+E DBE 330 IF (M.LT.6) GO TO 60 DBE 340 IF (X.GT.8.D0) GO TO 90 DBE 350 60 IA=0 DBE 360 IF (N.GT.0) IA=60 DBE 370 IF (M.GT.5) D=-1.D0 DBE 380 I=J+IA+1 DBE 390 Y=T(I) DBE 400 DO 70 IB=1,J DBE 410 I=J-IB+IA+1 DBE 420 Y=T(I)-D*A*Y/(B*C) DBE 430 B=B-1.D0 DBE 440 70 C=C-1.D0 DBE 450 IF (N.GT.0) Y=X*Y/2.D0 DBE 460 IF (M.GT.5) GO TO 80 DBE 470 Y=Y*.636619772368D0 DBE 480 IF (N.NE.0) Y=-.636619772368D0/X+Y DBE 490 GO TO 200 DBE 500 80 Y=-Y DBE 510 IF (N.NE.0) Y=1.D0/X-Y DBE 520 GO TO 200 DBE 530 90 A=8.D0*X DBE 540 H=N DBE 550 H=(2.*H)**2 DBE 560 T(1)=(H-1.D0)/A DBE 570 D=T(1) DBE 580 DO 100 I=2,20 DBE 590 K=I DBE 600 B=I DBE 610 C=(2*I-1)**2 DBE 620 T(I)=(H-C)/(A*B) DBE 630 E=D DBE 640 D=T(I)*D DBE 650 E=DABS(D/E) DBE 660 IF (DABS(D).LT..5D-10) GO TO 110 DBE 670 IF (E.GT..91D0) GO TO 110 DBE 680 100 T(I+2)=0.0D0 DBE 690 110 A=-1.D0 DBE 700 IF (M.LE.1) GO TO 150 DBE 710 IF (M.LE.3) GO TO 120 DBE 720 IF (M.LE.5) GO TO 150 DBE 730 A=1.D0 DBE 740 120 Y=1.D0 DBE 750 DO 130 I=1,K DBE 760 J=K-I+1 DBE 770 130 Y=1.D0+A*Y*T(J) DBE 780 A=1.D0 DBE 790 IF (X.LT.DXEXP) A=FDEXP(X) DBE 800 IF (M.LE.5) GO TO 140 DBE 810 Y=Y/(A*FDSQRT(.636619772368D0*X)) DBE 820 GO TO 200 DBE 830 140 Y=Y*A/FDSQRT(6.283185307D0*X) DBE 840 GO TO 200 DBE 850 150 Y=FDSQRT(3.1415926536D0*X) DBE 860 J=K/2 DBE 870 K=2*J DBE 880 J=J-1 DBE 890 A=1.D0 DBE 900 H=A DBE 910 DO 160 I=1,J DBE 920 IA=K-2*I+1 DBE 930 A=1.D0-A*T(IA)*T(IA+1) DBE 940 160 H=1.D0-H*T(IA)*T(IA-1) DBE 950 A=(1.D0-T(1)*T(2)*A)/Y DBE 960 H=T(1)*H/Y DBE 970 B=FDSIN(X) DBE 980 C=FDCOS(X) DBE 990 D=A-H DBE1000 E=A+H DBE1010 IF (M.GT.2) GO TO 180 DBE1020 IF (N.EQ.0) GO TO 170 DBE1030 Y=E*B-D*C DBE1040 GO TO 200 DBE1050 170 Y=D*B+E*C DBE1060 GO TO 200 DBE1070 180 IF (N.EQ.0) GO TO 190 DBE1080 Y=-D*B-E*C DBE1090 GO TO 200 DBE1100 190 Y=E*B-D*C DBE1110 GO TO 200 DBE1120 200 DBEJ=Y DBE1130 RETURN DBE1140 END DBE1150 SUBROUTINE DEFINE DEF 10 C VERSION 5.00 DEFINE 5/15/70 DEF 20 COMMON /BLOCRC/ NRC,RC(12600) DEF 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NDEF 40 1ARGS,VWXYZ(8),NERROR DEF 50 DIMENSION ARGS(100) DEF 60 EQUIVALENCE (ARGS(1),RC(12501)) DEF 70 C DEF 80 C DEFINE $$ INTO COLUMN ++ DEF 90 C DEFINE $$ INTO ROW ++, COL ++. DEF 85 C DEFINE ROW ++, COL ++ INTO ROW ++, COL++. DEF 90 C DEFINE ROW ++, COL ++ INTO COL ++. DEF 100 C DEF 110 IF(NARGS.NE.2) GO TO 5 DEF 122 J=1 DEF 124 IF(KIND(1).EQ.0) CALL ADRESS(1,J) DEF 125 CALL ADRESS(2,I) DEF 126 IF(I) 120,130,2 DEF 127 2 IF(J) 120,130,60 DEF 128 5 IF(NARGS.NE.3) IF(NARGS-4) 115,40,115 DEF 129 IF (KIND(1).EQ.0) GO TO 40 DEF 130 10 I=NARGS DEF 140 GO TO 90 DEF 150 20 IF (NERROR.EQ.0) RC(L)=ARGS(1) DEF 160 30 RETURN DEF 170 40 I=2 DEF 180 GO TO 90 DEF 190 50 ARGS(1)=RC(L) DEF 200 IF (NARGS.EQ.4) GO TO 10 DEF 210 CALL ADRESS (3,I) DEF 220 IF (I) 120,130,60 DEF 230 60 IF (NERROR.NE.0) GO TO 30 DEF 240 IF (NRMAX.EQ.0) GO TO 70 DEF 250 IF(KIND(1).EQ.0.AND.NARGS.EQ.2) GO TO 140 DEF 255 CALL VECTOR (ARGS(1),I) DEF 260 GO TO 30 DEF 270 70 I=9 DEF 280 80 CALL ERROR (I) DEF 290 GO TO 30 DEF 300 C DEF 310 C CHECK AND CALCULATE WORKSHEET ENTRY LOCATION INTO L DEF 320 C DEF 330 90 CALL ADRESS(I,L) DEF 340 IF (L) 120,130,100 DEF 350 100 IF (KIND(I-1).EQ.0.AND.IARGS(I-1).GT.0.AND.IARGS(I-1).LE.NROW) GO DEF 360 1TO 110 DEF 370 I=16 DEF 380 GO TO 80 DEF 390 110 L=L+IARGS(I-1)-1 DEF 400 IF (I-2) 50,50,20 DEF 410 115 I=10 DEF 420 GO TO 80 DEF 430 120 I=20 DEF 440 GO TO 80 DEF 450 130 I=11 DEF 460 GO TO 80 DEF 470 140 DO 150 IJ=1,NRMAX DEF 480 RC(I)=RC(J) DEF 490 I=I+1 DEF 500 150 J=J+1 DEF 510 RETURN DEF 520 END DEF 530 SUBROUTINE DETRNK (A,NROW,N,DET,RANK) DET 10 C VERSION 5.00 DETRNK 5/15/70 DET 20 C WRITTEN BY S PEAVY 2/ 1/68 DET 30 C EVALUATES THE DETERMINAUT AND RANK OF A DET 40 C A LOCATION OF A MATRIX DET 50 C NROW THE DIMENSION OF A IN DIMENSION STATEMENT DET 60 C N SIZE OF A DET 70 C DET -THE VALUE OR DETERMINANT OF A DET 80 C RANK-RANK OF A DET 90 C ORIGANAL VALUES OF A ARE DESTROYED DET 100 C DET 110 DIMENSION A(NROW,NROW) DET 120 NK=N DET 130 NN=N-1 DET 140 VAL=1.0 DET 150 DO 60 I=1,NN DET 160 II=I+1 DET 170 IB=I DET 180 DO 10 J=II,N DET 190 IF (ABS(A(IB,I)).GE.ABS(A(J,I))) GO TO 10 DET 200 IB=J DET 210 10 CONTINUE DET 220 IF (ABS(A(IB,I)).GE.1.E-7) GO TO 20 DET 230 NK=NK-1 DET 240 GO TO 40 DET 250 20 IF (IB.EQ.I) GO TO 40 DET 260 DO 30 J=I,N DET 270 T=A(I,J) DET 280 A(I,J)=A(IB,J) DET 290 30 A(IB,J)=T DET 300 VAL=-VAL DET 310 40 DO 50 J=II,N DET 320 X=A(J,I)/A(I,I) DET 330 DO 50 K=I,N DET 340 50 A(J,K)=A(J,K)-X*A(I,K) DET 350 60 CONTINUE DET 360 RANK=NK DET 370 IF (NK-N) 90,70,90 DET 380 70 PR=1.0 DET 390 DO 80 I=1,N DET 400 80 PR=PR*A(I,I) DET 410 DET=VAL*PR DET 420 RETURN DET 430 90 DET=0.0 DET 440 RETURN DET 450 END DET 460 SUBROUTINE DHRND (X,N,XT) DHR 10 C VERSION 5.00 DHRND 5/15/70 DHR 20 C SUBROUTINE TO ROUND X TO N SD AND STORE IN XT DHR 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/09/70 DHR 40 DOUBLE PRECISION Z DHR 50 IF (X) 20,10,20 DHR 60 10 XT=0.0 DHR 70 RETURN DHR 80 20 IF (N.LT.1) N=1 DHR 90 IF (N.GT.8) N=8 DHR 100 Y=ABS(X) DHR 110 M=FLOG10(Y) DHR 120 IF (Y.LT.1.0) M=M-1 DHR 130 Z=Y DHR 140 Z=Z*10.D0**(8-M) DHR 150 IF (Z.LT.1.0D+9) GO TO 30 DHR 160 M=M+1 DHR 170 Z=Z/10.0D0 DHR 180 GO TO 40 DHR 190 30 IF (Z.GE.1.0D+8) GO TO 40 DHR 200 M=M-1 DHR 210 Z=10.0D0*Z DHR 220 40 X1=Z DHR 230 LL1=X1 DHR 240 X2=Z-DBLE(X1) DHR 250 LL2=X2 DHR 260 LL=LL1+LL2+5 DHR 270 LL1=LL/(10**(9-N)) DHR 280 LL2=LL1*10**(9-N) DHR 290 LL2=LL-LL2 DHR 300 IF (N.EQ.8) GO TO 70 DHR 310 IF (LL2/10-5*10**(7-N)) 70,50,60 DHR 320 50 LL2=MOD(LL1,2) DHR 330 IF (LL2) 70,70,60 DHR 340 60 LL1=LL1+1 DHR 350 70 XT=FLOAT(LL1) DHR 360 IF (M.EQ.N-1) GO TO 80 DHR 370 C DHR 380 Z=XT DHR 390 Z=Z*10.0D0**(M-N+1) DHR 400 XT=FDPCON(Z) DHR 410 80 XT=SIGN(XT,X) DHR 420 RETURN DHR 430 END DHR 440 SUBROUTINE DIMENS DIM 10 C VERSION 5.00 DIMENS 5/15/70 DIM 20 COMMON /BLOCRC/ NRC,RC(12600) DIM 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NDIM 40 1ARGS,VWXYZ(8),NERROR DIM 50 DIMENSION ARGS(100) DIM 60 EQUIVALENCE (ARGS(1),RC(12501)) DIM 70 IF (NARGS.EQ.2) IF (KIND(1)+KIND(2)) 25,27,25 DIM 75 K=10 DIM 80 10 CALL ERROR (K) DIM 90 20 RETURN DIM 100 25 K=20 DIM 110 GO TO 10 DIM 120 27 IF (IARGS(1).GT.0.AND.IARGS(2).GT.0.AND.IARGS(1)*IARGS(2).LE.NRC) DIM 130 1GO TO 30 DIM 140 K=3 DIM 150 GO TO 10 DIM 160 30 NROW=IARGS(1) DIM 170 NCOL=IARGS(2) DIM 180 NRMAX=MIN0(NROW,NRMAX) DIM 190 GO TO 20 DIM 200 END DIM 210 SUBROUTINE DUMMYA DMA 10 C VERSION 5.00 DUMMYA 5/15/70 DMA 20 PRINT 10 DMA 30 10 FORMAT(55H * OMNITAB COMMAND DUMMYA IS NOT AVAILABLE AT THIS TIME)DMA 40 RETURN DMA 50 END DMA 60 SUBROUTINE DUMMYB DMB 10 C VERSION 5.00 DUMMYB 5/15/70 DMB 20 PRINT 10 DMB 30 10 FORMAT(55H * OMNITAB COMMAND DUMMYB IS NOT AVAILABLE AT THIS TIME)DMB 40 RETURN DMB 50 END DMB 60 SUBROUTINE DUMMYC DMC 10 C VERSION 5.00 DUMMYC 5/15/70 DMC 20 PRINT 10 DMC 30 10 FORMAT(55H * OMNITAB COMMAND DUMMYC IS NOT AVAILABLE AT THIS TIME)DMC 40 RETURN DMC 50 END DMC 60 SUBROUTINE DUMMYD DMD 10 C VERSION 5.00 DUMMYD 5/15/70 DMD 20 PRINT 10 DMD 30 10 FORMAT(55H * OMNITAB COMMAND DUMMYD IS NOT AVAILABLE AT THIS TIME)DMD 40 RETURN DMD 50 END DMD 60 SUBROUTINE DUMMYE DME 10 C VERSION 5.00 DUMMYE 5/15/70 DME 20 PRINT 10 DME 30 10 FORMAT(55H * OMNITAB COMMAND DUMMYE IS NOT AVAILABLE AT THIS TIME)DME 40 RETURN DME 50 END DME 60 SUBROUTINE DUMMYF DMF 10 C VERSION 5.00 DUMMYF 5/15/70 DMF 20 PRINT 10 DMF 30 10 FORMAT(55H * OMNITAB COMMAND DUMMYF IS NOT AVAILABLE AT THIS TIME)DMF 40 RETURN DMF 50 END DMF 60 SUBROUTINE ERASE ERA 10 C VERSION 5.00 ERASE 5/15/70 ERA 20 C ERA 30 C ERASE COL (C), (C), (C), ETC. ERA 40 C IF NO COLS SPECIFIED ALL OF WORKSHEET IS ERASED ERA 45 C ERA 50 COMMON /BLOCRC/ NRC,RC(12600) ERA 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NERA 70 1ARGS,VWXYZ(8),NERROR ERA 80 DIMENSION ARGS(100) ERA 90 EQUIVALENCE (ARGS(1),RC(12501)) ERA 100 IF (NARGS.EQ.0) GO TO 40 ERA 110 CALL CHKCOL (I) ERA 120 IF (I.EQ.0) GO TO 20 ERA 130 I=20 ERA 140 CALL ERROR (I) ERA 150 10 RETURN ERA 160 20 IF (NERROR.NE.0.OR.NRMAX.EQ.0) GO TO 10 ERA 170 DO 30 I=1,NARGS ERA 180 30 CALL VECTOR (0.,IARGS(I)) ERA 190 GO TO 10 ERA 200 C ERA 210 C CLEAR ALL OF DIMENSIONED WORKSHEET. ERA 220 C ERA 230 40 IF (NERROR.NE.0) GO TO 10 ERA 240 NRMAX=NROW*NCOL ERA 250 CALL VECTOR (0.,1) ERA 260 NRMAX=0 ERA 270 GO TO 10 ERA 280 END ERA 290 SUBROUTINE ERRINT (X,ERF,ERFC) ERT 10 C VERSION 5.00 ERRINT 5/15/70 ERT 20 DOUBLE PRECISION AN,BN,CONS,C1,DN,ERF,ERFC,F,FN,FNM1,FNM2,FOUR,GN,ERT 25 1GNM1,GNM2,ONE,P,PREV,RNBC,SCF,SUM,TN,TOLER,TRRTPI,TWO,ULCF,ULPS,WNERT 30 2,X,Y,YSQ,FDEXP ERT 40 COMMON/DCONL2/TRRTPI,NBC,NBM ERT 90 DATA ONE,TWO,FOUR,ULPS,CONS/1.D0,2.D0,4.D0,1.D0,.83D0/ ERT 100 RNBC=NBC ERT 120 TOLER=TWO**(-NBM) ERT 130 IF (X) 20,10,20 ERT 140 10 ERF=0 ERT 150 ERFC=ONE ERT 160 RETURN ERT 170 20 Y=ABS(X) ERT 180 YSQ=Y**2 ERT 190 IF (Y-ULPS) 50,50,30 ERT 200 30 C1=TWO**((RNBC-ONE)/TWO) ERT 210 ULCF=CONS*C1 ERT 220 SCF=TWO**(C1**2-RNBC) ERT 230 IF (Y-ULCF) 110,110,40 ERT 240 40 ERF=ONE ERT 250 ERFC=0 ERT 260 GO TO 80 ERT 270 50 SUM=0 ERT 280 DN=ONE ERT 290 TN=ONE ERT 300 P=TWO*YSQ ERT 310 60 DN=DN+TWO ERT 320 TN=P*TN/DN ERT 330 SUM=TN+SUM ERT 340 IF (TN-TOLER) 70,60,60 ERT 350 70 ERF=(SUM+ONE)*TRRTPI*Y*FDEXP(-YSQ) ERT 360 ERFC=ONE-ERF ERT 370 80 IF (X) 90,100,100 ERT 380 90 ERF=-ERF ERT 390 ERFC=TWO-ERFC ERT 400 100 RETURN ERT 410 110 FNM2=0 ERT 420 GNM2=ONE ERT 430 FNM1=TWO*Y ERT 440 GNM1=TWO*YSQ+ONE ERT 450 PREV=FNM1/GNM1 ERT 460 WN=ONE ERT 470 BN=GNM1+FOUR ERT 480 120 AN=-WN*(WN+ONE) ERT 490 FN=BN*FNM1+AN*FNM2 ERT 500 GN=BN*GNM1+AN*GNM2 ERT 510 F=FN/GN ERT 520 IF (ABS(ONE-(F/PREV))-TOLER) 170,170,130 ERT 530 130 IF (PREV-F) 140,140,160 ERT 540 140 IF (GN.LT.SCF) GO TO 150 ERT 550 FN=FN/SCF ERT 560 GN=GN/SCF ERT 570 FNM1=FNM1/SCF ERT 580 GNM1=GNM1/SCF ERT 590 150 FNM2=FNM1 ERT 600 GNM2=GNM1 ERT 610 FNM1=FN ERT 620 GNM1=GN ERT 630 WN=WN+TWO ERT 640 BN=BN+FOUR ERT 650 PREV=F ERT 660 GO TO 120 ERT 670 160 F=PREV ERT 680 170 ERFC=F*FDEXP(-YSQ)*TRRTPI/TWO ERT 690 ERF=ONE-ERFC ERT 700 GO TO 80 ERT 710 END ERT 720 SUBROUTINE ERROR(I) ERR 10 C VERSION 5.00 ERROR 5/15/70 ERR 20 COMMON/BLOCRC/NRC,RC(12600) ERR 30 COMMON/BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX, ERR 40 1 NROW,NCOL,NARGS,VWXYZ(8),NERROR ERR 50 DIMENSION ARGS(100) ERR 60 EQUIVALENCE (ARGS(1),RC(12501)) ERR 70 COMMON/BLOCKC/KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST ERR 80 COMMON / BLOCKX / INDEX( 6, 8 ), LEVEL ERR 90 COMMON/SPRV/NERCON,NERR,ISWERR ERR 100 DIMENSION IL( 2 ) ERR 110 DATA IBL,IL(1),IL(2)/2H ,2H/I,2H/F/ ERR 120 ISCRUN=ISCRAT ERR 130 C ERR 140 C IF 1 .LE. I .LE. 100, FATAL ERROR ERR 150 C IF 101 .LE. I .LE. 200, ARITHMETIC ERROR ERR 160 C IF 201 .LE. I .LE. INFORMATION DIAGNOSTIC ERR 170 C ERR 180 NERR=NERR+1 ERR 190 7003 IF( I .GT. 100 ) GO TO 200 ERR 200 NERROR=NERROR+1 ERR 210 WRITE( ISCRUN, 800 ) ERR 220 800 FORMAT(/32H*** FATAL ERROR IN ABOVE COMMAND,52X) ERR 230 IF(LLIST.NE.0) GO TO 710 ERR 240 WRITE(ISCRUN,700) ERR 250 700 FORMAT(66H*** COMMAND WAS NOT LISTED BECAUSE NO LIST OR LIST O WASERR 260 1 IN EFFECT,18X) ERR 270 710 LLIST=3 ERR 280 GO TO (801,802,803,804,805,806,807,808,809,810,811,812,813,814,815ERR 290 1,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830), I ERR 300 801 WRITE(ISCRUN,1) ERR 310 1 FORMAT(29H*** NAME NOT FOUND IN LIBRARY,55X) ERR 320 GO TO 900 ERR 330 802 WRITE(ISCRUN,2) ERR 340 2 FORMAT(28H*** ILLEGAL STATEMENT NUMBER,56X) ERR 350 GO TO 900 ERR 360 803 WRITE(ISCRUN,3) ERR 370 3 FORMAT(28H*** ILLEGAL ARGUMENT ON CARD,56X) ERR 380 GO TO 900 ERR 390 804 GO TO 900 ERR 400 805 WRITE(ISCRUN,5) ERR 410 5 FORMAT(38H*** COMMAND NOT ALLOWED IN REPEAT MODE,46X) ERR 420 GO TO 900 ERR 430 806 WRITE(ISCRUN,6) ERR 440 6 FORMAT(74H*** STATEMENT NUMBER MAY NOT BEGIN ANY CARD BETWEEN BEGIERR 450 1N AND FINISH CARDS,10X) ERR 460 GO TO 900 ERR 470 807 WRITE(ISCRUN,7) ERR 480 7 FORMAT(23H** ILLEGAL *STATEMENT*,61X) ERR 490 GO TO 900 ERR 500 808 WRITE(ISCRUN,8) ERR 510 8 FORMAT(34H*** PHYSICAL CONSTANT NOT IN TABLE,50X) ERR 520 GO TO 900 ERR 530 809 WRITE(ISCRUN,9) ERR 540 9 FORMAT(13H*** NRMAX = 0,71X) ERR 550 GO TO 900 ERR 560 810 WRITE(ISCRUN,10) NARGS ERR 570 10 FORMAT(3H***,I4,34H IS AN ILLEGAL NUMBER OF ARGUMENTS,43X) ERR 580 GO TO 900 ERR 590 811 WRITE(ISCRUN,11) ERR 600 11 FORMAT(40H*** COLUMN NUMBER TOO BIG OR LESS THEN 1,44X) ERR 610 GO TO 900 ERR 620 812 WRITE(ISCRUN,12) ERR 630 12 FORMAT(33H*** COMMAND STORAGE AREA OVERFLOW,51X) ERR 640 GO TO 900 ERR 650 813 WRITE(ISCRUN,13) ERR 660 13 FORMAT(30H*** STATEMENT NUMBER NOT FOUND,54X) ERR 670 GO TO 900 ERR 680 814 WRITE(ISCRUN,14) ERR 690 14 FORMAT(35H*** ILLEGAL OR NO FORMAT DESIGNATOR,49X) ERR 700 GO TO 900 ERR 710 815 WRITE(ISCRUN,15) ERR 720 15 FORMAT(34H*** DIMENSIONED AREA EXCEEDS LIMIT,50X) ERR 730 GO TO 900 ERR 740 816 WRITE(ISCRUN,16) ERR 750 16 FORMAT(27H*** ILLEGAL SIZE ROW NUMBER,57X) ERR 760 GO TO 900 ERR 770 817 WRITE(ISCRUN,17) ERR 780 17 FORMAT(39H*** DEFINED MATRIX OVERFLOWS WORKSHEET,45X) ERR 790 GO TO 900 ERR 800 818 WRITE(ISCRUN,18) ERR 810 18 FORMAT(36H*** INTEGER ARGUMENT LESS THEN -8191,48X) ERR 820 GO TO 900 ERR 830 819 WRITE(ISCRUN,19) ERR 840 19 FORMAT(48H*** STORED PERFORM STATEMENT WILL EXECUTE ITSELF,36X) ERR 850 GO TO 900 ERR 860 820 WRITE(ISCRUN,20) ERR 870 20 FORMAT(29H*** IMPROPER TYPE OF ARGUMENT,55X) ERR 880 GO TO 900 ERR 890 821 WRITE(ISCRUN,21) ERR 900 21 FORMAT(26H*** COMAND MUST BE STORED,58X) ERR 910 GO TO 900 ERR 920 822 WRITE(ISCRUN,22) ERR 930 22 FORMAT(31H*** MATRIX IS (NEARLY) SINGULAR,53X) ERR 940 GO TO 900 ERR 950 823 WRITE(ISCRUN,23) ERR 960 23 FORMAT(28H***INSUFFICIENT SCRATCH AREA,56X) ERR 970 GO TO 900 ERR 980 824 WRITE(ISCRUN,24) ERR 990 24 FORMAT (49H*** DEGREE IS LARGER THAN NO. OF NON-ZERO WEIGHTS,35X) ERR1000 GO TO 900 ERR1010 825 WRITE(ISCRUN,25) ERR1020 25 FORMAT(35H***NEGATIVE WEIGHTS MAY NOT BE USED,49X) ERR1030 GO TO 900 ERR1040 826 WRITE(ISCRUN,26) ERR1050 26 FORMAT(51H***NUMBER OF COLUMNS IS GREATER THAN NUMBER OF ROWS,33X)ERR1060 GO TO 900 ERR1070 827 WRITE(ISCRUN,27) ERR1080 27 FORMAT (19H***FORMAT NOT FOUND,65X) ERR1090 GO TO 900 ERR1100 C**** THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS ERR1110 828 WRITE(ISCRUN,28) ERR1120 28 FORMAT(47H* INCORRECT TAPE UNIT. COMMAND IS NOT EXECUTED.,37X) ERR1130 GO TO 900 ERR1140 C***********************************************************************ERR1150 829 NSB = NARGS+1 ERR1160 WRITE (ISCRUN,29) NSB ERR1170 29 FORMAT (31H* NUMBER OF ARGUMENTS SHOULD BE,I2,51X) ERR1180 GO TO 900 ERR1185 830 WRITE(ISCRUN,30) ERR1190 30 FORMAT (48H* AN INCREMENT COMMAND CAN NOT INCREMENT ITSELF.,36X) ERR1200 900 IF( LEVEL .NE. 0) CALL RNDOWN ERR1220 C FORCE OUT OF REPEAT MODE IF FATAL ERROR ERR1230 IF( I .LE. 100 ) LEVEL = 0 ERR1240 WRITE( ISCRUN, 901 ) ERR1250 901 FORMAT(84X) ERR1260 RETURN ERR1270 200 IF(NERR.LE.NERCON.OR.LLIST.NE.3) GO TO 201 ERR1280 IF(ISWERR.NE.0) RETURN ERR1290 ISWERR=1 ERR1300 WRITE(ISCRUN,9999)NERCON ERR1310 9999 FORMAT(/1H*,I5,62H INFORMATIVE AND ARITHMETIC DIAGNOSTICS HAVE BEEERR1320 1N ENCOUNTERED.,16X/ ERR1330 284H* ANY SUCH ADDITIONAL DIAGNOSTICS FOR THIS COMMAND OR REPEAT MERR1340 3ODE ARE DISREGARDED. ) ERR1350 RETURN ERR1360 201 IF(I.GT.200) GO TO 400 ERR1370 C ERR1380 C ERR1390 C ARITHMETIC TROUBLES, SET FLAGS ERR1400 C ERR1410 CALL AERR(I-100) ERR1420 250 RETURN ERR1430 C ERR1440 C INFORMATIVE DIAGNOSTIC ERR1450 C ERR1460 400 IF( MOD( LLIST, 2 ) .EQ. 0 ) GO TO 250 ERR1470 IF(LLIST.EQ.0) GO TO 250 ERR1475 CALL INFERR(I) ERR1480 GO TO 900 ERR1490 END ERR1500 SUBROUTINE EXCHNG EXC 10 C VERSION 5.00 EXCHNG 5/15/70 EXC 20 C EXC 30 C EXCHANGE COL ++ WITH ++, COL ++ WITH ++, ETC. EXC 40 C EXC 50 COMMON /BLOCRC/ NRC,RC(12600) EXC 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NEXC 70 1ARGS,VWXYZ(8),NERROR EXC 80 DIMENSION ARGS(100) EXC 90 EQUIVALENCE (ARGS(1),RC(12501)) EXC 100 IF (NARGS) 70,70,10 EXC 110 10 IF (NARGS.NE.(NARGS/2)*2) GO TO 70 EXC 120 DO 50 I=1,NARGS,2 EXC 130 CALL ADRESS (I,J) EXC 140 IF (J) 60,80,20 EXC 150 20 CALL ADRESS (I+1,K) EXC 160 IF (K) 60,80,30 EXC 170 30 IF (NERROR.NE.0) RETURN EXC 180 DO 40 N=1,NRMAX EXC 190 JJ=J+N-1 EXC 200 KK=K+N-1 EXC 210 WORK=RC(JJ) EXC 220 RC(JJ)=RC(KK) EXC 230 RC(KK)=WORK EXC 240 40 CONTINUE EXC 250 50 CONTINUE EXC 260 GO TO 90 EXC 270 60 CALL ERROR (3) EXC 280 GO TO 90 EXC 290 70 CALL ERROR (10) EXC 300 GO TO 90 EXC 310 80 CALL ERROR (11) EXC 320 90 RETURN EXC 330 END EXC 340 SUBROUTINE EXPCON EXN 10 C VERSION 5.00 EXPCON 5/15/70 EXN 20 C EXPCON SUBROUTINE S PEAVY 4/4/68 EXN 30 C COMMANDS EXN 40 C L2=1: MVECDIAG EXN 50 C MVECDIAG MATRIX IN R , C SIZE N , M PUT DIAGONAL IN C EXN 60 C MVECDIAG MATRIX IN R , C SIZE N , M PUT DIAGONAL IN R , C EXN 70 C L2=2: MVECMAT EXN 80 C MVECMAT MATRIX IN R , C SIZE N , M PUT ROW BY ROW EXN 90 C AS A VECTOR IN C EXN 100 C MVECMAT MATRIX IN R , C SIZE N , M PUT ROW BY ROW AS A EXN 110 C VECTOR IN R , C EXN 120 C L2=3: MMATVEC EXN 130 C MMATVEC VECTOR C PUT AS ROW X ROW MATRIX IN R , C SIZE N , MEXN 135 C MMATVEC VECTOR R , C PUT AS ROW X ROW MATRIX IN R , C EXN 140 C SIZE N X M EXN 145 COMMON /BLOCRC/ NRC,RC(12600) EXN 160 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NEXN 170 1ARGS,VWXYZ(8),NERROR EXN 180 DIMENSION ARGS(100) EXN 190 EQUIVALENCE (ARGS(1),RC(12501)) EXN 200 COMMON /SCRAT/ NS,NS2,A(13500) EXN 210 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG EXN 220 IF (NARGS.EQ.5.OR.NARGS.EQ.6) GO TO 10 EXN 230 CALL ERROR (10) EXN 240 RETURN EXN 250 10 J=NARGS EXN 260 KRR=0 EXN 270 CALL CKIND (J) EXN 280 IF (J.EQ.0) IF (L2-2) 15,65,125 EXN 285 CALL ERROR (3) EXN 290 RETURN EXN 300 C VEC DIAG **** EXN 310 15 IARGS(7)=MIN0(IARGS(3),IARGS(4)) EXN 320 IARGS(8)=1 EXN 330 IF (NARGS.EQ.6) GO TO 20 EXN 340 IARGS(6)=IARGS(5) EXN 350 IARGS(5)=1 EXN 360 MKKR=226 EXN 370 20 IF (IARGS(5)+IARGS(7)-1.LE.NROW) GO TO 30 EXN 380 IARGS(7)=NROW-IARGS(5)+1 EXN 390 KRR=MKKR EXN 400 C ERROR 226: COLUMN NOT LONG ENOUGH TO STORE ALL ELEMENTS. ONLY NROWEXN 410 C WILL BE STORE EXN 420 30 J=2 EXN 430 CALL MTXCHK (J) EXN 440 IF (J.NE.0) CALL ERROR (17) EXN 450 IF (NERROR.NE.0) RETURN EXN 460 IF (KRR.NE.0) CALL ERROR (KRR) EXN 470 GO TO (40,80,140), L2 EXN 480 40 IA=IARGS(1) EXN 490 IB=IARGS(7) EXN 500 DO 50 I=1,IB EXN 510 A(I)=RC(IA) EXN 520 50 IA=IA+NROW+1 EXN 530 IA=IARGS(5) EXN 540 DO 60 I=1,IB EXN 550 RC(IA)=A(I) EXN 560 60 IA=IA+1 EXN 570 RETURN EXN 580 C 65 VECTORIZE A MATRIX *** EXN 590 65 IARGS(7)=IARGS(3)*IARGS(4) EXN 600 IARGS(8)=1 EXN 610 IF (NARGS.EQ.6) GO TO 70 EXN 620 IARGS(6)=IARGS(5) EXN 630 IARGS(5)=1 EXN 640 70 MKKR=226 EXN 650 GO TO 20 EXN 690 80 IB=IARGS(7) EXN 700 IA=IARGS(1) EXN 710 N=IARGS(3) EXN 720 M=IARGS(4) EXN 730 IC=1 EXN 740 DO 100 I=1,N EXN 750 IAA=IA EXN 760 DO 90 J=1,M EXN 770 A(IC)=RC(IAA) EXN 780 IF (IC.EQ.IB) GO TO 110 EXN 790 IC=IC+1 EXN 800 90 IAA=IAA+NROW EXN 810 100 IA=IA+1 EXN 820 110 IA=IARGS(5) EXN 830 DO 120 I=1,IB EXN 840 RC(IA)=A(I) EXN 850 120 IA=IA+1 EXN 860 RETURN EXN 870 C 125 TAKE A COLUMN AND RESTORE IT TO A MATRIX OR ARRAY. EXN 880 125 IARGS(8)=IARGS(NARGS) EXN 890 IARGS(7)=IARGS(NARGS-1) EXN 900 IARGS(6)=IARGS(NARGS-2) EXN 910 IARGS(5)=IARGS(NARGS-3) EXN 920 IF (NARGS.EQ.6) GO TO 130 EXN 930 IARGS(2)=IARGS(1) EXN 940 IARGS(1)=1 EXN 950 130 IARGS(3)=IARGS(7)*IARGS(8) EXN 960 IARGS(4)=1 EXN 970 IF (IARGS(1)+IARGS(3)-1.LE.NROW) GO TO 30 EXN 980 IARGS(3)=NROW-IARGS(1)+1 EXN 990 C KRR=227 EXN1000 C 227 ERROR:,NOT ENOUGH ELEMENTS IN COL TO RESTORE MATRIX OR ARRAY. EXN1010 C ELEMENTS AVAILABLE WILL BE USED EXN1020 GO TO 30 EXN1030 140 IA=IARGS(1) EXN1040 IB=IARGS(3) EXN1050 DO 150 I=1,IB EXN1060 A(I)=RC(IA) EXN1070 150 IA=IA+1 EXN1080 IA=IARGS(5) EXN1090 N=IARGS(7) EXN1100 M=IARGS(8) EXN1110 IC=1 EXN1120 DO 170 I=1,N EXN1130 IAA=IA EXN1140 DO 160 J=1,M EXN1150 RC(IAA)=A(IC) EXN1160 IF (IC.EQ.IB) RETURN EXN1170 IC=IC+1 EXN1180 160 IAA=IAA+NROW EXN1190 170 IA=IA+1 EXN1200 RETURN EXN1210 END EXN1220 SUBROUTINE EXPAND (J,WHERE) EXD 10 C VERSION 5.00 EXPAND 5/15/70 EXD 20 COMMON /BLOCRC/ NRC,RC(12600) EXD 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NEXD 40 1ARGS,VWXYZ(8),NERROR EXD 50 DIMENSION ARGS(100) EXD 60 EQUIVALENCE (ARGS(1),RC(12501)) EXD 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG EXD 80 DIMENSION WHERE(1) EXD 90 C EXD 100 C THIS ROUTINE EXPANDS STORED COMMANDS FROM WHERE TO A USABLE EXD 110 C FORM IN ARGS, IARGS AND KIND. EXD 120 C EXD 130 II=0 EXD 140 I=0 EXD 150 JJJ=J EXD 160 C CONVERT ONLY FIRST ARGUMENT IF COMMAND IS INCREMENT OR RESTORE EXD 170 IF (L1.NE.14) GO TO 10 EXD 180 IF (L2.GE.6.AND.L2.LE.8) JJJ=2 EXD 190 10 II=II+1 EXD 200 20 I=I+1 EXD 210 IF (I.GE.JJJ) GO TO 80 EXD 220 T=WHERE(I) EXD 230 IF (T) 50,40,30 EXD 240 30 KIND(II)=0 EXD 250 IARGS(II)=T-8192. EXD 260 GO TO 10 EXD 270 40 KIND(II)=1 EXD 280 I=I+1 EXD 290 ARGS(II)=WHERE(I) EXD 300 GO TO 10 EXD 310 50 IF(T.EQ.(-1.)) GO TO 100 EXD 320 CALL XPND (WHERE(I),K,ARGS(II),KND) EXD 330 IF (K.GE.0) GO TO 90 EXD 340 60 K=-K EXD 350 70 CALL ERROR (K) EXD 360 80 RETURN EXD 370 90 KIND(II)=KND EXD 380 IF (KND.EQ.0) IARGS(II)=ARGS(II) EXD 390 I=I+K EXD 400 GO TO 10 EXD 410 C EXD 420 C IF STORED VALUE = -1, THEN ARGS (INTEGER) ARE TO BE EXPANDED FROM EXD 430 C PREVIOUS ARG TO FOLLOWING WITH A MAXIMUM TOTAL OF 100 EXD 440 C EXD 450 100 I=I+1 EXD 460 C PICK UP NEXT ARG EXD 470 IU=WHERE(I) EXD 480 IF (KIND(II-1).NE.0.OR.I.GE.J) GO TO 190 EXD 490 IF (IU) 170,190,110 EXD 500 110 IU=IU-8192 EXD 510 120 K=IU-IARGS(II-1) EXD 520 NARGS=NARGS+IABS(K)-1 EXD 530 IF(NARGS.GT.100) GO TO 200 EXD 540 IF (K) 130,20,140 EXD 550 130 INC=-1 EXD 560 K=-K EXD 570 GO TO 150 EXD 580 140 INC=1 EXD 590 150 DO 160 IT=1,K EXD 600 KIND(II)=0 EXD 610 IARGS(II)=IARGS(II-1)+INC EXD 620 160 II=II+1 EXD 630 GO TO 20 EXD 640 C EXD 650 C EXPAND FROM IARG *** ,,ARG,, EXD 660 C EXD 670 170 CALL XPND (WHERE(I),K,ARGS(II),KND) EXD 680 IF (K.LT.0) GO TO 60 EXD 690 I=I+K EXD 700 IF (KND.EQ.0) GO TO 180 EXD 710 K=20 EXD 720 GO TO 70 EXD 730 180 IU=ARGS(II) EXD 740 GO TO 120 EXD 750 190 CALL ERROR (211) EXD 760 GO TO 10 EXD 770 200 K=10 EXD 780 GO TO 70 EXD 790 END EXD 800 SUBROUTINE EXTREM EXT 10 C VERSION 5.00 EXTREM 5/15/70 EXT 20 COMMON /BLOCRC/ NRC,RC(12600) EXT 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NEXT 40 1ARGS,VWXYZ(8),NERROR EXT 50 DIMENSION ARGS(100) EXT 60 EQUIVALENCE (ARGS(1),RC(12501)) EXT 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG EXT 80 C EXT 90 C L2 = 4,5 MAX L2 = 6,7 MIN EXT 100 C EXT 110 C MAX OF ++ TO ++ EXT 120 C MAX OF ++ TO ++, CORRESP ENTRY OF ++ TO ++, ++ TO ++, ETC. EXT 130 C LIKEWISE FOR MIN. EXT 140 C EXT 150 IF (NARGS.GT.0.AND.MOD(NARGS,2).EQ.0) GO TO 30 EXT 160 I=10 EXT 170 10 CALL ERROR (I) EXT 180 20 RETURN EXT 190 30 CALL CHKCOL (I) EXT 200 IF (I.EQ.0) GO TO 40 EXT 210 I=20 EXT 220 GO TO 10 EXT 230 40 IF (NERROR.NE.0) GO TO 20 EXT 240 J=0 EXT 250 IF (NRMAX-1) 50,110,60 EXT 260 50 I=9 EXT 270 GO TO 10 EXT 280 60 J=IARGS(1) EXT 290 K=J+1 EXT 300 L=K+NRMAX-2 EXT 310 IF (L2.GT.5) GO TO 80 EXT 320 C EXT 330 C FIND MAXIMUM EXT 340 C EXT 350 DO 70 I=K,L EXT 360 IF (RC(J).LT.RC(I)) J=I EXT 370 70 CONTINUE EXT 380 GO TO 100 EXT 390 C EXT 400 C FIND MINIMUM EXT 410 C EXT 420 80 DO 90 I=K,L EXT 430 IF (RC(J).GT.RC(I)) J=I EXT 440 90 CONTINUE EXT 450 100 J=J-IARGS(1) EXT 460 110 DO 120 I=1,NARGS,2 EXT 470 K=IARGS(I)+J EXT 480 120 CALL VECTOR (RC(K),IARGS(I+1)) EXT 490 GO TO 20 EXT 500 END EXT 510 FUNCTION FCOS (X) FCO 10 C VERSION 5.00 FCOS 5/15/70 FCO 20 C FCO 30 C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 3.3E7 IN FCO 40 C ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET = 0.0 FCO 50 C FCO 60 COMMON /CONSLB/ XTRIG,XEXP FCO 70 IF (ABS(X).GT.XTRIG) GO TO 20 FCO 80 FCOS=COS(X) FCO 90 10 RETURN FCO 100 20 CALL ERROR (104) FCO 110 FCOS=0. FCO 120 GO TO 10 FCO 130 END FCO 140 DOUBLE PRECISION FUNCTION FDCOS(X) FDC 10 C VERSION 5.00 FDCOS 5/15/70 FDC 20 C FDC 30 C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THEN 3.5016 IN FDC 40 C ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET =0 WITH DIAGNOSTIC. FDC 50 C FDC 60 DOUBLE PRECISION DSNCOS,DXEXP FDC 70 COMMON /DCONLB/ DSNCOS,DXEXP FDC 80 DOUBLE PRECISION X,DCOS FDC 90 IF (DABS(X).GT.DSNCOS) GO TO 20 FDC 100 FDCOS=DCOS(X) FDC 110 10 RETURN FDC 120 20 CALL ERROR (104) FDC 130 FDCOS=0.D0 FDC 140 GO TO 10 FDC 150 END FDC 160 DOUBLE PRECISION FUNCTION FDEXP (X) FDE 10 C VERSION 5.00 FDEXP 5/15/70 FDE 20 C FDE 30 C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THEN 704.D0 FDE 40 C BEFORE SYSTEM DOES. RESULT IS SET = 0.0 AND DIAGNOSTIC IS PRINTED.FDE 50 C FDE 60 DOUBLE PRECISION DSNCOS,DXEXP FDE 70 COMMON /DCONLB/ DSNCOS,DXEXP FDE 80 DOUBLE PRECISION X,DEXP FDE 90 IF (X.GT.DXEXP) GO TO 20 FDE 100 FDEXP=DEXP(X) FDE 110 10 RETURN FDE 120 20 CALL ERROR (102) FDE 130 FDEXP=0.0D0 FDE 140 GO TO 10 FDE 150 END FDE 160 DOUBLE PRECISION FUNCTION FDLOG(X) FDL 10 C VERSION 5.00 FDLOG 5/15/70 FDL 20 C FDL 30 C THIS FUNCITON IS TO TRAP ILLEGAL ARGUMENT FDL 40 C BEFORE SYSTEM DOES. RESULT SET 0.0 AND DIAGNOSTIC IS PRINTED FDL 50 C FDL 60 DOUBLE PRECISION X,DLOG FDL 70 IF (X.GT.0.D0) GO TO 10 FDL 80 CALL ERROR (101) FDL 90 FDLOG=0.D0 FDL 100 GO TO 20 FDL 110 10 FDLOG=DLOG(X) FDL 120 20 RETURN FDL 130 END FDL 140 FUNCTION FDPCON (X) FDP 10 C VERSION 5.00 FDPCON 5/15/70 FDP 20 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 8/16/69. FDP 40 DOUBLE PRECISION X,D FDP 50 Y=X FDP 60 D=Y FDP 70 FDPCON=X+(X-D) FDP 80 RETURN FDP 90 END FDP 100 DOUBLE PRECISION FUNCTION FDSQRT (X) FDQ 10 C VERSION 5.00 FDSQRT 5/15/70 FDQ 20 C FDQ 30 C THIS FUNCTION TRAPS IF ARGUMENT IS NEGATIVE BEFORE SYSTEM DOES. FDQ 40 C RESULT SET = 0.0 AND DIAGNOSTIC IS PRINTED FDQ 50 C FDQ 60 DOUBLE PRECISION X,DSQRT FDQ 70 IF (X.LT.0.D0) GO TO 10 FDQ 80 FDSQRT=DSQRT(X) FDQ 90 RETURN FDQ 100 10 CALL ERROR (101) FDQ 110 FDSQRT =0.D0 FDQ 120 RETURN FDQ 130 END FDQ 140 DOUBLE PRECISION FUNCTION FDSIN(X) FDS 10 C VERSION 5.00 FDSIN 5/15/70 FDS 20 C FDS 30 C THIS FUNITON IS TO TRAP IF ARGUMENT IS GREATER THEN 3.5D16 IN FDS 40 C ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET = 0.0 FDS 50 C FDS 60 DOUBLE PRECISION DSNCOS,DXEXP FDS 70 COMMON /DCONLB/ DSNCOS,DXEXP FDS 80 DOUBLE PRECISION X,DSIN FDS 90 IF (DABS(X).GT.DSNCOS) GO TO 20 FDS 100 FDSIN=DSIN(X) FDS 110 10 RETURN FDS 120 20 CALL ERROR (104) FDS 130 FDSIN=0.D0 FDS 140 GO TO 10 FDS 150 END FDS 160 FUNCTION FEXP2 (B,E) FX2 10 C VERSION 5.00 FEXP2 5/15/70 FX2 20 DATA IEXP/60/ FX2 30 C FX2 40 C THIS FUNCTION IS INCLUDED TO CATCH EXPONENTIATION ERROR BEFORE FX2 50 C SYSTEM DOES FX2 60 C FX2 70 IE=E FX2 80 IF (E.EQ.FLOAT(IE).AND.IE.LT.IEXP) GO TO 20 FX2 90 FEXP2=FEXP(E*FLOG(B)) FX2 100 10 RETURN FX2 110 20 FEXP2=B**IE FX2 120 GO TO 10 FX2 130 END FX2 140 FUNCTION FEXP (X) FEX 10 C VERSION 5.00 FEXP 5/15/70 FEX 20 C FEX 30 C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 88.0 BEFORE FEX 40 C SYSTEM DOES. RESULT SET = 0.0. FEX 50 C FEX 60 COMMON /CONSLB/ XTRIG,XEXP FEX 70 IF (X.GT.XEXP) GO TO 20 FEX 80 FEXP=EXP(X) FEX 90 10 RETURN FEX 100 20 CALL ERROR (102) FEX 110 FEXP=0. FEX 120 GO TO 10 FEX 130 END FEX 140 SUBROUTINE FIXFLO FIX 10 C VERSION 5.00 FIXFLO 5/15/70 FIX 20 COMMON /ABCDEF/ L(48) FIX 30 COMMON /BLOCRC/ NRC,RC(12600) FIX 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NFIX 50 1ARGS,VWXYZ(8),NERROR FIX 60 DIMENSION ARGS(100) FIX 70 EQUIVALENCE (ARGS(1),RC(12501)) FIX 80 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG FIX 90 COMMON/CONLB2/ER,ISIGD FIX 95 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) FIX 100 DIMENSION IB(3) FIX 110 DATA IB(1),IB(2),IB(3)/2H8F,2H8E,2H1P/ FIX 120 C FIX 130 C L2 = 3 FOR FIXED, L2 = 4 FOR FLOAT FIX 140 C L2=12 FOR FLEXIBLE FIX 150 C FIX 160 IF (L2.NE.12) GO TO 5 FIX 170 IOSWT=0 FIX 180 RETURN FIX 190 5 IF (L2.NE.4.OR.NARGS.NE.0) GO TO 8 FIX 192 I=6 FIX 194 GO TO 50 FIX 196 8 IF (NARGS.EQ.1) IF (KIND(1)) 30,40,30 FIX 198 I=10 FIX 200 10 CALL ERROR (I) FIX 210 20 RETURN FIX 220 30 I=20 FIX 230 GO TO 10 FIX 240 40 I=IARGS(1) FIX 250 IF(I.GE.0.AND.I.LE.ISIGD) GO TO 50 FIX 260 I=ISIGD FIX 270 CALL ERROR (237) FIX 280 50 IOSWT=1 FIX 290 IFMTX(5)=L(I+1) FIX 300 IF (L2.EQ.4) GO TO 60 FIX 310 C SET UP FIXED FORMAT FIX 320 IFMTX(3)=IB(1) FIX 330 IFMTX(2)=L(45) FIX 340 RETURN FIX 350 C SET UP FLOATING FORMAT FIX 360 60 IFMTX(3)=IB(2) FIX 370 IFMTX(2)=IB(3) FIX 380 RETURN FIX 390 END FIX 400 SUBROUTINE FLIP FLI 10 C VERSION 5.00 FLIP 5/15/70 FLI 20 COMMON /BLOCRC/ NRC,RC(12600) FLI 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NFLI 40 1ARGS,VWXYZ(8),NERROR FLI 50 DIMENSION ARGS(100) FLI 60 EQUIVALENCE (ARGS(1),RC(12501)) FLI 70 EQUIVALENCE (I,IARGS(100)), (J,IARGS(99)), (K,IARGS(98)), (KK,IARGFLI 80 1S(97)), (M,IARGS(96)), (MM,IARGS(95)), (MMM,IARGS(94)), (N,IARGS(9FLI 90 23)), (NN,IARGS(92)), (A,ARGS(1)) FLI 100 C FLI 110 C FLIP COL ++ INTO COL ++, ++ INTO ++, ETC. FLI 120 C IF NARGS = 0, FLIP THE ENTIRE ARRAY (WORKSHEET). FLI 130 C FLI 140 IF (NARGS.EQ.0) GO TO 40 FLI 150 IF (MOD(NARGS,2).EQ.0) GO TO 30 FLI 160 I=10 FLI 170 10 CALL ERROR (I) FLI 180 20 RETURN FLI 190 30 CALL CHKCOL (I) FLI 200 IF (I.EQ.0) GO TO 40 FLI 210 I=20 FLI 220 GO TO 10 FLI 230 40 IF (NERROR.NE.0) GO TO 20 FLI 240 IF (NRMAX-1) 50,20,60 FLI 250 50 I=9 FLI 260 GO TO 10 FLI 270 60 KK=NRMAX-1 FLI 280 K=KK/2 FLI 290 IF (NARGS.EQ.0) GO TO 90 FLI 300 DO 80 I=1,NARGS,2 FLI 310 M=IARGS(I) FLI 320 N=IARGS(I+1) FLI 330 MM=M+KK FLI 340 NN=N+KK FLI 350 MMM=M+K FLI 360 DO 70 J=M,MMM FLI 370 A=RC(J) FLI 380 RC(N)=RC(MM) FLI 390 RC(NN)=A FLI 400 N=N+1 FLI 410 MM=MM-1 FLI 420 70 NN=NN-1 FLI 430 80 CONTINUE FLI 440 GO TO 20 FLI 450 C FLI 460 C FLIP ENTIRE ARRAY FLI 470 C FLI 480 90 N=1 FLI 490 DO 110 I=1,NCOL FLI 500 M=N FLI 510 MM=M+KK FLI 520 DO 100 J=1,K FLI 530 A=RC(M) FLI 540 RC(M)=RC(MM) FLI 550 RC(MM)=A FLI 560 M=M+1 FLI 570 100 MM=MM-1 FLI 580 110 N=N+NROW FLI 590 GO TO 20 FLI 600 END FLI 610 FUNCTION FLOG (X) FLE 10 C VERSION 5.00 FLOG 5/15/70 FLE 20 C FLOG CHECKS TO SEE IF ARGUMENT IS GREATER THAN 0, BEFORE USING FLE 23 C LIBRARY FUNCTION FOR NATURAL LOG. FLE 25 C IF X IS ZERO OR NEG., RESULT IS = 0 AND DIAGNOSTIC IS PRINTED. FLE 27 IF (X.GT.0.) GO TO 10 FLE 30 CALL ERROR (101) FLE 40 FLOG=0. FLE 50 GO TO 20 FLE 60 10 FLOG=ALOG(X) FLE 70 20 RETURN FLE 80 END FLE 90 FUNCTION FLOG10 (X) FLT 10 C VERSION 5.00 FLOG10 5/15/70 FLT 20 C FLT 30 C THIS FUNCTION CHECKS TO SEE IF X IS ZERO OR NEGATIVE BEFORE USINGFLT 40 C LIBRARY ALOG10. INFORMATIVE DIAGNOSTIC IS PRINTED AND 0 RETURNED.FLT 50 C FLT 60 IF (X.GT.0.0) GO TO 20 FLT 70 CALL ERROR (101) FLT 80 FLOG10=0.0 FLT 90 10 RETURN FLT 100 20 FLOG10=ALOG10(X) FLT 110 GO TO 10 FLT 120 END FLT 130 SUBROUTINE FNEC FNE 10 C VERSION 5.00 FNEC 5/15/70 FNE 20 C THIS SUBROUTINE HANDLES MISC FUNCTION COMMANDS WITH TWO ARGUMENTS,FNE 30 C THE FIRST IS (E) (A CONSTANT, OR COLUMN NUMBER) AND THE SECOND IS FNE 40 C (C) A COLUMN NUMBER FNE 50 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 3/27/70. FNE 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NFNE 70 1ARGS,VWXYZ(8),NERROR FNE 80 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG FNE 90 COMMON /BLOCRC/ NRC,RC(12600) FNE 100 DIMENSION ARGS(100) FNE 110 EQUIVALENCE (ARGS(1),RC(12501)) FNE 120 COMMON /SCRAT/ NS,NS2,A(13500) FNE 130 DOUBLE PRECISION Y,Z FNE 140 C ***** COMMANDS ***** FNE 150 C ERROR (E), (C) L2=18 BY I. STEGUN, 3/25/70.FNE 160 C CERF (E), (C) L2=19 BY I. STEGUN, 3/25/70.FNE 170 C ***** FNE 180 10 IF (NARGS.NE.2) CALL ERROR (10) FNE 190 IF (NRMAX.EQ.0) CALL ERROR (9) FNE 200 CALL ADRESS (1,J1) FNE 210 IF (J1.LT.0) J1=-J1 FNE 220 IF (J1.EQ.0) CALL ERROR (11) FNE 230 CALL ADRESS (2,J2) FNE 240 IF (J2.EQ.0) CALL ERROR (11) FNE 250 IF (J2.LT.0) CALL ERROR (20) FNE 260 IF (NERROR.NE.0) GO TO 70 FNE 270 LL=L2-17 FNE 280 DO 60 I=1,NRMAX FNE 290 IF (KIND(1).EQ.1.AND.I.GT.1) GO TO 50 FNE 300 GO TO (20,30), LL FNE 310 20 CALL ERRINT (DBLE(RC(J1)),Y,Z) FNE 320 X=FDPCON(Y) FNE 330 GO TO 40 FNE 340 30 CALL ERRINT (DBLE(RC(J1)),Z,Y) FNE 350 X=FDPCON(Y) FNE 360 GO TO 40 FNE 370 40 J1=J1+1 FNE 380 50 RC(J2)=X FNE 390 60 J2=J2+1 FNE 400 70 RETURN FNE 410 END FNE 420 SUBROUTINE FNEIC FNC 10 C VERSION 5.00 FNEIC 5/15/70 FNC 20 C THIS SUBROUTINE HANDLES INSTRUCTIONS OF THE FORM (E), (I), (C) FNC 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/21/70 FNC 40 C ***** COMMON ***** FNC 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NFNC 60 1ARGS,VWXYZ(8),NERROR FNC 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG FNC 80 COMMON /BLOCRC/ NRC,RC(12600) FNC 90 DIMENSION ARGS(100) FNC 100 EQUIVALENCE (ARGS(1),RC(12501)) FNC 110 COMMON /SCRAT/ NS,NS2,A(13500) FNC 120 C ***** FNC 130 IF (NRMAX.EQ.0) CALL ERROR (9) FNC 140 IF (NARGS.NE.3) CALL ERROR (10) FNC 150 IF (KIND(2).NE.0) CALL ERROR (20) FNC 160 CALL ADRESS (1,J) FNC 170 IF (J.LT.0) J=-J FNC 180 CALL ADRESS (3,K) FNC 190 IF (J.EQ.0.OR.K.EQ.0) CALL ERROR (11) FNC 200 IF (K.LT.0) CALL ERROR (20) FNC 210 IF (NERROR.NE.0) RETURN FNC 220 N=IARGS(2) FNC 230 DO 10 I=1,NRMAX FNC 240 C ROUND X EQUAL TO (E) TO (I) SIGNIFICANT DIGITS, PUT IN COLUMN (C) FNC 250 C SUBROUTINE TO ROUND. WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/21/68. FNC 260 CALL DHRND (RC(J),N,RC(K)) FNC 270 IF (KIND(1).EQ.0) J=J+1 FNC 280 10 K=K+1 FNC 290 RETURN FNC 300 END FNC 310 SUBROUTINE FNKC FKC 10 C VERSION 5.00 FNKC 5/15/70 FKC 20 C SUBROUTINE TREATS INSTRUCTIONS OF THE FORM (K),(C) FKC 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/22/70. FKC 40 C ***** COMMON ***** FKC 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NFKC 60 1ARGS,VWXYZ(8),NERROR FKC 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG FKC 80 COMMON /BLOCRC/ NRC,RC(12600) FKC 90 DIMENSION ARGS(100) FKC 100 EQUIVALENCE (ARGS(1),RC(12501)) FKC 110 COMMON /SCRAT/ NS,NS2,A(13500) FKC 120 C ***** FKC 130 IF (L1.NE.24.OR.L2.NE.15) RETURN FKC 140 CALL ERROR (235) FKC 150 IF (NRMAX.EQ.0) CALL ERROR (9) FKC 160 IF (NARGS.NE.2) CALL ERROR (10) FKC 170 CALL ADRESS (2,J) FKC 180 IF (J.EQ.0) CALL ERROR (11) FKC 190 IF (J.LT.0) CALL ERROR (20) FKC 200 IF (NERROR.NE.0) RETURN FKC 210 NST=ARGS(1) FKC 220 IF (NST.LE.0) NST=8192.0*ARGS(1)+0.1 FKC 230 IF (KIND(1).EQ.0) NST=IARGS(1) FKC 240 NST=MOD(NST,8192) FKC 250 DO 10 I=1,NRMAX FKC 260 C RNJBK SHOULD BE REPLACED BY MORE RELIABLE AND EFFICIENT GENERATOR.FKC 270 CALL RNJBK (RC(J),NST,NST) FKC 280 10 J=J+1 FKC 290 RETURN FKC 300 END FKC 310 SUBROUTINE FOURIA (Y,A,R,N,KAA) FOU 10 C VERSION 5.00 FOURIA 5/15/70 FOU 20 DOUBLE PRECISION Y(1),R(1),A,AA,AB,AC,BA,BB,AD FOU 30 DOUBLE PRECISION FDCOS,FDSIN FOU 40 M=N/2 FOU 50 K=2*M FOU 60 L=0 FOU 70 IF (N.EQ.K) GO TO 10 FOU 80 L=1 FOU 90 10 AB=N FOU 100 AA=6.28318530717D0/AB FOU 110 A=0.0 FOU 120 R(M)=.0 FOU 130 AC=1. FOU 140 DO 20 I=1,N FOU 150 A=A+Y(I) FOU 160 R(M)=R(M)+AC*Y(I) FOU 170 20 AC=-1.*AC FOU 180 A=A/AB FOU 190 R(M)=R(M)/AB FOU 200 J=M+L-1 FOU 210 KA=M+1 FOU 220 DO 40 K=1,J FOU 230 BA=Y(1) FOU 240 BB=0.0 FOU 250 AC=K FOU 260 AC=AC*AA FOU 270 DO 30 I=2,N FOU 280 AD=I-1 FOU 290 AD=AD*AC FOU 300 BA=BA+Y(I)*FDCOS(AD) FOU 310 30 BB=BB+Y(I)*FDSIN(AD) FOU 320 R(K)=2.0*BA/AB FOU 330 R(KA)=2.*BB/AB FOU 340 40 KA=KA+1 FOU 350 IF (L.EQ.1) GO TO 50 FOU 360 R(KA)=0. FOU 370 50 RETURN FOU 380 END FOU 390 SUBROUTINE FPPT (V11,V12,P10,XA) FPP 10 C VERSION 5.00 FPPT 5/15/70. FPP 20 DIMENSION X(5), P(5) FPP 30 V1=V11 FPP 40 V2=V12 FPP 50 P0=P10 FPP 60 C CALLS PROB AND THEN USES ISOLATE METHOD FOR SOLVING ITERATIVELY FPP 70 IF (V1-1.5) 10,10,20 FPP 80 C USE STUDENT'S T FPP 90 C ONLY GOOD FOR P0=0.05 FPP 100 10 CALL TPCTPT (V2,XA) FPP 110 XA=XA**2.0 FPP 120 GO TO 70 FPP 130 20 IF (V2-1.5) 30,30,40 FPP 140 C ONLY GOOD FOR P0=0.05 FPP 150 C SHOULD USE STUDENT'S T FPP 160 30 XA = 225.0 FPP 170 GO TO 70 FPP 180 C TUKEY APPROXIMATION TO NORMAL PERCENT POINT FPP 190 40 YP=-4.91*(P0**.14-(1.-P0)**.14) FPP 200 C AMS 55 APPROXIMATION 26.5.22 FPP 210 H=2.0/(1.0/(V1-1.0)+1.0/(V2-1.0)) FPP 220 XLMBDA=(YP**2-3.0)/6.0 FPP 230 W=YP*FSQRT(H+XLMBDA)/H FPP 240 IF (V1-V2) 50,60,50 FPP 250 50 W=W-(1.0/(V1-1.0)-1.0/(V2-1.0))*(XLMBDA+0.833333-0.666667/H) FPP 260 C AMS 55 APPROXIMATION 26.6.16 FPP 270 60 XA=FEXP(2.*W) FPP 280 70 XMIN=0.5*XA FPP 290 XMAX=2.0*XA FPP 300 CALL PROB (V1,V2,XMAX,Q) FPP 310 IF (Q.LE.P0) GO TO 80 FPP 320 XA=1.9999*XMAX FPP 330 GO TO 70 FPP 340 80 CALL PROB (V1,V2,XMIN,Q) FPP 350 IF (P0.LE.Q) GO TO 90 FPP 360 XA=0.5001*XMIN FPP 370 GO TO 70 FPP 380 90 X0=XA FPP 390 DO 140 I=1,5 FPP 400 X(I)=XMIN+FLOAT(I-1)*(XMAX-XMIN)/4. FPP 410 100 CALL PROB (V1,V2,X(I),P(I)) FPP 420 110 IF (P0-P(I)) 140,130,120 FPP 430 120 XMAX=X(I) FPP 440 XMIN=X(I-1) FPP 450 GO TO 150 FPP 460 130 XA=X(I) FPP 470 GO TO 160 FPP 480 140 CONTINUE FPP 490 150 XA=(XMIN+XMAX)/2. FPP 500 C EXIT IF EITHER TOLERANCE IS SATISFIED * ABSOLUTE 5E-6, REL. 5E-7 FPP 510 IF (ABS(X0-XA).GT.5.E-6.AND.ABS(X0-XA)/XA.GT.5.E-7) GO TO 90 FPP 520 160 RETURN FPP 530 END FPP 540 SUBROUTINE FPROB FPR 10 C VERSION 5.00 FPROB 5/15/70 FPR 20 C WRITTEN BY S PEAVY 10/13/67 FPR 30 C COMMAND IS AS FOLLOWING FPR 40 C FPROBABILITY V1 $ ,V2 $ , F $ , STORE Q IN COL ++ FPR 50 COMMON /BLOCRC/ NRC,RC(12600) FPR 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NFPR 70 1ARGS,VWXYZ(8),NERROR FPR 80 DIMENSION ARGS(100) FPR 90 EQUIVALENCE (ARGS(1),RC(12501)) FPR 100 IF (NARGS.NE.4) CALL ERROR (10) FPR 110 IF (KIND(NARGS).NE.0) CALL ERROR (3) FPR 120 I1=1 FPR 130 I2=1 FPR 140 I3=1 FPR 150 CALL ADRESS (1,IARGS(1)) FPR 160 IF (IARGS(1)) 10,20,30 FPR 170 10 I1=2 FPR 180 V1=ARGS(1) FPR 190 GO TO 40 FPR 200 20 CALL ERROR (11) FPR 210 30 L=IARGS(1) FPR 220 40 CALL ADRESS (2,IARGS(2)) FPR 230 IF (IARGS(2)) 50,60,70 FPR 240 50 I2=2 FPR 250 V2=ARGS(2) FPR 260 GO TO 80 FPR 270 60 CALL ERROR (11) FPR 280 70 M=IARGS(2) FPR 290 80 CALL ADRESS (3,IARGS(3)) FPR 300 IF (IARGS(3)) 90,100,110 FPR 310 90 I3=2 FPR 320 F=ARGS(3) FPR 330 GO TO 120 FPR 340 100 CALL ERROR (11) FPR 350 110 N=IARGS(3) FPR 360 120 CALL ADRESS (NARGS,K) FPR 370 IF (K.LE.0) CALL ERROR (11) FPR 380 IF (I1+I2+I3.NE.6) GO TO 140 FPR 400 CALL PROB (V1,V2,F,Q) FPR 410 DO 130 I=1,NRMAX FPR 420 RC(K)=1 FPR 430 130 K=K+1 FPR 440 RETURN FPR 450 140 DO 210 I=1,NRMAX FPR 460 GO TO (150,160), I1 FPR 470 150 V1=RC(L) FPR 480 L=L+1 FPR 490 160 GO TO (170,180), I2 FPR 500 170 V2=RC(M) FPR 510 M=M+1 FPR 520 180 GO TO (190,200), I3 FPR 530 190 F=RC(N) FPR 540 N=N+1 FPR 550 200 CALL PROB (V1,V2,F,RC(K)) FPR 560 210 K=K+1 FPR 570 RETURN FPR 580 END FPR 590 SUBROUTINE FRDIST FRD 10 C VERSION 5.00 FRDIST 5/15/70 FRD 20 COMMON/BLOCRC/NRC,RC(12600) FRD 30 COMMON/BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, FRD 40 1NARGS,VWXYZ(8),NERROR FRD 50 DIMENSION ARGS(100) FRD 60 EQUIVALENCE (ARGS(1),RC(12501)) FRD 70 COMMON/BLOCKE/NAME(4),L1,L2,ISRFLG FRD 80 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/25/69. FRD 90 C ***** FORMS OF COMMAND ***** FRD 100 C 1 FREQUENCY OF COLUMN (C), PUT IN COLUMN (C) FRD 110 C 2 FREQUENCY OF COL (C), USE (I) CELLS, PUT IN COLUMN (C) FRD 120 C 3 FREQUENCY OF COL (C), USE (I) CELLS, OF LENGTH (A), PUT IN COL (C)FRD 130 C 4 FREQUENCY OF COL (C), CELLS (I), LENGTH (A), START (A), IN COL (C)FRD 140 C 5 FREQUENCY OF COL (C), LOWER (C), UPPER IN (C), FREQ IN (C) FRD 150 C 7 FREQUENCY OF COL (C), CELLS (I), LENGTH (A), PUT IN (C), (C), (C) FRD 160 C 8 FREQUENCY OF (C), CELLS (I), LENGTH (A), START (A), IN (C),(C),(C)FRD 170 C RESETS NRMAX TO NO. OF CELLS FRD 180 C ***** FRD 190 10 IF (NARGS.GT.1 .AND. NARGS.LT.8) GO TO 100 FRD 200 CALL ERROR (10) FRD 210 RETURN FRD 220 20 CALL ERROR (3) FRD 230 RETURN FRD 240 30 CALL ERROR (11) FRD 250 RETURN FRD 260 100 CALL ADRESS (1,J1) FRD 270 IF (J1) 20,30,110 FRD 280 110 CALL ADRESS (NARGS,J2) FRD 290 IF (J2) 20,30,120 FRD 300 120 NST = 1 FRD 310 LIMIT = 0 FRD 320 C FORM (1) FRD 330 IF (NARGS.EQ.2) GO TO 901 FRD 340 200 KN = IARGS(2) FRD 350 C FORM (3) FRD 360 IF (NARGS.EQ.3) GO TO 902 FRD 370 IF (KIND(3).EQ.0) GO TO 500 FRD 380 CELL = ARGS(3) FRD 390 C FORM (3) FRD 400 IF (NARGS.EQ.4) GO TO 903 FRD 410 400 IF (KIND(4).EQ.0) GO TO 500 FRD 420 NST = 0 FRD 430 STRT = ARGS(4) FRD 440 C FORM (4) FRD 450 IF (NARGS.EQ.5) GO TO 904 FRD 460 C FORMS (5), (6), (7), (8) FRD 470 500 CALL ADRESS (NARGS-2,J3) FRD 480 IF (J3) 20,30,510 FRD 490 510 CALL ADRESS (NARGS-1,J4) FRD 500 IF (J4) 20,30,520 FRD 510 520 LIMIT = 1 FRD 520 JJ = NARGS-3 FRD 530 GO TO (901,902,903,904), JJ FRD 540 901 KN = 0 FRD 550 902 CELL = 0.0 FRD 560 903 STRT = 0.0 FRD 570 904 CALL FREQCY (RC(J1),RC(J2),NRMAX,KN,CELL,NST,STRT,LIMIT, FRD 580 1 RC(J3),RC(J4)) FRD 590 NRMAX=KN FRD 600 RETURN FRD 610 END FRD 620 SUBROUTINE FREQCY (X,F,N,K,C,NSTART,START,LIMITS,XL,XU) FRE 10 C VERSION 5.00 FREQCY 5/15/70 FRE 20 C SUBROUTINE TO CONSTRUCT FREQUENCY DISTRIBUTION IN VECTOR F FOR FRE 30 C VECTOR OF OBSERVATIONS X OF LENGTH N USING K CELLS OF LENGTH C. FRE 40 C IF C=0.0, THEN C IS DETERMINED BY SUBROUTINE. IF BOTH K AND C=0.0,FRE 50 C THEN BOTH K AND C ARE DETERMINED BY THE SUBROUTINE. FRE 60 C IF NSTART=1, START DETERMINED. IF NSTART=0, START IS GIVEN. FRE 70 C IF LIMITS=1, LOWER CELL BOUNDARIES ARE PUT IN XL AND UPPER IN XU. FRE 80 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/25/69. FRE 90 DIMENSION X(1),F(1),XL(1),XU(1) FRE 100 100 IF (K.GT.0) GO TO 200 FRE 110 K = 1.5 + 3.3*FLOG10(FLOAT(N)) FRE 120 K = MAX0 (K,5) FRE 130 200 XMIN=X(1) FRE 140 XMAX=X(1) FRE 150 DO 250 I=1,N FRE 160 IF(X(I).LT.XMIN) XMIN=X(I) FRE 170 IF(X(I).GT.XMAX) XMAX=X(I) FRE 180 250 CONTINUE FRE 190 IF (C) 300,260,300 FRE 200 260 RANGE=XMAX-XMIN FRE 210 C=RANGE/FLOAT(K-1) FRE 220 300 IF (NSTART.EQ.0) GO TO 500 FRE 230 START=XMIN-0.5*C FRE 240 500 DO 510 I=1,K FRE 250 510 F(I)=0.0 FRE 260 DO 520 I=1,N FRE 270 J=(X(I)-START)/C+1.0 FRE 280 520 F(J)=F(J)+1.0 FRE 290 IF (LIMITS.EQ.0) RETURN FRE 300 600 XL(1)=START FRE 310 XU(1)=XL(1)+C FRE 320 DO 610 I=2,K FRE 330 XL(I)=XL(I-1)+C FRE 340 610 XU(I)=XL(I)+C FRE 350 RETURN FRE 360 END FRE 370 FUNCTION FSIN (X) FSI 10 C VERSION 5.00 FSIN 5/15/70 FSI 20 C FSI 30 C THIS FUNCTION IS TO TRAP IF ARGUMENT IS GREATER THAN 3.3E7 IN FSI 40 C ABSOLUTE VALUE BEFORE SYSTEM DOES. RESULT SET = 0.0 FSI 50 C FSI 60 COMMON /CONSLB/ XTRIG,XEXP FSI 70 IF (ABS(X).GT.XTRIG) GO TO 20 FSI 80 FSIN=SIN(X) FSI 90 10 RETURN FSI 100 20 CALL ERROR (104) FSI 110 FSIN=0. FSI 120 GO TO 10 FSI 130 END FSI 140 FUNCTION FSQRT (X) FSQ 10 C VERSION 5.00 FSQRT 5/15/70 FSQ 20 C FSQRT CHECKS X FOR NEGATIVE VALUES. FSQ 23 C IF X.LT. ZOER, RESULT IS ZERO, AND DIAGNOSTIC IS PRINTED. FSQ 25 IF (X.LT.0.) GO TO 20 FSQ 30 FSQRT=SQRT(X) FSQ 40 10 RETURN FSQ 50 20 CALL ERROR (101) FSQ 60 FSQRT=0. FSQ 70 GO TO 10 FSQ 80 END FSQ 90 FUNCTION FTANH (X) FTA 10 C VERSION 5.00 FTANH 5/15/70 FTA 20 C FTA 30 C SINCE TANH FUNCTION USES EXP FUNCTION FTANH CHECKS TO SEE IF THEFTA 40 C ABSOLUTE VALUE OF 2*X IS GREATER THEN XEXP (OR 88.3). IF THISFTA 50 C IS THE CASE, AND ERROR MESSAGE IS PRINTED AND FTANH=0. FTA 60 C FTA 70 COMMON /CONSLB/ XTRIG,XEXP FTA 80 IF (ABS(2.*X).LE.XEXP) GO TO 20 FTA 90 FTANH=0.0 FTA 100 10 RETURN FTA 110 20 FTANH=TANH(X) FTA 120 GO TO 10 FTA 130 END FTA 140 SUBROUTINE FUNCT FUN 10 C VERSION 5.00 FUNCT 5/15/70 FUN 20 COMMON /BLOCRC/NRC,RC(12600) FUN 30 COMMON /BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, FUN 40 1 NARGS,VWXYZ(8),NERROR FUN 50 DIMENSION ARGS(100) FUN 60 EQUIVALENCE (ARGS(1),RC(12501)) FUN 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG FUN 80 COMMON /CONSTS/ PI,E,HALFPI,DEG,RAD,XALOG FUN 90 COMMON /SCRAT/ NS,NS2,A(13500) FUN 100 DIMENSION II(4),KK(4) FUN 110 EQUIVALENCE(II(1),I1),(II(2),I2),(II(3),I3),(II(4),I4) FUN 120 C FUN 130 C THIS SUBROUTINE HANDLES ALL TWO, THREE, AND FOUR ARGUMENT FUNCTIONFUN 140 C IF THE FIRST ARGUMENT IS A CONSTANT, THE FUNCTION IS EVALUATED FUN 150 C ONLY ONCE. FUN 160 C FUN 170 C L2= 1 SIN L2= 2 COS L2= 3 TAN FUN 180 C L2= 4 COT L2= 5 ARCSIN L2= 6 ARCCOS FUN 190 C L2= 7 ARCTAN L2= 8 ARCCOT L2= 9 SIND FUN 200 C L2=10 COSD L2=11 TAND L2=12 COTD FUN 210 C L2=13 ASIND L2=14 ACOSD L2=15 ATAND FUN 220 C L2=16 ACOTD L2=17 SQRT L2=18 EXPONENT FUN 230 C L2=19 NEGEXP L2=20 LOGE L2=21 LOGTEN FUN 240 C L2=22 ANTILO L2=23 SINH L2=24 COSH FUN 250 C L2=25 TANH L2=26 COTH L2=27 ASINH FUN 260 C L2=28 ACOSH L2=29 ATANH L2=30 ACOTH FUN 270 C L2=31 ABSOLU L2=32 INTEGE L2=33 FRACTI FUN 280 C L2=34 SQUARE FUN 290 C FUN 300 IF(NARGS.LT.2.OR.NARGS.GT.4) CALL ERROR (10) FUN 310 IF (NARGS.EQ.3) CALL ERROR (29) FUN 315 DO 30 I=1,NARGS FUN 320 KK(I)=1 FUN 330 CALL ADRESS (I,II(I)) FUN 340 IF(II(I)) 20,10,30 FUN 350 10 CALL ERROR (20) FUN 360 GO TO 30 FUN 370 20 KK(I)=0 FUN 380 II(I)=-II(I) FUN 390 30 CONTINUE FUN 400 IF(KK(NARGS).EQ.0) CALL ERROR (11) FUN 410 IF(NRMAX.LE.0) CALL ERROR(9) FUN 420 IF(NERROR.NE.0) RETURN FUN 430 NR=NRMAX FUN 440 IF(NARGS.EQ.4) GO TO 36 FUN 450 KK(4)=1 FUN 460 I4=I2 FUN 470 IF(NARGS.EQ.3) I4=I3 FUN 480 36 IL=I4 FUN 490 ILL=1 FUN 500 IF(KK(1).EQ.1) GO TO 40 FUN 510 IF(NARGS.EQ.2) NR=1 FUN 520 40 DO 1010 I=1,NR FUN 530 GO TO (50,1005),ILL FUN 535 50 X=RC(I1) FUN 540 GO TO (110,120,130,140,150,160,170,180,190,200, FUN 550 1 210,220,230,240,250,260,270,280,290,300, FUN 560 2 310,320,330,340,350,360,370,380,390,400, FUN 570 3 410,420,430,440),L2 FUN 580 110 X=FSIN(X) FUN 590 GO TO 1000 FUN 600 120 X = FCOS(X) FUN 610 GO TO 1000 FUN 620 130 AX=FCOS(X) FUN 630 IF(AX.NE.0.0) GO TO 135 FUN 640 132 X = 0.0 FUN 650 CALL ERROR (107) FUN 660 GO TO 1000 FUN 670 135 X = FSIN(X)/AX FUN 680 GO TO 1000 FUN 690 140 AX=FSIN(X) FUN 700 IF(AX.EQ.0.0) GO TO 132 FUN 710 X = FCOS(X)/AX FUN 720 GO TO 1000 FUN 730 150 Y=X**2 FUN 740 IF(Y.GT.(.5)) GO TO 151 FUN 750 X=ATAN(X/FSQRT(1.-Y)) FUN 760 GO TO 153 FUN 770 151 Z=X FUN 780 IF(X.NE.0.0) IF (ABS(X)-1.) 154,158,159 FUN 790 X=HALFPI FUN 800 152 IF(L2.EQ.5.OR.L2.EQ.13) X=HALFPI-X FUN 810 153 IF(L2.GT.10) X=DEG*X FUN 820 GO TO 1000 FUN 830 154 YY=1.0 FUN 840 DO 155 J=1,3 FUN 850 Y=X**2 FUN 860 IF(Y.LE.(.5)) GO TO 156 FUN 870 YY=YY+YY FUN 880 155 X=Y+Y-1. FUN 890 Y=X**2 FUN 900 156 X=SIGN(ATAN(FSQRT(1.-Y)/X)/YY,Z) FUN 910 157 IF(Z.LT.0.0) X=PI+X FUN 920 GO TO 152 FUN 930 158 X=0.0 FUN 940 GO TO 157 FUN 950 159 X=0.0 FUN 960 CALL ERROR (103) FUN 970 GO TO 1000 FUN 980 160 GO TO 151 FUN 990 170 X=ATAN(X) FUN1000 GO TO 1000 FUN1010 180 IF(X.EQ.0.0) GO TO 132 FUN1020 X=ATAN(1./X) FUN1030 GO TO 1000 FUN1040 190 X=FSIN(RAD*X) FUN1050 GO TO 1000 FUN1060 200 X=FCOS(RAD*X) FUN1070 GO TO 1000 FUN1080 210 X=X*RAD FUN1090 GO TO 130 FUN1100 220 X=X*RAD FUN1110 GO TO 140 FUN1120 230 GO TO 150 FUN1130 240 GO TO 151 FUN1140 250 X=DEG*ATAN(X) FUN1150 GO TO 1000 FUN1160 260 IF(X.EQ.0.0) GO TO 132 FUN1170 X=DEG*ATAN(1.0/X) FUN1180 GO TO 1000 FUN1190 270 X=FSQRT(X) FUN1200 GO TO 1000 FUN1210 280 X=FEXP(X) FUN1220 GO TO 1000 FUN1230 290 X=FEXP(-X) FUN1240 GO TO 1000 FUN1250 300 X=FLOG(X) FUN1260 GO TO 1000 FUN1270 310 IF(X.GT.0.0) GO TO 315 FUN1280 X=0.0 FUN1290 CALL ERROR (101) FUN1300 GO TO 1000 FUN1310 315 X=FLOG10(X) FUN1320 GO TO 1000 FUN1330 320 IF(X.GT.XALOG) GO TO 325 FUN1340 X=10.**X FUN1350 GO TO 1000 FUN1360 325 X=0.0 FUN1370 CALL ERROR (102) FUN1380 GO TO 1000 FUN1390 330 AX=FTANH(X) FUN1400 GO TO 345 FUN1410 340 AX=1.0 FUN1420 345 Y=FEXP(X) FUN1430 X=.5*(Y+1./Y)*AX FUN1440 GO TO 1000 FUN1450 350 X=FTANH(X) FUN1460 GO TO 1000 FUN1470 360 Y=FTANH(X) FUN1480 IF(Y.EQ.0.0) GO TO 132 FUN1490 X=1.0/Y FUN1500 GO TO 1000 FUN1510 370 X=SIGN(FLOG(ABS(X)+FSQRT(X**2+1.0)),X) FUN1520 GO TO 1000 FUN1530 380 X=FLOG(ABS(X)+FSQRT(X**2-1.0)) FUN1540 GO TO 1000 FUN1550 390 IF(ABS(X).GE.1.0) GO TO 132 FUN1560 X=.5*FLOG((1.+X)/(1.0-X)) FUN1570 GO TO 1000 FUN1580 400 IF(ABS(X).LE.1.0) GO TO 132 FUN1590 X=.5*FLOG((X+1.0)/(X-1.0)) FUN1600 GO TO 1000 FUN1610 410 X=ABS(X) FUN1620 GO TO 1000 FUN1630 420 X=AINT(X) FUN1640 GO TO 1000 FUN1650 430 X=X-AINT(X) FUN1660 GO TO 1000 FUN1670 440 X=X*X FUN1680 1000 XA=X FUN1685 IF(NARGS.EQ.2) GO TO 1007 FUN1690 1005 X=XA*RC(I2)+RC(I3) FUN1695 1007 RC(I4)=X FUN1700 I1=I1+KK(1) FUN1705 I2=I2+KK(2) FUN1710 I3=I3+KK(3) FUN1715 I4=I4+KK(4) FUN1720 IF(I.EQ.1.AND.NARGS.NE.2.AND.KIND(1).EQ.1) ILL=2 FUN1722 1010 CONTINUE FUN1775 IF(KIND(1).EQ.1.AND.NR.EQ.1) CALL VECTOR (RC(IL),IL) FUN1780 RETURN FUN1740 END FUN1750 SUBROUTINE GENER GEN 10 C VERSION 5.00 GENER 5/15/70 GEN 20 COMMON /BLOCRC/ NRC,RC(12600) GEN 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NGEN 40 1ARGS,VWXYZ(8),NERROR GEN 50 DIMENSION ARGS(100) GEN 60 EQUIVALENCE (ARGS(1),RC(12501)) GEN 70 C DELETE BLOCKE GEN 80 C GENERATE GEN 90 C NARGS MUST BE .GE. 4 AND EVEN GEN 100 IF (NARGS.GE.4.AND.MOD(NARGS,2).EQ.0) GO TO 10 GEN 110 CALL ERROR (10) GEN 120 GO TO 90 GEN 130 C GET STORAGE COLUMN ADDRESS GEN 140 10 CALL ADRESS (NARGS,J) GEN 150 IF (J.GT.0) GO TO 20 GEN 160 CALL ERROR (3) GEN 170 GO TO 90 GEN 180 20 IF (NERROR.NE.0) GO TO 90 GEN 190 C CONVERT INTEGERS TO FLOATING POINT GEN 200 DO 30 I=2,NARGS GEN 210 IF (KIND(I-1).EQ.0) ARGS(I-1)=IARGS(I-1) GEN 220 30 CONTINUE GEN 230 RC(J)=ARGS(1) GEN 240 NDROW=J+NROW-1 GEN 250 DO 70 I=4,NARGS,2 GEN 260 IF (ARGS(I-3).GT.ARGS(I-1)) ARGS(I-2)=SIGN(ARGS(I-2),-1.) GEN 270 S=SIGN(1.,ARGS(I-2)) GEN 280 ENDER=ARGS(I-1)-.01*ARGS(I-2) GEN 290 40 J=J+1 GEN 300 RC(J)=RC(J-1)+ARGS(I-2) GEN 310 IF (S*(RC(J)-ENDER)) 50,60,60 GEN 320 C NOT DONE GEN 330 50 IF (J.LT.NDROW) GO TO 40 GEN 340 C EXCEEDED COLUMN LENGTH GEN 350 CALL ERROR (201) GEN 360 GO TO 80 GEN 370 C PASSES GENERATE UPPER BOUND, SET IN UPPER BOUND GEN 380 60 RC(J)=ARGS(I-1) GEN 390 70 CONTINUE GEN 400 80 NRMAX=MAX0(NRMAX,J-NDROW+NROW) GEN 410 90 RETURN GEN 420 END GEN 430 SUBROUTINE GQUAD QUA 10 C VERSION 5.00 GQUAD 5/15/70 QUA 20 C WRITTEN BY DAVID HOGBEN SEL, NBS. 8/18/69. QUA 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NQUA 40 1ARGS,VWXYZ(8),NERROR QUA 50 COMMON /BLOCRC/ NRC,RC(12600) QUA 60 DIMENSION ARGS(100) QUA 70 EQUIVALENCE (ARGS(1),RC(12501)) QUA 80 C DOUBLE PRECISION USED TO AVOID NOISE IN 8TH DIGIT. QUA 100 C SLIGHT NOISE MAY BE LEFT DUE TO CONVERSION FROM DP TO SP QUA 110 DOUBLE PRECISION C,B,BPA,BMA,DELGQ,STORE1,STORE2 QUA 120 C TAKEN FROM SYMBOLIC LISTING PAGE 251 (YELLOW COVER) JULY,1965 QUA 130 C A GOES TO C BECAUSE A DIMENSIONED QUA 140 10 IF (NARGS.EQ.5) GO TO 20 QUA 150 CALL ERROR(10) QUA 160 RETURN QUA 170 C N MUST BE AN EXACT MULTIPLE OF 4 AND LESS THEN NROW QUA 180 20 NGQ=INT(ARGS(1))*KIND(1)+IARGS(1)*(1-KIND(1)) QUA 190 IF (MOD(NGQ,4).EQ.0.AND.NGQ.GT.0) GO TO 50 QUA 200 30 CALL ERROR (3) QUA 210 RETURN QUA 220 40 CALL ERROR (10) QUA 230 RETURN QUA 240 50 IF (NGQ.GT.NROW) GO TO 30 QUA 250 C RESET NRMAX IF NECESSARY QUA 260 NRMAX=MAX0(NGQ,NRMAX) QUA 270 CALL ADRESS (4,JPGQ) QUA 280 IF (JPGQ) 30,40,60 QUA 290 60 JPGQ=JPGQ-1 QUA 300 CALL ADRESS (5,JWGQ) QUA 310 IF (JWGQ) 30,40,70 QUA 320 70 JWGQ=JWGQ-1 QUA 330 IF (NERROR.NE.0) RETURN QUA 340 C=ARGS(2)*FLOAT(KIND(2))+FLOAT(IARGS(2)*(1-KIND(2))) QUA 350 B=ARGS(3)*FLOAT(KIND(3))+FLOAT(IARGS(3)*(1-KIND(3))) QUA 360 DELGQ=NGQ QUA 370 DELGQ=4.D0*(B-C)/DELGQ QUA 380 DO 80 I=1,NGQ,4 QUA 390 B=C+DELGQ QUA 400 BPA=(B+C)/2.D0 QUA 410 BMA=(B-C)/2.D0 QUA 420 K1=I+JPGQ QUA 430 K2=I+JWGQ QUA 440 STORE1=-.861136311594053D0*BMA QUA 450 STORE2=-.339981043584856D0*BMA QUA 460 RC(K1)=FDPCON(STORE1+BPA) QUA 470 RC(K1+1)=FDPCON(STORE2+BPA) QUA 480 RC(K1+2)=FDPCON(BPA-STORE2) QUA 490 RC(K1+3)=FDPCON(BPA-STORE1) QUA 500 RC(K2)=FDPCON(.34785845137454D0*BMA) QUA 510 RC(K2+1)=FDPCON(.65214515482546D0*BMA) QUA 520 RC(K2+2)=RC(K2+1) QUA 530 RC(K2+3)=RC(K2) QUA 540 80 C=B QUA 550 RETURN QUA 560 END QUA 570 SUBROUTINE HDIAG (A,N,IEGEN,U,COL,VECTOR,NROW,H) HDI 10 C VERSION 5.00 HDIAG 5/15/70 HDI 20 DIMENSION A(NROW,1), H(54,54), U(54,54), X(54), IQ(54), COL(1), VEHDI 30 1CTOR(NROW,1), IEGEN(2) HDI 40 C MIHDI3, FORTRAN II DIAGONALIZATION OF A REAL SYMMETRIC MATRIX BY HDI 50 C THE JACOBI METHOD. HDI 60 C MAY 19, 1959 HDI 70 C CALLING SEQUENCE FOR DIAGONALIZATION HDI 80 C CALL HDIAG( H, N, IEGEN, U, NR) HDI 90 C WHERE H IS THE ARRAY TO BE DIAGNOALIZED. HDI 100 C N IS THE ORDER OF THE MATRIX, H. HDI 110 C HDI 120 C IEGEN MUST BE SET UNEQUAL TO ZERO IF ONLY EIGENVALUES ARE HDI 130 C TO BE COMPUTED. HDI 140 C IEGEN MUST BE SET EQUAL TO ZERO IF EIGENVALUES AND EIGENVECTORS HDI 150 C ARE TO BE COMPUTED. HDI 160 C HDI 170 C U IS THE UNITARY MATRIX USED FOR FORMATION OF THE EIGENVECTORS. HDI 180 C HDI 190 C NR IS THE NUMBER OF ROTATIONS. HDI 200 C HDI 210 C A DIMENSION STATEMENT MUST BE INSERTED IN THE SUBROUTINE. HDI 220 C DIMENSION H(N,N), U(N,N), X(N), IQ(N) HDI 230 C HDI 240 C HDI 250 C THE SUBROUTINE OPERATES ONLY ON THE ELEMENTS OF H THAT ARE TO THE HDI 260 C RIGHT OF THE MAIN DIAGONAL. THUS, ONLY A TRIANGULAR HDI 270 C SECTION NEED BE STORED IN THE ARRAY H. HDI 280 C HDI 290 C HDI 300 DO 10 I=1,N HDI 310 DO 10 J=1,N HDI 320 H(I,J)=A(I,J) HDI 330 10 CONTINUE HDI 340 IF (IEGEN(1)) 60,20,60 HDI 350 20 DO 50 I=1,N HDI 360 DO 50 J=1,N HDI 370 IF (I-J) 40,30,40 HDI 380 30 U(I,J)=1.0 HDI 390 GO TO 50 HDI 400 40 U(I,J)=0. HDI 410 50 CONTINUE HDI 420 C HDI 430 60 NR=0 HDI 440 IF (N-1) 440,440,70 HDI 450 C HDI 460 C SCAN FOR LARGEST OFF DIAGONAL ELEMENT IN EACH ROW HDI 470 C X(I) CONTAINS LARGEST ELEMENT IN ITH ROW HDI 480 C IQ(I) HOLDS SECOND SUBSCRIPT DEFINING POSITION OF ELEMENT HDI 490 C HDI 500 70 NMI1=N-1 HDI 510 DO 90 I=1,NMI1 HDI 520 X(I)=0. HDI 530 IPL1=I+1 HDI 540 DO 90 J=IPL1,N HDI 550 IF (X(I)-ABS(H(I,J))) 80,80,90 HDI 560 80 X(I)=ABS(H(I,J)) HDI 570 IQ(I)=J HDI 580 90 CONTINUE HDI 590 C HDI 600 C SET INDICATOR FOR SHUT-OFF.RAP=2**-27,NR=NO. OF ROTATIONS HDI 610 HDTEST=1.0E37 HDI 620 RAP=7.45058059E-9 HDI 630 C HDI 640 C FIND MAXIMUM OF X(I) S FOR PIVOT ELEMENT AND HDI 650 C TEST FOR END OF PROBLEM HDI 660 C HDI 670 100 DO 130 I=1,NMI1 HDI 680 IF (I-1) 120,120,110 HDI 690 110 IF (XMAX-X(I)) 120,130,130 HDI 700 120 XMAX=X(I) HDI 710 IPIV=I HDI 720 JPIV=IQ(I) HDI 730 130 CONTINUE HDI 740 C HDI 750 C IS MAX. X(I) EQUAL TO ZERO, IF LESS THEN HDTEST, REVISE HDTEST HDI 760 IF (XMAX) 440,440,140 HDI 770 140 IF (HDTEST) 160,160,150 HDI 780 150 IF (XMAX-HDTEST) 160,160,190 HDI 790 160 HDIMIN=ABS(H(1,1)) HDI 800 DO 180 I=2,N HDI 810 IF (HDIMIN-ABS(H(I,I))) 180,180,170 HDI 820 170 HDIMIN=ABS(H(I,I)) HDI 830 180 CONTINUE HDI 840 C HDI 850 HDTEST=HDIMIN*RAP HDI 860 C HDI 870 C RETURN IF MAX.H(I,J)LESS THAN(2**-27)ABSF(H(K,K)-MIN) HDI 880 IF (HDTEST-XMAX) 190,440,440 HDI 890 190 NR=NR+1 HDI 900 C HDI 910 C COMPUTE TANGENT, SINE AND COSINE,H(I,I),H(J,J) HDI 920 TANG=SIGN(2.0,(H(IPIV,IPIV)-H(JPIV,JPIV)))*H(IPIV,JPIV)/(ABS(H(IPIHDI 930 1V,IPIV)-H(JPIV,JPIV))+FSQRT((H(IPIV,IPIV)-H(JPIV,JPIV))**2+4.0*H(IHDI 940 2PIV,JPIV)**2)) HDI 950 COSINE=1./FSQRT(1.0+TANG**2) HDI 960 SINE=TANG*COSINE HDI 970 HII=H(IPIV,IPIV) HDI 980 H(IPIV,IPIV)=COSINE**2*(HII+TANG*(2.*H(IPIV,JPIV)+TANG*H(JPIV,JPIVHDI 990 1))) HDI1000 H(JPIV,JPIV)=COSINE**2*(H(JPIV,JPIV)-TANG*(2.*H(IPIV,JPIV)-TANG*HIHDI1010 1I)) HDI1020 H(IPIV,JPIV)=0. HDI1030 C HDI1040 C PSEUDO RANK THE EIGENVALUES HDI1050 C ADJUST SINE AND COS FOR COMPUTATION OF H(IK) AND U(IK) HDI1060 IF (H(IPIV,IPIV)-H(JPIV,JPIV)) 200,210,210 HDI1070 200 HTEMP=H(IPIV,IPIV) HDI1080 H(IPIV,IPIV)=H(JPIV,JPIV) HDI1090 H(JPIV,JPIV)=HTEMP HDI1100 C RECOMPUTE SINE AND COS HDI1110 HTEMP=SIGN(1.0,-SINE)*COSINE HDI1120 COSINE=ABS(SINE) HDI1130 SINE=HTEMP HDI1140 210 CONTINUE HDI1150 C HDI1160 C INSPECT THE IQS BETWEEN I+1 AND N-1 TO DETERMINE HDI1170 C WHETHER A NEW MAXIMUM VALUE SHOULD BE COMPUTED SINCE HDI1180 C THE PRESENT MAXIMUM IS IN THE I OR J ROW. HDI1190 C HDI1200 DO 280 I=1,NMI1 HDI1210 IF (I-IPIV) 230,280,220 HDI1220 220 IF (I-JPIV) 230,280,230 HDI1230 230 IF (IQ(I)-IPIV) 240,250,240 HDI1240 240 IF (IQ(I)-JPIV) 280,250,280 HDI1250 250 K=IQ(I) HDI1260 HTEMP=H(I,K) HDI1270 H(I,K)=0. HDI1280 IPL1=I+1 HDI1290 X(I)=0. HDI1300 C HDI1310 C SEARCH IN DEPLETED ROW FOR NEW MAXIMUM HDI1320 C HDI1330 DO 270 J=IPL1,N HDI1340 IF (X(I)-ABS(H(I,J))) 260,260,270 HDI1350 260 X(I)=ABS(H(I,J)) HDI1360 IQ(I)=J HDI1370 270 CONTINUE HDI1380 H(I,K)=HTEMP HDI1390 280 CONTINUE HDI1400 C HDI1410 X(IPIV)=0. HDI1420 X(JPIV)=0. HDI1430 C HDI1440 C CHANGE THE OTHER ELEMENTS OF H HDI1450 C HDI1460 DO 410 I=1,N HDI1470 C HDI1480 IF (I-IPIV) 290,410,330 HDI1490 290 HTEMP=H(I,IPIV) HDI1500 H(I,IPIV)=COSINE*HTEMP+SINE*H(I,JPIV) HDI1510 IF (X(I)-ABS(H(I,IPIV))) 300,310,310 HDI1520 300 X(I)=ABS(H(I,IPIV)) HDI1530 IQ(I)=IPIV HDI1540 310 H(I,JPIV)=-SINE*HTEMP+COSINE*H(I,JPIV) HDI1550 IF (X(I)-ABS(H(I,JPIV))) 320,410,410 HDI1560 320 X(I)=ABS(H(I,JPIV)) HDI1570 IQ(I)=JPIV HDI1580 GO TO 410 HDI1590 C HDI1600 330 IF (I-JPIV) 340,410,370 HDI1610 340 HTEMP=H(IPIV,I) HDI1620 H(IPIV,I)=COSINE*HTEMP+SINE*H(I,JPIV) HDI1630 IF (X(IPIV)-ABS(H(IPIV,I))) 350,360,360 HDI1640 350 X(IPIV)=ABS(H(IPIV,I)) HDI1650 IQ(IPIV)=I HDI1660 360 H(I,JPIV)=-SINE*HTEMP+COSINE*H(I,JPIV) HDI1670 IF (X(I)-ABS(H(I,JPIV))) 320,410,410 HDI1680 C HDI1690 370 HTEMP=H(IPIV,I) HDI1700 H(IPIV,I)=COSINE*HTEMP+SINE*H(JPIV,I) HDI1710 IF (X(IPIV)-ABS(H(IPIV,I))) 380,390,390 HDI1720 380 X(IPIV)=ABS(H(IPIV,I)) HDI1730 IQ(IPIV)=I HDI1740 390 H(JPIV,I)=-SINE*HTEMP+COSINE*H(JPIV,I) HDI1750 IF (X(JPIV)-ABS(H(JPIV,I))) 400,410,410 HDI1760 400 X(JPIV)=ABS(H(JPIV,I)) HDI1770 IQ(JPIV)=I HDI1780 410 CONTINUE HDI1790 C HDI1800 C TEST FOR COMPUTATION OF EIGENVECTORS HDI1810 C HDI1820 IF (IEGEN(1)) 100,420,100 HDI1830 420 DO 430 I=1,N HDI1840 HTEMP=U(I,IPIV) HDI1850 U(I,IPIV)=COSINE*HTEMP+SINE*U(I,JPIV) HDI1860 430 U(I,JPIV)=-SINE*HTEMP+COSINE*U(I,JPIV) HDI1870 GO TO 100 HDI1880 440 IF (IEGEN(2)-2) 450,470,450 HDI1890 450 DO 460 I=1,N HDI1900 COL(I)=H(I,I) HDI1910 460 CONTINUE HDI1920 IF (IEGEN(2).NE.3) GO TO 490 HDI1930 470 DO 480 J=1,N HDI1940 DO 480 I=1,N HDI1950 VECTOR(I,J)=U(I,J) HDI1960 480 CONTINUE HDI1970 490 RETURN HDI1980 END HDI1990 SUBROUTINE HEADS (LOC,NOO,IN,IO) HEA 10 C VERSION 5.00 HEADS 5/15/70 HEA 20 C REWRITTEN BY S PEAVY 8/8/69 HEA 30 C HEA 40 C THIS SUBROUTINE INSERTS HEADING (IF AVAILABE) OVER THE COLUMNS HEA 50 C WHEN NO FORMAT IS SPECIFIED HEA 60 C HEA 70 C LOC LOCATION WHERE COL NUMBERS ARE HEA 80 C NOO NO OF COLUMN HEADINGS TO LOOK FOR. NOO LESS THEN OR = 8. HEA 90 C IN IF IN =0 NEW HEADINGS HEA 100 C IF IN =1 PRINT OUT HEADING FROM RREVIOUS PAGE HEA 110 C HEA 120 C IF A HEADING EXISTS THE 12 CHARACTER HEADING WILL BE PRINTED. HEA 130 C OTHERWISE THE HEADING COLUMN XXXX IS TO BE USED WHERE XXXX IS THE HEA 140 C NUMBER CONVERTED FOR DECIMAL PRINTOUT. THE HEADINGS ARE PRINTED HEA 150 C OVER THE DATA WHICH IS IF FORMAT 1PBE15.6 HEA 160 C HEA 170 C IO =0 PRINT HEADINGS HEA 180 C IO NOT =0 DO NOT PRINT HEADINGS HEA 190 C HEA 200 COMMON /ABCDEF/ L(48) HEA 210 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH HEA 220 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) HEA 230 DIMENSION LOC(1) HEA 240 DIMENSION ICOLHD(7) HEA 250 DATA ICOLHD(1),ICOLHD(2),ICOLHD(3),ICOLHD(4),ICOLHD(5),ICOLHD(6),IHEA 260 1COLHD(7)/1HC,1HO,1HL,1HU,1HM,1HN,1H / HEA 270 NO=NOO HEA 280 IF (NO.GT.8) NO=8 HEA 290 IF (IN.NE.0) GO TO 80 HEA 300 IR=1 HEA 310 DO 70 I=1,NO HEA 320 CALL PREPAK (5,IND,I,LOC(I),LHEAD(IR)) HEA 330 IF (IND.NE.0) GO TO 10 HEA 340 IR=IR+12 HEA 350 GO TO 70 HEA 360 10 DO 20 IS=1,7 HEA 370 LHEAD(IR)=ICOLHD(IS) HEA 380 20 IR=IR+1 HEA 390 K=LOC(I) HEA 400 KC=1000 HEA 410 KD=0 HEA 420 DO 60 IS=1,4 HEA 430 KA=K/KC HEA 440 IF (KA.NE.0) GO TO 30 HEA 450 IF (KD.NE.0) GO TO 40 HEA 460 LHEAD(IR)=L(45) HEA 470 GO TO 50 HEA 480 30 KD=1 HEA 490 40 KAP=KA+1 HEA 500 LHEAD(IR)=L(KAP) HEA 510 50 IR=IR+1 HEA 520 K=K-KA*KC HEA 530 60 KC=KC/10 HEA 540 LHEAD(IR)=L(45) HEA 550 IR=IR+1 HEA 560 70 CONTINUE HEA 570 80 IF (IO.NE.0) RETURN HEA 580 IS=NO*12 HEA 590 WRITE (IPRINT,90) (LHEAD(I),I=1,IS) HEA 600 RETURN HEA 610 C HEA 620 90 FORMAT (8(3X,12A1)) HEA 630 END HEA 640 SUBROUTINE HISTGM HIS 10 C VERSION 5.00 HISTGM 5/15/70 HIS 20 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/24/69. HIS 30 COMMON/ABCDEF/L(48) HIS 40 COMMON/BLOCRC/NRC,RC(12600) HIS 50 COMMON/BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX, HIS 60 1 NROW,NCOL,NARGS,VWXYZ(8),NERROR HIS 70 DIMENSION ARGS(100) HIS 80 EQUIVALENCE( ARGS(1), RC(12501)) HIS 90 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG HIS 100 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH HIS 110 COMMON/SCRAT/NS,NS2,A(13500) HIS 120 C HISTOGRAM FOR MIDPOINTS IN COLUMN (C), FREQUENCIES IN COLUMN (C) HIS 130 C NHISTOGRAM (C), (C) L2=2 DOES NOT CALL NEW PAGE OR PRINT BLANK HIS 140 C LINE BETWEEN CELLS OR HEADING. HIS 150 L2=L2-7 HIS 160 10 IF (NARGS.EQ.2) GO TO 20 HIS 170 CALL ERROR (10) HIS 180 RETURN HIS 190 20 CALL ADRESS (1,J1) HIS 200 IF (J1) 30,40,50 HIS 210 30 CALL ERROR (3) HIS 220 RETURN HIS 230 40 CALL ERROR (11) HIS 240 RETURN HIS 250 50 CALL ADRESS (2,J2) HIS 260 IF (J2) 30,40,60 HIS 270 60 IF (NRMAX.GT.0) GO TO 70 HIS 280 CALL ERROR (9) HIS 290 RETURN HIS 300 70 IF (NERROR.NE.0) RETURN HIS 310 80 FORMAT (// 25X,35HHISTOGRAM FOR FREQUENCIES IN COLUMN,I5,22H, MID-HIS 320 1POINTS IN COLUMN,I5//3X,10HMID-POINTS,7X,9HFREQUENCY/) HIS 330 85 FORMAT (1X,14A1,2X,I5,3X, 95A1) HIS 340 90 FORMAT (25X, 95A1) HIS 350 100 CALL RFORMT (RC(J1),NRMAX,8,NW1,NDEC1,13,A(1),A(1),0,0) HIS 360 NBLANK = 15-NW1 HIS 370 IF (L2.EQ.2) GO TO 110 HIS 380 CALL PAGE (4) HIS 390 WRITE (IPRINT,80) IARGS(1),IARGS(2) HIS 400 110 LOC1=J1 HIS 410 LOC2=J2 HIS 420 DO 200 I=1,NRMAX HIS 430 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,RC(LOC1),A(1),NBLANK,1) HIS 440 LFREQ = RC(LOC2) + 0.001 HIS 450 IF (LFREQ.GT.0) GO TO 140 HIS 460 WRITE (IPRINT,85) (A(I1),I1=2,15),LFREQ HIS 470 GO TO 150 HIS 480 140 I2END = MIN0 (LFREQ,95) HIS 490 WRITE (IPRINT,85) (A(I1),I1=2,15),LFREQ,(L(40),I2=1,I2END) HIS 500 IF (LFREQ.LE.95) GO TO 150 HIS 510 I3END = LFREQ-95 HIS 520 WRITE (IPRINT,90) (L(40),I3=1,I3END) HIS 530 150 LOC1 = LOC1+1 HIS 540 200 LOC2 = LOC2+1 HIS 550 RETURN HIS 560 END HIS 570 SUBROUTINE IFS IFS 10 C VERSION 5.00 IFS 5/15/70 IFS 20 COMMON /BLOCRC/ NRC,RC(12600) IFS 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NIFS 40 1ARGS,VWXYZ(8),NERROR IFS 50 DIMENSION ARGS(100) IFS 60 EQUIVALENCE (ARGS(1),RC(12501)) IFS 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG IFS 80 COMMON /BLOCKX/ INDEX(6,8),LEVEL IFS 90 DIMENSION II(3),K(3),NNN(7) IFS 100 EQUIVALENCE (I1,II(1)), (I2,II(2)), (I3,II(3)) IFS 110 LOGICAL TWOARG IFS 120 C IFS 130 C THIS COMMAND MAY APPEAR ONLY AS A STORED COMMAND. IFS 140 C IFS 150 C IFS 160 C IFLT, IFEQ, IFGE, IFNE, IFLE CORRESPND TO L2 = 9, 14 IFS 170 C COMPARE L2 = 15 IFS 175 C IFS 180 C COMMANDS MAY HAVE 2 OR 3 ARGUMENTS (ONLY IFEQ AND IFNE MAY HAVE 3)IFS 190 C ANY ARGUMENT MAY BE OF ANY TYPE, COLUMN NUMBER OR CONSTANT. IFS 200 C COMPARE MUST HAVE 3 ARGUMENTS IFS 205 C IFS 210 C IN COMPARE THE TEST IF FOR RELATIVE ERROR AND GOES IFS 220 C IFS 230 C I ARG1-ARG2 I I I IFS 240 C I --------- I .LT. I ARG3 I IFS 250 C I ARG2 I I I IFS 260 C IFS 270 C IF ARG2 OR ARG1 IS 0., THEN ABSOLUTE ERROR WILL BE COMPUTED IFS 272 C ABS(ARG2-ARG1) .LT. ARG3 AND INFORMATIVE DIAGNOSTIC IFS 273 C WILL BE PRINTED. IFS 278 C IFS 280 C IF IFEQ AND IFNE CONTAIN A THRID ARGUMENT (TOLERANCE) ABSOLUTE IFS 282 C ERROR WILL BE COMPUTED IFS 284 C ABS(ARG1-ARG2) .LT. ABS (ARG3) IFS 286 C A GIVEN TOLERANCE IS IGNORED ON IFLT, IFLE, IFGT, IFGE IFS 290 C EXAMPLES OF HOW COMMANDS READ. IFS 300 C IFLT 8.32 LT EVERY ENTRY OF COL 34, CONDITION IS TRUE IFS 310 C IFGE EACH ELEM COL 1 .GE. CORRESP. ELEM. COL 5, COND. IS TRUE IFS 320 C IFEQ 2. .EQ. 5. CONDITION TRUE (USEFUL WHEN INCREMENTING ARGS. ) IFS 330 C IFS 340 C IF CONDITION IS FALSE, NO ACTION IS TAKEN. IFS 350 C IF CONDITION IS TRUE, THERE ARE TWO POSSIBILITIES.. IFS 360 C 1. IF THE TEST COMMAND IS THE LAST ONE IN THE REPEAT LOOP IFS 370 C CURRENTLY BEING EXECUTED, THE LOOP IS TERMINATED (DROPPED IFS 380 C BACK TO THE NEXT OUTER LEVEL IF MORE THAN ONE LEVEL DEEP). IFS 390 C 2. IF THE TEST COMMAND IS NOT THE LAST ONE, ALL THAT HAPPENS IS IFS 400 C THAT THE REST OF THE LOOP IS NOT PERFORMED. THAT IS, IF THE IFS 410 C LOOP COUNTER HAS NOT REACHED ITS UPPER LIMIT, IT IS ADVANCED IFS 420 C ONE AND THE LOOP IS BEGUN FROM THE TOP AGAIN. IFS 430 C IFS 440 IF (LEVEL.GT.0) GO TO 10 IFS 450 CALL ERROR (21) IFS 460 GO TO 120 IFS 470 10 IF(NARGS.EQ.2) IF(L2-15) 40,150,40 IFS 480 IF (NARGS.EQ.3) GO TO 30 IFS 490 CALL ERROR (10) IFS 500 GO TO 120 IFS 510 20 CALL ERROR (11) IFS 520 GO TO 120 IFS 530 30 IF(L2.EQ.10.OR.L2.EQ.13.OR.L2.EQ.15) GO TO 40 IFS 540 CALL ERROR (212) IFS 550 NARGS=2 IFS 560 40 DO 60 I=1,NARGS IFS 570 CALL ADRESS (I,II(I)) IFS 580 IF (II(I)) 50,20,60 IFS 590 50 II(I)=-II(I) IFS 600 60 K(I)=1-KIND(I) IFS 610 IF(NRMAX.NE.0.OR.KIND(1) +KIND(2).EQ.2) IF (NERROR) 120,65,120 IFS 615 CALL ERROR (9) IFS 620 GO TO 120 IFS 630 65 NNN(4)=0 IFS 640 NNN(5)=0 IFS 650 NNN(6)=0 IFS 660 TWOARG=NARGS.EQ.2 IFS 670 DO 110 I=1,NRMAX IFS 680 IF (TWO ARG) IF (RC(I1)-RC(I2)) 75,77,80 IFS 685 C CHECK EQ,NE WITHIN BOUNDS IFS 690 T=ABS(RC(I1)-RC(I2)) IFS 692 IF(L2.NE.15) GO TO 66 IFS 694 IF(RC(I1).NE.0.0.AND.RC(I2).NE.0.0) GO TO 63 IFS 696 CALL ERROR (108) IFS 698 GO TO 66 IFS 700 63 T=ABS(T/RC(I2)) IFS 702 66 IF(T-ABS(RC(I3)))70,80,80 IFS 704 70 NNN(5)=NNN(5)+1 IFS 710 GO TO 90 IFS 720 C CHECK IFS WITHOUT BOUNDS IFS 730 75 NNN(4)=NNN(4)+1 IFS 740 GO TO 100 IFS 750 77 NNN(5)=NNN(5)+1 IFS 760 GO TO 100 IFS 770 80 NNN(6)=NNN(6)+1 IFS 780 90 I3=I3+K(3) IFS 790 100 I1=I1+K(1) IFS 800 110 I2=I2+K(2) IFS 810 NNN(1)=NNN(5)+NNN(6) IFS 820 NNN(2)=NNN(4)+NNN(6) IFS 830 NNN(7)=NNN(2) IFS 835 NNN(3)=NNN(4)+NNN(5) IFS 840 IF(NNN(L2-8).EQ.0) IF(INDEX(2,LEVEL)-INDEX(3,LEVEL)) 130,130,140 IFS 845 120 RETURN IFS 850 C IFS 860 C IF-COMMAND NOT AT END OF PERFORM LOOP, ADVANCE LOOP COUNT. IFS 870 C IFS 880 130 INDEX(2,LEVEL)=INDEX(3,LEVEL)+1 IFS 890 GO TO 120 IFS 900 C IFS 910 C IF-COMMAND IS AT END OF PERFORM LOOP, TERMINATE LOOP. IFS 920 C IFS 930 140 LEVEL=LEVEL-1 IFS 940 GO TO 120 IFS 950 150 CALL ERROR (10) IFS 960 RETURN IFS 970 END IFS 980 SUBROUTINE INFERR(I) INF 10 C VERSION 5.00 INFERR 5/15/70 INF 20 C INFORMATIVE DIAGNOSTICS 200 AND UP INF 30 COMMON/BLOCKC/KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST INF 40 COMMON/CONLB2/ER,ISIGD INF 50 ISCRUN=ISCRAT INF 60 WRITE(ISCRUN,500) INF 70 500 FORMAT(/41H* INFORMATIVE DIAGNOSTIC IN ABOVE COMMAND,43X) INF 80 II=I-200 INF 90 GO TO (401, 402, 403, 404, 405, 406, 407, 408, 409, 410, 411, 412,INF 100 1 413,414,415,416,417,418,419,420, INF 110 2 421,422,423,424,425,426,427,428,429,430,431,432,433,434,435, INF 105 3 436,437),II INF 110 401 WRITE(ISCRUN,201) INF 120 201 FORMAT(52H* TOO MUCH DATA IN SET, READ OR GENERATE, SPILL LOST, INF 130 132X) INF 140 GO TO 900 INF 150 402 WRITE(ISCRUN,202) INF 160 202 FORMAT(61H* COMMAND NOT ALLOWED IN REPEAT MODE. EXECUTED BUT NOT SINF 170 1TORED,23X) INF 180 GO TO 900 INF 190 403 WRITE( ISCRUN, 203) INF 200 203 FORMAT(61H* VALUE REQUESTED IN SHORTEN, ACOALESCE OR AAVERAGE NOT INF 210 1FOUND,23X) INF 220 GO TO 900 INF 230 404 WRITE( ISCRUN, 204) INF 240 204 FORMAT(32H* BAD HEAD. COLUMN GT 50 OR NO /,52X) INF 250 GO TO 900 INF 260 405 WRITE( ISCRUN, 205) INF 270 205 FORMAT(68H* THIS COMMAND WAS NOT EXECUTED BECAUSE ITS MEANING WAS INF 280 1QUESTIONABLE,16X) INF 290 GO TO 900 INF 300 406 WRITE(ISCRUN,206) INF 310 206 FORMAT (24H* F LESS THAN 0, SET = 0,60X) INF 320 GO TO 900 INF 330 407 WRITE(ISCRUN,207) INF 340 207 FORMAT(24H* NU1 OR NU2 LESS THAN 1,60X) INF 350 GO TO 900 INF 360 408 WRITE(ISCRUN,208) INF 370 208 FORMAT(33H* NU1 OR NU2 TRUNCATED TO INTEGER,51X) INF 380 GO TO 900 INF 390 409 WRITE(ISCRUN,209) INF 400 209 FORMAT(34H* IMPROPER TITLE NUMBER, ASSUMED 1,50X) INF 410 GO TO 900 INF 420 410 WRITE(ISCRUN,210) INF 430 210 FORMAT(54H* NO OF ROWS NOT = TO COLS. MATRIX USED LARGEST SQUARE, INF 440 1 20X) INF 450 GO TO 900 INF 460 411 WRITE(ISCRUN,211) INF 470 211 FORMAT(52H* ASTERISK STRING IMPLYING ,THRU, INCORRECT, IGNORED, INF 480 1 32X) INF 490 GO TO 900 INF 500 412 WRITE(ISCRUN,212) INF 510 212 FORMAT(43H* UNNECESSAYY ARGUMENTS IN COMMAND IGNORED.,41X) INF 520 GO TO 900 INF 530 413 WRITE(ISCRUN,213) INF 540 213 FORMAT(27H* PARTIAL STORAGE OF MATRIX,57X) INF 550 GO TO 900 INF 560 414 WRITE (ISCRUN,214) INF 570 214 FORMAT(28H***INSUFFICIENT SCRATCH AREA,56X) INF 580 GO TO 900 INF 585 415 WRITE (ISCRUN,215) INF 590 215 FORMAT(48H* NRMAX IS NOT LARGE ENOUGH TO ALLOW ITERATION ,36X) INF 600 GO TO 900 INF 610 416 WRITE (ISCRUN,216) INF 620 216 FORMAT(68H* 1ST COLUMN OF ISETUP OR ISOLATE IS NOT MONOTONIC OR ISINF 630 1 CONSTANT. ,16X) INF 640 GO TO 900 INF 650 417 WRITE (ISCRUN,217) INF 660 217 FORMAT (34H* ITERATION HAS FOUND NO VALUES. ,50X) INF 670 GO TO 900 INF 680 418 WRITE (ISCRUN,218) INF 690 218 FORMAT(81H* WORKSHEET IS TOO SHORT TO ACCOMMODATE ALL THE VALUES GINF 700 1ENERATED BY THIS COMMAND. ,3X ) INF 710 GO TO 900 INF 720 419 WRITE(ISCRUN,219) INF 730 219 FORMAT (30H* MAXMIN HAS FOUND NO EXTREMA. ,54X) INF 740 GO TO 900 INF 750 420 WRITE (ISCRUN,220) INF 760 220 FORMAT (84H* MAXIMIN HAS FOUND AND IGNORED A TRIAD OF X,S ITH AT LINF 770 1EAST TWO IDENTIAL VALUES. ) INF 780 GO TO 900 INF 790 421 WRITE (ISCRUN,221) INF 800 221 FORMAT(59H* MORE THAN ONE ARGUMENT IN COMMAND. ONLY FIRST ONE IS UINF 810 1SED,25X) INF 820 GO TO 900 INF 830 422 WRITE (ISCRUN,222) INF 840 222 FORMAT(43H* FORMAT NOT FOUND. READABLE FORMAT IS USED, 41X) INF 850 GO TO 900 INF 860 423 WRITE (ISCRUN,223) INF 870 223 FORMAT(38H* ONE,SOME OR ALL WEIGHTS ARE NEGATIVE,46X) INF 880 GO TO 900 INF 890 424 WRITE(ISCRUN,224) INF 900 224 FORMAT(48H* ALL WEIGHTS ARE ZERO. COMMAND IS NOT EXECUTED,36X) INF 910 GO TO 900 INF 920 425 WRITE(ISCRUN,225) INF 930 225 FORMAT(81H* ARG FOR BESIN,BESJN,BESKN GIVES A RESULT TO LARGE/SMA INF 940 1LL. COMMAND NOT EXECUTED.,3X) INF 950 GO TO 900 INF 960 426 WRITE(ISCRUN,226) INF 970 226 FORMAT(73H* COLUMN NOT LONG ENOUGH TO STORE ALL ELEMENTS. ONLY NROINF 980 1W WILL BE STORED.,11X) INF 990 GO TO 900 INF1000 427 WRITE(ISCRUN,227) INF1010 227 FORMAT(78H* NOT ENOUGH DATA ON COL TO RESTORE MATRIX/ARRAY. DATA AINF1020 1VAILABLE WILL BE USED.,6X) INF1030 GO TO 900 INF1040 428 WRITE (ISCRUN,228) INF1050 228 FORMAT(84H* SUM OF SQRS DO NOT ADD UP-ABS. VALUE OF (TOTAL-ROW-COLINF1060 1-RES.)/TOTAL EXCEEDS 5.E-7 ) INF1070 GO TO 900 INF1080 429 WRITE (ISCRUN,229) INF1090 229 FORMAT(51H* MORE THAN 50 HEAD COLUMN COMMANDS HAVE BEEN USED.,33X)INF1100 GO TO 900 INF1110 430 WRITE (ISCRUN,230) INF1120 230 FORMAT (72H* ATTEMPT TO PROMOTE FROM BELOW NRMAX. FIRST ARGUMENT IINF1130 1S RESET TO NRMAX., 12X) INF1140 GO TO 900 INF1150 431 WRITE (ISCRUN,231) INF1160 231 FORMAT (53H* ATTEMPT TO DEMOTE OFF THE WORKSHEET. SPILL IS LOST., INF1170 131X) INF1180 GO TO 900 INF1190 432 GO TO 900 INF1200 433 WRITE (ISCRUN,233) INF1210 233 FORMAT(76H* NEGATIVE VALUE(S) WERE ENCOUNTERED BY PARTITION FUNCTIINF1220 1ON. ZEROS STORED. ,8X) INF1230 GO TO 900 INF1240 434 WRITE (ISCRUN,234) INF1250 234 FORMAT( 45H* NEGATIVE ABSOLUTE TEMPERATURES CONVERTED. ,39X) INF1260 GO TO 900 INF1270 435 WRITE (ISCRUN,235) INF1280 235 FORMAT(76H* CAUTION, USE EXPERIMENTALLY ONLY. NOT OPTIMUM IN ORDEINF1290 1R TO MAKE IT MACHINE,10X/84H INDEPENDENT. REFERENCES - J.B. KRUSINF1300 2KAL,ACM,12,92. AND J.H. HALTON,SIAM REV.,12,1.) INF1310 GO TO 900 INF1320 436 WRITE (ISCRUN,236) INF1330 236 FORMAT (78H* COMMAND IGNORED - S BEFORE COMMAND NAME MEANINGLESS IINF1340 1F NO STORAGE REQUESTED.) INF1350 GO TO 900 INF1360 437 WRITE(ISCRUN,237) ISIGD INF1370 237 FORMAT(63H* NUMBER OF SIGNIFICANT DIGITS AFTER DECIMAL PT HAS BEENINF1380 1 SET TO ,I3,18X) INF1405 900 RETURN INF1410 END INF1420 SUBROUTINE INPUT INP 10 C VERSION 5.00 INPUT 5/15/70 INP 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND INP 30 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) INP 40 COMMON /BLOCKC/ KIO,INUNIT,ISCRET,KBDOUT,KRDKNT,LLIST INP 50 C INP 60 C THIS ROUTINE HANDLES THE READING OF INPUT RECORDS. INP 70 C IF KIO = 0, INPUT IS CARD IMAGE FROM CARD READER OR TAPE. INP 80 C IF KIO = 1, INPUT IS REAL-TIME FROM A KEYBOARD. INP 90 C INP 100 KRDKNT=KRDKNT+1 INP 110 IF (KIO.EQ.0) GO TO 20 INP 120 IF (MODE.EQ.3) GO TO 10 INP 130 WRITE (KBDOUT,30) INP 140 GO TO 20 INP 150 10 WRITE (KBDOUT,40) NSTMT INP 160 GO TO 20 INP 170 20 READ (INUNIT,50) NEWCD INP 180 KARD(1)=0 INP 190 KARD(2)=0 INP 200 KARD(KRDEND+3)=46 INP 210 CALL OMCONV (NEWCD,KARD(3),KRDEND) INP 220 RETURN INP 230 C INP 240 30 FORMAT (9H READY ) INP 250 40 FORMAT (9H READY ,I3,3H / ) INP 260 50 FORMAT (80A1) INP 270 END INP 280 SUBROUTINE INTERP INT 10 C VERSION 5.00 INTERP 5/15/70 INT 20 C * INT 30 C GENERAL FORM OF COMMAND IS INT 40 C INTERPOLATE X IN COL ++ Y IN COL 33 LENGTH=,, FOR THE FIRST INT 50 C ,, VALUES OF XP IN COL ++ USE ,, POINTS STORE IN COL 33 INT 60 C * INT 70 COMMON /BLOCRC/ NRC,RC(12600) INT 80 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NINT 90 1ARGS,VWXYZ(8),NERROR INT 100 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST INT 110 DIMENSION ARGS(100) INT 120 EQUIVALENCE (ARGS(1),RC(12501)) INT 130 COMMON /SCRAT/ NS,NS2,A(13500) INT 140 C * INT 150 C CHECK TO SEE IF WE HAVE CORRECT NUMBER AND MODE OF ARGUMENTS INT 160 C * INT 170 IF (NARGS.NE.7) CALL ERROR (10) INT 180 J=NARGS INT 190 CALL CKIND (J) INT 200 IF (J.NE.0) CALL ERROR (3) INT 210 C * INT 220 C CHECK NO. OF POINTS LESS THAN OR EQUAL TO NRMAX AND POSITIVE INT 230 C * INT 240 IF (IARGS(3).LT.0.OR.IARGS(4).LT.0) CALL ERROR (3) INT 250 IF (IARGS(3).GT.NROW.OR.IARGS(4).GT.NRMAX) CALL ERROR (3) INT 260 C * INT 270 C CHECK TO SEE IF WE HAVE MORE THAN TWO ENTRIES IN TABLE INT 280 C COMPUTE COLUMN ADDRESSES INT 290 C * INT 300 IF (IARGS(3).LT.2) CALL ERROR (3) INT 310 LXY=IARGS(3) INT 320 LXP=IARGS(4) INT 330 IARGS(3)=IARGS(5) INT 340 IARGS(4)=IARGS(7) INT 350 NARGS=4 INT 360 CALL CHKCOL (J) INT 370 IF (J.NE.0) CALL ERROR (11) INT 380 C * INT 390 C CHECK TO SEE IF WE EXCEED SCRATCH AREA INT 400 C CHECK FOR PREVIOUS ERRORS INT 410 C * INT 420 INDRV=0 INT 430 IF (IARGS(6)-LXY) 20,20,10 INT 440 10 IARGS(6)=LXY INT 450 INDRV=1 INT 460 20 IF (IARGS(6)**2+3*IARGS(6)+LXP.LE.NS) GO TO 30 INT 470 C=1.0-4.0*FLOAT(NS-LXP) INT 480 I=FSQRT(C) INT 490 IARGS(6)=(-1+I)/2 INT 500 INDRV=2 INT 510 30 IA1=IARGS(1) INT 520 IA2=IARGS(2) INT 530 IA3=IARGS(3) INT 540 IA4=3*IARGS(6)+LXP+1 INT 550 CALL INTRP (RC(IA1),RC(IA2),LXY,RC(IA3),A(1),LXP,IARGS(6),A(LXP+1)INT 560 1,A(IA4),IND) INT 570 C STORE RESULTS INT 580 IA3=IARGS(4) INT 590 DO 40 I=1,LXP INT 600 RC(IA3)=A(I) INT 610 IA3=IA3+1 INT 620 40 CONTINUE INT 630 IF (INDRV.EQ.0.AND.IND.EQ.0) RETURN INT 640 IF (INDRV-1) 70,50,60 INT 650 50 WRITE (ISCRAT,80) INT 660 GO TO 70 INT 670 60 WRITE (ISCRAT,90) INT 680 70 IF (IND.EQ.0) RETURN INT 690 WRITE (ISCRAT,100) INT 700 RETURN INT 710 C INT 720 80 FORMAT (6X,20(1H+),39HORDER OF INTERPOLATION EQUALS LIST SIZE,19X)INT 730 90 FORMAT (6X,20(1H+),53HORDER OF INTERP WAS RESET DUE TO SIZE OF SCRINT 740 1ATCH AREA,5X) INT 750 100 FORMAT (6X,20(1H+),42HEXTRAPOLATION DONE FOR MORE THAN ONE DELTA,1INT 760 16X) INT 770 END INT 780 SUBROUTINE INTRP (X,Y,NLIST,X1,RESULT,NX1,NORD,S,SA,IND) INR 10 C VERSION 5.00 INTRP 5/15/70 INR 20 C CALLING SEQUENCE INR 30 C SUBROUTINE INTRP(X,Y,NLIST,X1,RESULT,NX1,NORD,S,SA,IND) INR 40 C INR 50 C X THE INDEPENDENT VALUE OF THE TABLE. MUST BE IN ASCENDING OR INR 60 C DESCENDING ORDER. NEED NOT BE EVENLY SPACED INR 70 C Y THE DEPENDING VALUE OF THE TABLE INR 80 C NLIST LENGTH OF X OR Y INR 90 C X1 VALUES TO BE INTERPOLATED INR 100 C RESULT RESULT FROM INTERPOLATION INR 110 C NX1 LENGTH OF X1 VECTOR INR 120 C NORD ORDER OF INTERPOLATION INR 130 C S SCRATCH AREA S(3*NORD) INR 140 C SA SCRATCH AREA SA(NORD,NORD) INR 150 C IND INDICATOR INR 160 C IND=0 EVERYTHING FINE INR 170 C IND=1 EXTRAPOLATION AND MORE THEN ONE DELTA INR 180 C INR 190 DIMENSION X(1), Y(1), X1(1), RESULT(1), S(1), SA(NORD,NORD) INR 200 INDA=0 INR 210 IND=0 INR 220 NRD=NORD-1 INR 230 NDIR=1 INR 240 IF (X(1).GE.X(2)) NDIR=2 INR 250 I=1 INR 260 DO 220 II=1,NX1 INR 270 IC=0 INR 280 XA=X1(II) INR 290 GO TO (10,180), NDIR INR 300 10 IF (XA-X(1)) 20,160,30 INR 310 20 IF (ABS(XA-X(1)).GT.ABS(X(1)-X(2))) INDA=2 INR 320 IC=1 INR 330 IA=1 INR 340 GO TO 80 INR 350 30 DO 40 IA=I,NLIST INR 360 IF (X(IA)-XA) 40,170,60 INR 370 40 CONTINUE INR 380 50 IF (ABS(X(NLIST)-XA).GT.ABS(X(NLIST)-X(NLIST-1))) INDA=2 INR 390 IE=1 INR 400 IA=NLIST-NRD INR 410 IC=1 INR 420 GO TO 80 INR 430 60 IA=IA-1 INR 440 IF (X(IA)-XA) 70,170,60 INR 450 70 IF (IA+NRD.LE.NLIST) GO TO 80 INR 460 IC=1 INR 470 IA=NLIST-NRD INR 480 80 IF (NRD.GT.1) GO TO 90 INR 490 TEMP=(XA-X(IA))/(X(IA+1)-X(IA)) INR 500 RESULT(II)=Y(IA)+(Y(IA+1)-Y(IA))*TEMP INR 510 GO TO 220 INR 520 90 IF (IC.NE.0) GO TO 100 INR 530 IA=IA-NRD/2 INR 540 IF (IA.LE.0) IA=1 INR 550 100 NA=IA+NRD INR 560 PROD=1. INR 570 IZ=1 INR 580 IZA=NORD+1 INR 590 DO 110 IB=IA,NA INR 600 S(IZ)=X(IB) INR 610 S(IZA)=XA-X(IB) INR 620 PROD=PROD*S(IZA) INR 630 IZ=IZ+1 INR 640 110 IZA=IZA+1 INR 650 NB=NRD+1 INR 660 DO 120 IAR=2,NB INR 670 DO 120 IBR=IAR,NB INR 680 SA(IBR-1,IAR-1)=S(IAR-1)-S(IBR) INR 690 120 SA(IAR-1,IBR)=(-SA(IBR-1,IAR-1)) INR 700 IZB=IZA INR 710 IZC=NORD+1 INR 720 DO 140 IAR=1,NB INR 730 SUM=S(IZC) INR 740 DO 130 IBR=1,NRD INR 750 130 SUM=SUM*SA(IBR,IAR) INR 760 S(IZA)=PROD/SUM INR 770 IZC=IZC+1 INR 780 140 IZA=IZA+1 INR 790 R=0.0 INR 800 IAX=IA INR 810 DO 150 IX=1,NORD INR 820 R=R+S(IZB)*Y(IAX) INR 830 IAX=IAX+1 INR 840 150 IZB=IZB+1 INR 850 RESULT(II)=R INR 860 GO TO 220 INR 870 160 RESULT(II)=Y(1) INR 880 IA=1 INR 890 GO TO 220 INR 900 170 RESULT(II)=Y(IA) INR 910 GO TO 220 INR 920 180 IF (XA-X(1)) 190,160,30 INR 930 190 DO 200 IA=I,NLIST INR 940 IF (XA-X(IA)) 200,170,210 INR 950 200 CONTINUE INR 960 GO TO 50 INR 970 210 IA=IA-1 INR 980 IF (XA-X(IA)) 70,170,210 INR 990 220 I=IA INR1000 IND=IND+INDA INR1010 RETURN INR1020 END INR1030 SUBROUTINE INVCHK (A,M,N,AINV,M1,Y,L2,ERR,IND) INK 10 C VERSION 5.00 INVCHK 5/15/70 INK 20 C INVCHK FOR OMNITAB UNIVAC 1108 S. PEAVY 5/24/67 INK 30 C THIS SUBROUTINE INVERTS A MATRIX AND PROVIDES ALL THE CHECKS DESCRINK 40 C IN PAC-1 INK 50 C INK 60 C A IS THE MATRIX TO BE INVERTED INK 70 C INK 80 C M IS THE SIZE OF A AS DIMENSIONED IN THE CALLING PROGRAM A(M,M) INK 90 C INK 100 C N IS THE SIZE OF A TO BE INVERTED INK 110 C N LESS THAN OR =M-1 INK 120 C INK 130 C AINV WILL CONTAIN THE INVERTED MATRIX IF INVERSION IS OBTAINABLE INK 140 C INK 150 C M1 IS THE SIZE OF AINV AS DIMENSIONED IN THE CALLING PROGRAM INK 160 C AINV(M1,2*M1) M1 MUST BE GREATER OR =N+1 INK 170 C AINV MUST HAVE TWICE AS MANY COLUMNS AS ROWS INK 180 C A AND AINV CANNOT BE SAME OR EQUIVALENT INK 190 C INK 200 C ERR WILL CONTAIN THE 3 WAYS OF EVALUATION NORM CHECKS INK 210 C ERR IS A DIMENSIONED AS ERR(3) INK 220 C INK 230 C IND IS AN INDICATOR INK 240 C IND=0 MATRIX INVERTED AND ERROR CHECKS MADE INK 250 C IND=1 MATRIX SIGNULAR INK 260 C INK 270 C COLUMN AINV(N+1,I) I=1,....,N WILL CONTAIN THE ERROR BOUND OF INK 280 C THE SUM CHECKS+1. INK 290 C INK 300 DIMENSION A(M,M), AINV(M1,M1), ERR(3), ANORM(2,3) INK 310 DIMENSION Y(N) INK 320 DATA ZERO/0.0/,ONE/1.0/ INK 330 10 NA=N INK 340 DO 20 I=1,NA INK 350 DO 20 J=1,NA INK 360 20 AINV(J,I)=A(J,I) INK 370 NB=NA INK 380 IF (L2.EQ.1) GO TO 40 INK 390 NB=NB+1 INK 400 DO 30 I=1,NA INK 410 AINV(I,NA+1)=Y(I) INK 420 30 AINV(NA+1,I)=ZERO INK 430 AINV(NA+1,NA+1)=-ONE INK 440 NA=NA+1 INK 450 40 DO 60 I=1,NA INK 460 SUM=ZERO INK 470 AINV(NA+1,I)=ZERO INK 480 DO 50 J=1,NA INK 490 50 SUM=SUM+AINV(I,J) INK 500 60 AINV(I,NA+1)=-SUM INK 510 AINV(NA+1,NA+1)=ONE INK 520 NB=NB+1 INK 530 CALL SPINV (AINV,NB,M1,IND) INK 540 IF (IND.NE.0) RETURN INK 550 DO 140 K=1,2 INK 560 DO 70 I=1,3 INK 570 70 ANORM(K,I)=ZERO INK 580 DO 130 I=1,N INK 590 SUM=ZERO INK 600 DO 120 J=1,N INK 610 GO TO (80,90), K INK 620 80 TEMP=ABS(AINV(I,J)) INK 630 GO TO 110 INK 640 90 TEMP=ZERO INK 650 DO 100 L=1,N INK 660 100 TEMP=TEMP+A(I,L)*AINV(L,J) INK 670 IF (I.EQ.J) TEMP=ONE-TEMP INK 680 TEMP=ABS(TEMP) INK 690 110 ANORM(K,1)=ANORM(K,1)+TEMP**2 INK 700 IF (ANORM(K,2).LT.TEMP) ANORM(K,2)=TEMP INK 710 120 SUM=SUM+TEMP INK 720 IF (ANORM(K,3).LT.SUM) ANORM(K,3)=SUM INK 730 130 CONTINUE INK 740 ANORM(K,1)=FSQRT(ANORM(K,1)) INK 750 140 ANORM(K,2)=FLOAT(N)*ANORM(K,2) INK 760 DO 150 K=1,3 INK 770 150 ERR(K)=(ANORM(1,K)*ANORM(2,K))/(1.-ANORM(2,K)) INK 780 RETURN INK 790 END INK 800 SUBROUTINE INVCOR (A,M,N,AINV,M1,Y,L2,ERR,IND) INC 10 C VERSION 5.00 INVCHK 5/15/70 INC 20 C INVCOR FOR OMNITAB UNIVAC 1108 S. PEAVY 5/24/67 INC 30 C THIS SUBROUTINE INVERTS A MATRIX AND PROVIDES ALL THE CHECKS DESCRINC 40 C IN PAC-1 INC 50 C INC 60 C A IS THE MATRIX TO BE INVERTED INC 70 C INC 80 C M IS THE SIZE OF A AS DIMENSIONED IN THE CALLING PROGRAM A(N,M) INC 90 C INC 100 C N IS THE SIZE OF A TO BE INVERTED INC 110 C N LESS THAN OR =M-1 INC 120 C INC 130 C AINV WILL CONTAIN THE INVERTED MATRIX IF INVERSION IS OBTAINABLE INC 140 C INC 150 C M1 IS THE SIZE OF AINV AS DIMENSIONED IN THE CALLING PROGRAM INC 160 C AINV(M1,2*M1) M1 MUST BE GREATER OR =N+1 INC 170 C AINV MUST HAVE TWICE AS MANY COLUMNS AS ROWS INC 180 C A AND AINV CANNOT BE SAME OR EQUIVALENT INC 190 C INC 200 C ERR WILL CONTAIN THE 3 WAYS OF EVALUATION NORM CHECKS INC 210 C ERR IS A DIMENSIONED AS ERR(3) INC 220 C INC 230 C IND IS AN INDICATOR INC 240 C IND=0 MATRIX INVERTED AND ERROR CHECKS MADE INC 250 C IND=1 MATRIX SIGNULAR INC 260 C INC 270 C COLUMN AINV(N+1,I) I=1,....,N WILL CONTAIN THE ERROR BOUND OF INC 280 C THE SUM CHECKS+1. INC 290 C INC 300 DIMENSION A(M,M), AINV(M1,M1), ERR(3), ANORM(2,3) INC 310 DIMENSION Y(N) INC 320 DATA ZERO/0.0/,ONE/1.0/ INC 330 10 NA=N INC 340 DO 20 I=1,NA INC 350 DO 20 J=1,NA INC 360 20 AINV(J,I)=A(J,I) INC 370 NB=NA INC 380 IF (L2.EQ.1) GO TO 40 INC 390 NB=NB+1 INC 400 DO 30 I=1,NA INC 410 AINV(I,NA+1)=Y(I) INC 420 30 AINV(NA+1,I)=ZERO INC 430 AINV(NA+1,NA+1)=-ONE INC 440 NA=NA+1 INC 450 40 DO 60 I=1,NA INC 460 SUM=ZERO INC 470 AINV(NA+1,I)=ZERO INC 480 DO 50 J=1,NA INC 490 50 SUM=SUM+AINV(I,J) INC 500 60 AINV(I,NA+1)=-SUM INC 510 AINV(NA+1,NA+1)=ONE INC 520 NB=NB+1 INC 530 CALL CSPINV (AINV,NB,M1,IND) INC 540 IF (IND.NE.0) RETURN INC 550 DO 140 K=1,2 INC 560 DO 70 I=1,3 INC 570 70 ANORM(K,I)=ZERO INC 580 DO 130 I=1,N INC 590 SUM=ZERO INC 600 DO 120 J=1,N INC 610 GO TO (80,90), K INC 620 80 TEMP=ABS(AINV(I,J)) INC 630 GO TO 110 INC 640 90 TEMP=ZERO INC 650 DO 100 L=1,N INC 660 100 TEMP=TEMP+A(I,L)*AINV(L,J) INC 670 IF (I.EQ.J) TEMP=ONE-TEMP INC 680 TEMP=ABS(TEMP) INC 690 110 ANORM(K,1)=ANORM(K,1)+TEMP**2 INC 700 IF (ANORM(K,2).LT.TEMP) ANORM(K,2)=TEMP INC 710 120 SUM=SUM+TEMP INC 720 IF (ANORM(K,3).LT.SUM) ANORM(K,3)=SUM INC 730 130 CONTINUE INC 740 ANORM(K,1)=FSQRT(ANORM(K,1)) INC 750 140 ANORM(K,2)=FLOAT(N)*ANORM(K,2) INC 760 DO 150 K=1,3 INC 770 150 ERR(K)=(ANORM(1,K)*ANORM(2,K))/(1.-ANORM(2,K)) INC 780 RETURN INC 790 END INC 800 SUBROUTINE INVERT INV 10 C VERSION 5.00 INVERT 5/15/70 INV 20 C MATRIX INVERSION, SOLUTION OF SYSTEM OF EQUATIONS INV 30 C S PEAVY 5/22/67 INV 40 C MINVERT (+++,+++) SIZE +++,+++ STORE (+++,+++) INV 50 C SOLVE (+++,+++,) SIZE +++,+++ Y VECTOR +++ STORE +++ INV 60 C LARGEST MATRIX TO BE INVERTED OR SYSTEM TO BE SOLVED IS 50 INV 70 C INV 80 C L2=1 INVERT INV 90 C L2=2 SOLVE INV 100 COMMON /SCRAT/ NS,NS2,A(13500) INV 110 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG INV 120 COMMON /BLOCRC/ NRC,RC(12600) INV 130 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NINV 140 1ARGS,VWXYZ(8),NERROR INV 150 DIMENSION ARGS(100) INV 160 EQUIVALENCE (ARGS(1),RC(12501)) INV 170 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST INV 180 DIMENSION ERR(3) INV 190 IF(NARGS.EQ.6) GO TO 10 INV 200 CALL ERROR (10) INV 210 RETURN INV 220 10 J=NARGS INV 230 CALL CKIND (J) INV 240 IF (J.NE.0) GO TO 100 INV 250 IF(IARGS(3)-IARGS(4)) 105,20,107 INV 275 20 NARGS=8 INV 320 KIND(7)=0 INV 330 KIND(8)=0 INV 340 IF (L2.EQ.1) GO TO 30 INV 350 IARGS(9)=IARGS(6) INV 360 NARGS=9 INV 370 KIND(9)=0 INV 380 CALL ADRESS (NARGS,JE) INV 390 IF (JE.LE.0) GO TO 150 INV 400 IARGS(6)=IARGS(5) INV 410 IARGS(5)=1 INV 420 IARGS(8)=1 INV 430 GO TO 40 INV 440 30 IARGS(8)=IARGS(3) INV 450 40 IARGS(7)=IARGS(3) INV 460 J=2 INV 470 CALL MTXCHK (J) INV 480 IF (J.NE.0) GO TO 140 INV 490 JA=IARGS(1) INV 500 JB=IARGS(5) INV 510 IF (2*((IARGS(3)+2)**2).GT.NS) GO TO 120 INV 520 IF (NERROR.NE.0) RETURN INV 530 M1=IARGS(3)+1 INV 540 IF (L2.EQ.2) M1=M1+1 INV 550 CALL INVCHK (RC(JA),NROW,IARGS(3),A,M1,RC(JB),L2,ERR,IND) INV 560 C CHECK TO SEE IF MATRIX WAS INVERTED. YES, IF IND=0 INV 570 IF (IND.NE.0) GO TO 130 INV 580 IA=IARGS(3) INV 590 IF (L2.EQ.2) GO TO 70 INV 600 C STORE INVERTED MATRIX INV 610 DO 60 I=1,IA INV 620 JC=JB INV 630 JD=(I-1)*M1+1 INV 640 DO 50 J=1,IA INV 650 RC(JC)=A(JD) INV 660 JC=JC+1 INV 670 50 JD=JD+1 INV 680 60 JB=JB+NROW INV 690 GO TO 90 INV 700 C STORE RESULTS OF SOLUTION INV 710 70 JC=M1*IARGS(3)+1 INV 720 DO 80 I=1,IA INV 730 RC(JE)=A(JC) INV 740 JC=JC+1 INV 750 80 JE=JE+1 INV 760 C DETERMINE SMALLEST ERROR BOUND INV 770 90 SERR=AMIN1(ERR(1),ERR(2),ERR(3)) INV 780 WRITE (ISCRAT,160) SERR INV 790 RETURN INV 800 100 CALL ERROR (3) INV 810 RETURN INV 820 105 IARGS(4)=IARGS(3) INV 830 GO TO 110 INV 840 107 IARGS(3)=IARGS(4) INV 850 110 CALL ERROR (210) INV 860 C PRINT ROW AND COLUMNS DO NOT AGREE,SIZE OF COLUMNS IS SET TO ROW INV 870 GO TO 20 INV 880 120 CALL ERROR (23) INV 890 C PRINT MATRIX TOO LARGS TO INVERT INV 900 RETURN INV 910 130 CALL ERROR (22) INV 920 C PRINT MATRIX IS SINGULAR OR NEAR SINGULAR-NO INVERSE INV 930 RETURN INV 940 140 IF (J.EQ.1) GO TO 150 INV 950 CALL ERROR (17) INV 960 RETURN INV 970 150 CALL ERROR (11) INV 980 RETURN INV 990 C INV1000 160 FORMAT (6X,20(1H+),43H SMALLEST ERROR BOUND ON INVERTED MATRIX IS,INV1010 1E8.1,7H ++++) INV1020 END INV1030 SUBROUTINE ITERAT ITE 10 C VERSION 5.00 ITERAT 5/15/70 ITE 20 COMMON /BLOCRC/ NRC,RC(12600) ITE 30 COMMON /SCRAT/ NS,NS2,A(13500) ITE 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NITE 50 1ARGS,VWXYZ(8),NERROR ITE 60 DIMENSION ARGS(100) ITE 70 EQUIVALENCE (ARGS(1),RC(12501)) ITE 80 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ITE 90 C L2=1 ITERATE X IN ++, Y IN ++, DESIRED Y IN ++ START STORINITE 100 C L2=2 ISETUP X IN ++, Y IN ++, DESIRED Y IN ++ STORE STARTINITE 110 C COLUMN ++ ITE 120 C IN COLUMN ++ ITE 130 C L2=3 ISOLATE X IN ++ FOR Y IN COL ++=** STORE IN ++ AND ++ ITE 140 C ISOLATE X IN ++ FOR Y IN COL ++=** USE ,, POINT, STORE ITE 150 C IN ++ AND ++ ITE 160 C ITERATE AND ISETUP USE THREE COLUMNS AFTER THE INDICATED STORE ITE 170 C STORAGE FOR ITERATE AND ISETUP ARE NEW X ,AVERAGE BRACKETING X,ITE 180 C AVERAGE BRACKETTING Y, AND SUCCESSFUL Y ITE 190 C CODE BY MRS. CARLA G. MESSINA NSRDS-NBS OCT 1967 ITE 200 INSERT=3 ITE 210 IF (NARGS-4) 10,40,80 ITE 220 10 K=10 ITE 230 20 CALL ERROR (K) ITE 240 30 RETURN ITE 250 40 IF (L2-2) 50,50,10 ITE 260 50 NARGS=7 ITE 270 DO 60 I=5,7 ITE 280 KIND(I)=0 ITE 290 60 IARGS(I)=IARGS(I-1)+1 ITE 300 IF (NROW-5) 70,180,180 ITE 310 70 K=17 ITE 320 GO TO 20 ITE 330 80 IF (L2-3) 10,90,10 ITE 340 90 IARGS(7)=IARGS(5) ITE 350 KIND(7)=KIND(5) ITE 360 IF (NARGS-6) 100,110,10 ITE 370 100 NARGS=6 ITE 380 IARGS(6)=IARGS(5) ITE 390 KIND(6)=KIND(5) ITE 400 IARGS(5)=IARGS(4) ITE 410 KIND(5)=KIND(4) ITE 420 GO TO 140 ITE 430 110 IF (KIND(4)) 120,130,120 ITE 440 120 K=3 ITE 450 GO TO 20 ITE 460 130 INSERT=IARGS(4) ITE 470 IARGS(4)=IARGS(5) ITE 480 140 IF (INSERT-1) 120,150,150 ITE 490 150 IF (NROW-INSERT-2) 70,160,160 ITE 500 160 IF (KIND(3)) 170,120,170 ITE 510 170 POINT=ARGS(3) ITE 520 IARGS(3)=IARGS(2) ITE 530 KIND(3)=0 ITE 540 180 CALL CHKCOL (J) ITE 550 IF (J) 120,190,120 ITE 560 190 IF (NERROR.NE.0) GO TO 30 ITE 570 IF (NRMAX-1) 200,210,220 ITE 580 200 K=9 ITE 590 GO TO 20 ITE 600 210 K=215 ITE 610 GO TO 20 ITE 620 220 IF (L2-2) 300,230,230 ITE 630 230 I1=IARGS(1)-1 ITE 640 DO 240 I=2,NRMAX ITE 650 K=I1+I ITE 660 IF (RC(K-1)-RC(K)) 250,240,270 ITE 670 240 CONTINUE ITE 680 GO TO 290 ITE 690 250 DO 260 I=2,NRMAX ITE 700 K=I1+I ITE 710 IF (RC(K-1)-RC(K)) 260,260,290 ITE 720 260 CONTINUE ITE 730 GO TO 300 ITE 740 270 DO 280 I=2,NRMAX ITE 750 K=I1+I ITE 760 IF (RC(K-1)-RC(K)) 290,280,280 ITE 770 280 CONTINUE ITE 780 GO TO 300 ITE 790 290 CALL ERROR (216) ITE 800 300 DO 310 I=1,NRMAX ITE 810 I1=IARGS(1)+I-1 ITE 820 I2=IARGS(2)+I-1 ITE 830 I3=IARGS(3)+I-1 ITE 840 A(I)=RC(I1) ITE 850 M=I+NRMAX ITE 860 A(M)=RC(I2) ITE 870 M=M+NRMAX ITE 880 310 A(M)=RC(I3) ITE 890 M=0 ITE 900 M1=0 ITE 910 IOVFL=0 ITE 920 IND2=INSERT+2 ITE 930 DIV=INSERT+1 ITE 940 IDIV=INSERT+1 ITE 950 I1=IARGS(4)-1 ITE 960 I2=IARGS(5)-1 ITE 970 I3=IARGS(6)-1 ITE 980 I4=IARGS(7)-1 ITE 990 I5=IARGS(4)-1 ITE1000 IF (L2-2) 500,500,320 ITE1010 C ISOLATE ITE1020 320 K1=NRMAX+1 ITE1030 L1=2*NRMAX ITE1040 I5=IARGS(5)-1 ITE1050 IF (POINT-A(K1)) 340,330,340 ITE1060 330 M=M+1 ITE1070 I2=I2+1 ITE1080 RC(I2)=A(1) ITE1090 M1=M1+1 ITE1100 I3=I3+1 ITE1110 RC(I3)=A(1) ITE1120 340 K1=K1+1 ITE1130 I=1 ITE1140 DO 440 K=K1,L1 ITE1150 I=I+1 ITE1160 IF (POINT-A(K-1)) 350,440,360 ITE1170 350 IF (POINT-A(K)) 440,390,370 ITE1180 360 IF (POINT-A(K)) 370,390,440 ITE1190 370 IF (NROW-M-IND2) 380,400,400 ITE1200 380 IOVFL=1 ITE1210 GO TO 430 ITE1220 390 A(I-1)=A(I) ITE1230 IF (NROW-M-1) 430,420,420 ITE1240 400 M=M+1 ITE1250 I2=I2+1 ITE1260 RC(I2)=A(I-1) ITE1270 DELT=(A(I)-A(I-1))/DIV ITE1280 DO 410 II=1,INSERT ITE1290 M=M+1 ITE1300 I2=I2+1 ITE1310 410 RC(I2)=RC(I2-1)+DELT ITE1320 420 M=M+1 ITE1330 I2=I2+1 ITE1340 RC(I2)=A(I) ITE1350 430 M1=M1+1 ITE1360 I3=I3+1 ITE1370 RC(I3)=(A(I-1)+A(I))/2.0 ITE1380 IF (NROW-M1) 470,470,440 ITE1390 440 CONTINUE ITE1400 IF (M) 480,480,450 ITE1410 450 NRMAX=M ITE1420 460 IF (IOVFL) 470,30,470 ITE1430 470 K=218 ITE1440 GO TO 20 ITE1450 480 K=217 ITE1460 DO 490 I=1,NRMAX ITE1470 I5=I5+1 ITE1480 490 RC(I5)=A(I) ITE1490 GO TO 20 ITE1500 500 K1=2*NRMAX+1 ITE1510 L1=3*NRMAX ITE1520 DO 510 K=1,NRMAX ITE1530 IF (A(L1)) 520,510,520 ITE1540 510 L1=L1-1 ITE1550 L1=3*NRMAX ITE1560 520 NEWY=L1-K1+1 ITE1570 IF (L2-2) 780,530,10 ITE1580 C ISETUP ITE1590 530 DO 740 K=K1,L1 ITE1600 I=1 ITE1610 L=NRMAX+1 ITE1620 IF (A(K)-A(I)) 590,540,590 ITE1630 540 IF (NROW-M-IND2) 550,560,560 ITE1640 550 IOVFL=1 ITE1650 GO TO 580 ITE1660 560 DO 570 II=1,IND2 ITE1670 M=M+1 ITE1680 I1=I1+1 ITE1690 570 RC(I1)=A(I) ITE1700 580 M1=M1+1 ITE1710 I2=I2+1 ITE1720 RC(I2)=A(I) ITE1730 I3=I3+1 ITE1740 RC(I3)=A(L) ITE1750 I4=I4+1 ITE1760 RC(I4)=A(K) ITE1770 IF (NROW-M1) 470,470,590 ITE1780 590 DO 730 I=2,NRMAX ITE1790 L=NRMAX+I ITE1800 IF (A(L-1)-A(K)) 600,730,610 ITE1810 600 IF (A(L)-A(K)) 730,620,670 ITE1820 610 IF (A(L)-A(K)) 670,620,730 ITE1830 620 IF (NROW-M-IND2) 630,640,640 ITE1840 630 IVOFL=1 ITE1850 GO TO 660 ITE1860 640 DO 650 J=1,IND2 ITE1870 M=M+1 ITE1880 I1=I1+1 ITE1890 650 RC(I1)=A(I) ITE1900 660 M1=M1+1 ITE1910 I2=I2+1 ITE1920 RC(I2)=A(I) ITE1930 I3=I3+1 ITE1940 RC(I3)=A(L) ITE1950 GO TO 720 ITE1960 670 IF (NROW-M-IND2) 680,690,690 ITE1970 680 IOVFL=1 ITE1980 GO TO 710 ITE1990 690 DELT=(A(I)-A(I-1))/DIV ITE2000 M=M+1 ITE2010 I1=I1+1 ITE2020 RC(I1)=A(I-1) ITE2030 DO 700 J=1,INSERT ITE2040 M=M+1 ITE2050 I1=I1+1 ITE2060 700 RC(I1)=RC(I1-1)+DELT ITE2070 M=M+1 ITE2080 I1=I1+1 ITE2090 RC(I1)=A(I) ITE2100 710 M1=M1+1 ITE2110 I2=I2+1 ITE2120 RC(I2)=(A(I)+A(I-1))/2.0 ITE2130 I3=I3+1 ITE2140 RC(I3)=(A(L)+A(L-1))/2.0 ITE2150 720 I4=I4+1 ITE2160 RC(I4)=A(K) ITE2170 IF (NROW-M1) 470,470,740 ITE2180 730 CONTINUE ITE2190 740 CONTINUE ITE2200 750 IF (M) 480,480,760 ITE2210 760 IF (M-NEWY) 770,770,450 ITE2220 770 NRMAX=NEWY ITE2230 GO TO 460 ITE2240 C ITERATE ITE2250 780 II=IND2*(NRMAX/IND2) ITE2260 IF (II) 210,210,790 ITE2270 790 DO 960 K=K1,L1 ITE2280 DO 950 K3=1,II,IND2 ITE2290 DO 830 J=1,IDIV ITE2300 I=K3+J ITE2310 L=NRMAX+I ITE2320 IF (A(L-1)-A(K)) 810,800,820 ITE2330 800 I=I-1 ITE2340 L=L-1 ITE2350 GO TO 840 ITE2360 810 IF (A(L)-A(K)) 830,840,890 ITE2370 820 IF (A(L)-A(K)) 890,840,830 ITE2380 830 CONTINUE ITE2390 GO TO 950 ITE2400 840 IF (NROW-M-IND2) 850,860,860 ITE2410 850 IOVFL=1 ITE2420 GO TO 880 ITE2430 860 DO 870 J=1,IND2 ITE2440 M=M+1 ITE2450 I1=I1+1 ITE2460 870 RC(I1)=A(I) ITE2470 880 M1=M1+1 ITE2480 I2=I2+1 ITE2490 RC(I2)=A(I) ITE2500 I3=I3+1 ITE2510 RC(I3)=A(L) ITE2520 GO TO 940 ITE2530 890 IF (NROW-M-IND2) 900,910,910 ITE2540 900 IOVFL=1 ITE2550 GO TO 930 ITE2560 910 DELT=(A(I)-A(I-1))/DIV ITE2570 M=M+1 ITE2580 I1=I1+1 ITE2590 RC(I1)=A(I-1) ITE2600 DO 920 J=1,INSERT ITE2610 M=M+1 ITE2620 I1=I1+1 ITE2630 920 RC(I1)=RC(I1-1)+DELT ITE2640 M=M+1 ITE2650 I1=I1+1 ITE2660 RC(I1)=A(I) ITE2670 930 M1=M1+1 ITE2680 I2=I2+1 ITE2690 RC(I2)=(A(I)+A(I-1))/2.0 ITE2700 I3=I3+1 ITE2710 RC(I3)=(A(L)+A(L-1))/2.0 ITE2720 940 I4=I4+1 ITE2730 RC(I4)=A(K) ITE2740 IF (NROW-M1) 470,470,960 ITE2750 950 CONTINUE ITE2760 960 CONTINUE ITE2770 GO TO 750 ITE2780 END ITE2790 C BLOCK DATA LBCONS LBC 10 C VERSION 5.00 LBCONS 5/15/70 LBC 20 BLOCK DATA LBC 30 C LBC 40 C THESE CONSTANTS MAY HAVE TO BE CHANGED FOR OTHER COMPUTERS OR LBC 50 C LIBRARY ROUTINE LBC 60 C LBC 70 C DSNCOS IS USED BY DOUBLE PRECISION SIN AND COS FUNCTIONS IN ORDER LBC 80 C TO TRAP IF ARGUMENT BECOMES TOO LARGE LBC 90 C LBC 100 C XTRIG IS USED BY FSIN,FCOS FUNCTIONS IN ORDER TO TRAP IF ARGUMENTLBC 110 C BECOMES TO LARGS LBC 120 C LBC 130 C XEXP IS USED BY FEXP FUNCION IN ORDER TO TRAP IF ARGUMENT LBC 140 C BECOMES TOO LARGE LBC 150 C LBC 160 C DXEXP IS USED BY FDEXP FUNCTION IN ORDER TO TRAP IF ARGUMENT LBC 170 C BECOMES TOO LARGE LBC 180 C LBC 190 C ER IS USED BY SUBROUTINE CSPINV TO CHECK ON A COMPUTER ZERO LBC 210 C LBC 220 C NBC IS USED BY SUBROUTINE ERRINT AND IS THE NUMBER OF BINARY LBC 230 C BITS IN THE CHARACTERISTIC OF A DOUBLE PRECISION NUMBER LBC 240 C LBC 250 C NBM IS USED BY SUBROUTINE ERRINT AND IS THE NUMBER OF BINARY LBC 260 C BITS IN THE MANTISSA OF A DOUBLE PRECISION NUMBER LBC 270 C LBC 280 C TRRTPI IS USED BY SUBROUTINE ERRINT AND IS THE VALUE 2.0/SQRT(PI) LBC 290 C LBC 300 C ISIGD IS USED BY SUBROUTINE FIXFLO AND INFERR, NO. OF SIGNIFICANTLBC 310 C DIGITS I/O SUB. CAN PRINT AFTER DECIMAL POINT ISIGD=8 LBC 320 C LBC 330 DOUBLE PRECISION DSNCOS,DXEXP,TRRTPI LBC 340 COMMON/CONSLB/XTRIG,XEXP LBC 350 COMMON/CONLB2/ER,ISIGD LBC 360 COMMON/CONSTS/PI,E,HALFPI,DEG,RAD,XALOG LBC 370 COMMON/DCONLB/DSNCOS,DXEXP LBC 380 COMMON/DCONL2/TRRTPI,NBC,NBM LBC 390 DATA DSNCOS/3.5D16/,DXEXP/704.0D0/ LBC 400 DATA NBC/11/,NBM/60/,TRRTPI/1.128379167095512574D0/ LBC 410 DATA XTRIG/3.3E7/,XEXP/88.0 / LBC 420 DATA ER/1.E-8/,ISIGD/8/ LBC 430 C LBC 440 C THIS BLOCK DEFINES CONSTANTS TO BE USED THROUGHOUT OMNITAB LBC 450 C WHOSE VALUE (ACCURACY) WILL HAVE TO BE CHANGED FOR OTHER LBC 460 C COMPUTERS LBC 470 C PI=3.14159265 (VALUE OF PI) LBC 480 C E, 2.71821818 (BASE OF NATURAL LOGS) LBC 490 C HALFPI=1.5707963 (VALUE OF PI/2) LBC 500 C DEG= 57.2957795 (NUMBER OF DEGREES IN ONE RADIAN) LBC 510 C RAD= .0174532925 (NUMBER OF RADIANS IN ONE DEGREE) LBC 520 C XALOG= 38. (EXPONENT BOUND) LBC 530 DATA PI,E,HALFPI,DEG,RAD,XALOG/ LBC 540 1 3.14159265,2.7182818,1.5707963,57.2957795,.0174532925,38./ LBC 550 END LBC 560 SUBROUTINE LIST (K) LIS 10 C VERSION 5.00 LIST 5/15/70 LIS 20 C WRITTEN BY R VARNER 3/14/68 LIS 30 C K=0 COMMAND IS LIST LIS 40 C K=1 COMMAND IS NOLIST LIS 50 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST LIS 60 COMMON /BLOCRC/ NRC,RC(12600) LIS 70 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NLIS 80 1ARGS,VWXYZ(8),NERROR LIS 90 DIMENSION ARGS(100) LIS 100 EQUIVALENCE (ARGS(1),RC(12501)) LIS 110 IF (K.EQ.0) GO TO 20 LIS 120 C NO LIST OR NOLIST LIS 130 IARGS(1)=0 LIS 140 10 IF (NERROR.EQ.0) LLIST=IARGS(1) LIS 150 WRITE (ISCRAT,30) IARGS(1) LIS 160 RETURN LIS 170 C LIS 180 C LIST (WITH NO ARGUMENTS) = LIST 3 LIS 190 C LIST 0 = NO LISTING LIS 200 C LIST 1 = LIST ONLY INFORMATIVE DIAGS. LIS 210 C LIST 2 = LIST ONLY ARITH. ERR LIS 220 C LIST 3 = LIST BOTH TYPES OF ERRORS LIS 230 C LIST=4 SUPPRESS BOTH ARITHMETIC ERRORS AND INFOMRATIVE DIAGNOSTICSLIS 235 C IF A FATAL ERROR OCCURS, LLIST IS SET TO AND KEPT AT 3 LIS 240 20 IF(NARGS.EQ.0.OR.IARGS(1).LT.0.OR.IARGS(1).GT.4) IARGS(1)=3 LIS 250 GO TO 10 LIS 260 C LIS 270 30 FORMAT (1H,,I1,82X) LIS 280 END LIS 290 FUNCTION LOCATE (L) LOC 10 C VERSION 5.00 LOCATE 5/15/70 LOC 20 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) LOC 30 C LOC 40 C THIS FUNCTION SEARCHES THE LIST OF STORED COMMANDS TO SEE IF ONE LOC 50 C WITH STATEMENT NUMBER L EXISTS. IF IT DOES, RETURN ITS LOCATION LOC 60 C IF IT DOESN'T EXIST, RETURN NEGATIVE THE LOCATION OF THE NEXT LOC 70 C HIGHER STATEMENT NUMBER. LOC 80 C LOC 90 I=1 LOC 100 AL=L LOC 105 10 IF (COM(I)-AL) 20,30,40 LOC 110 20 I=I+IFIX(COM(I+1)) LOC 120 GO TO 10 LOC 130 30 LOCATE=I LOC 140 GO TO 50 LOC 150 40 LOCATE=-I LOC 160 50 RETURN LOC 170 END LOC 180 SUBROUTINE LOOKUP LOU 10 C VERSION 5.00 LOOKUP 5/15/70 LOU 20 C WRITTEN BY S PEAVY 3/14/68 LOU 30 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG LOU 40 COMMON /ICODE/ NIR,NID,NIRD,LIR,LID,LIRD LOU 50 COMMON /CODE/ IALPH(6),NALPH(5),ID(9,3),IR(300,4),IRD(30,6) LOU 60 C THE FOLLOWING CARS ARE NEEDED ONLY FOR THE OPERATIONS LOU 70 COMMON /ICODTP/ NITP,LITP LOU 80 COMMON /CODETP/ ITP(10,4) LOU 90 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP LOU 100 C THIS SUBROUTINE CHECKS TO SEE IF FIRST WORD AND SOMETIMES SECOND LOU 102 C WORD ON COMMAND CARD IS A LEGITIMATE COMMAND LOU 104 C IF COMMAND IS FOUND L1 AND L2 ARE ASSIGNED A VALUE LOU 106 C IF COMMAND IS NOT FOUND IN THE DICTIONARY L1 IS SET EQUAL TO ZERO LOU 108 C ************************************************************* LOU 110 L1=0 LOU 120 DO 10 I=1,NIR LOU 130 IF (NAME(1).NE.IR(I,1).OR.NAME(2).NE.IR(I,2)) GO TO 10 LOU 140 L1=IR(I,3) LOU 150 L2=IR(I,4) LOU 160 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOU 170 IF (NAME(1).NE.IR(50,1)) RETURN LOU 180 C NAME(3)=TAP NAME(4)=3 LOU 190 IF (NAME(3).EQ.14623.AND.NAME(4).EQ.3645) GO TO 40 LOU 200 C ************************************************************* LOU 210 RETURN LOU 220 10 CONTINUE LOU 230 DO 20 I=1,NID LOU 240 IF (NAME(1).NE.ID(I,1).OR.NAME(2).NE.ID(I,2)) GO TO 20 LOU 250 L1=ID(I,3) LOU 260 GO TO 80 LOU 270 20 CONTINUE LOU 280 DO 30 I=1,NIRD LOU 290 IF (NAME(1).NE.IRD(I,1).OR.NAME(2).NE.IRD(I,2).OR.NAME(3).NE.IRD(ILOU 300 1,3).OR.NAME(4).NE.IRD(I,4)) GO TO 30 LOU 310 L1=IRD(I,5) LOU 320 L2=IRD(I,6) LOU 330 RETURN LOU 340 30 CONTINUE LOU 350 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOU 360 40 DO 50 I=1,NITP LOU 370 IF (NAME(1).NE.ITP(I,1).OR.NAME(2).NE.ITP(I,2)) GO TO 50 LOU 380 L1=ITP(I,3) LOU 390 L2=ITP(I,4) LOU 400 GO TO 60 LOU 410 50 CONTINUE LOU 420 RETURN LOU 430 60 IF (L1.GT.47) RETURN LOU 440 DO 70 I=1,6 LOU 450 IF (NAME4(1).NE.IALPH(I)) GO TO 70 LOU 460 L2=I+1 LOU 470 RETURN LOU 480 70 CONTINUE LOU 490 C ******************************************************************LOU 500 RETURN LOU 510 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOU 520 80 IF (L1.NE.5) GO TO 90 LOU 530 C NAME(3)=TAP NAME(4)=E LOU 540 IF (NAME(3).EQ.14623.AND.NAME(4).EQ.3645) GO TO 40 LOU 550 C THIS CARD WAS 500 L2=1 LOU 560 90 L2=1 LOU 570 C ******************************************************************LOU 580 IF (L1.EQ.1) GO TO 110 LOU 590 DO 100 I=1,6 LOU 600 IF (NAME(3).NE.IALPH(I)) GO TO 100 LOU 610 L2=I+1 LOU 620 RETURN LOU 630 100 CONTINUE LOU 640 IF (L1.NE.2) RETURN LOU 641 IF (L2.NE.1) RETURN LOU 642 IF (NAME(3).NE.10631.AND.NAME(4).NE.3645) RETURN LOU 643 C THE COMMAND IS PRINT NOTE LOU 644 L1=13 LOU 645 L2=13 LOU 646 RETURN LOU 650 110 DO 120 I=1,5 LOU 660 IF (NAME(3).NE.NALPH(I)) GO TO 120 LOU 670 L2=I+2 LOU 680 RETURN LOU 690 120 CONTINUE LOU 700 RETURN LOU 710 END LOU 720 C BLOCK DATA LOOKTB LOT 10 C VERSION 5.00 LOOKTB 5/15/70 LOT 20 BLOCK DATA LOT 30 COMMON/ICODE/ NIR,NID,NIRD,LIR,LID,LIRD LOT 40 COMMON/CODE/IALPH (6),NALPH (5), ID(9,3), LOT 50 1 IR(300,4),IRD(30,6) LOT 60 C **** THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS LOT 70 COMMON/ICODTP/NITP, LITP LOT 80 COMMON/CODETP/ITP(10,4) LOT 90 C********************************************************************** LOT 100 C ADD SUB SUBTRA MULT MULTIP DIV DIVIDE RAISE LOT 110 C LOT 120 DATA IR(1,1),IR(1,2),IR(1,3),IR(1,4),IR(2,1),IR(2,2),IR(2,3), LOT 130 1 IR(2,4),IR(3,1),IR(3,2),IR(3,3),IR(3,4),IR(4,1),IR(4,2),IR(4,3), LOT 140 2IR(4,4),IR(5,1),IR(5,2),IR(5,3),IR(5,4),IR(6,1),IR(6,2),IR(6,3), LOT 150 3 IR(6,4),IR(7,1),IR(7,2),IR(7,3),IR(7,4),IR(8,1),IR(8,2),IR(8,3), LOT 160 4IR(8,4) / LOT 170 5 841,0,11,1,14420, 0,11,2,14420,15067,11,2, LOT 180 6 10056,14580,11,3,10056,14839,11,3,3181, 0,11,4, LOT 190 7 3181,6674,11,4,13158,13986,11,5/ LOT 200 C LOT 210 C SIN COS TAN COT ASIN ACOS LOT 220 C ATAN ACOT LOT 230 C SIND COSD TAND COTD ASIND ACOSD ATAND ACOTD LOT 240 C SQRT EXP EXPONE NEGEXP LOG LOGE LOGTEN ANTILO LOT 250 C SINH CONSH TANH COTH ASINH ACOSH ATANH ACOTH ABS LOT 260 C ABSULO INTEGE FRACTI LOT 270 C LOT 280 DATA IR( 9,1),IR( 9,2),IR( 9,3),IR( 9,4),IR(10,1),IR(10,2), LOT 290 1 IR(10,3),IR(10,4),IR(11,1),IR(11,2),IR(11,3),IR(11,4),IR(12,1), LOT 300 2 IR(12,2),IR(12,3),IR(12,4),IR(13,1),IR(13,2),IR(13,3),IR(13,4), LOT 310 3 IR(14,1),IR(14,2),IR(14,3),IR(14,4),IR(15,1),IR(15,2),IR(15,3), LOT 320 4 IR(15,4),IR(16,1),IR(16,2),IR(16,3),IR(16,4),IR(17,1),IR(17,2), LOT 330 5 IR(17,3),IR(17,4),IR(18,1),IR(18,2),IR(18,3),IR(18,4),IR(19,1), LOT 340 6 IR(19,2),IR(19,3),IR(19,4),IR(20,1),IR(20,2),IR(20,3),IR(20,4), LOT 350 7 IR(21,1),IR(21,2),IR(21,3),IR(21,4),IR(22,1),IR(22,2),IR(22,3), LOT 360 8 IR(22,4),IR(23,1),IR(23,2),IR(23,3),IR(23,4),IR(24,1),IR(24,2), LOT 370 9 IR(24,3),IR(24,4),IR(25,1),IR(25,2),IR(25,3),IR(25,4) / LOT 380 A 14108, 0,12,1, 2611, 0,12,2,14621, 0,12, 3, LOT 390 B 2612, 0,12, 4, 0, 0, 0, 0, 1251,10206,12, 5, LOT 400 C 0, 0, 0, 0, 825,13851,12, 6, 0, 0, 0, 0, LOT 410 D 1270,10206,12, 7, 0, 0, 0, 0, 825,14580,12, 8, LOT 420 E 14108, 2916,12, 9, 2611, 2916,12,10,14621, 2916,12,11, LOT 430 F 2612, 2916,12,12, 1251,10314,12,13/ LOT 440 DATA IR(26,1),IR(26,2),IR(26,3),IR(26,4),IR(27,1),IR(27,2), LOT 450 1 IR(27,3),IR(27,4),IR(28,1),IR(28,2),IR(28,3),IR(28,4),IR(29,1), LOT 460 2 IR(29,2),IR(29,3),IR(29,4),IR(30,1),IR(30,2),IR(30,3),IR(30,4), LOT 470 3 IR(31,1),IR(31,2),IR(31,3),IR(31,4),IR(32,1),IR(32,2),IR(32,3), LOT 480 4 IR(32,4),IR(33,1),IR(33,2),IR(33,3),IR(33,4),IR(34,1),IR(34,2), LOT 490 5 IR(34,3),IR(34,4),IR(35,1),IR(35,2),IR(35,3),IR(35,4),IR(36,1), LOT 500 6 IR(36,2),IR(36,3),IR(36,4),IR(37,1),IR(37,2),IR(37,3),IR(37,4), LOT 510 7 IR(38,1),IR(38,2),IR(38,3),IR(38,4),IR(39,1),IR(39,2),IR(39,3), LOT 520 8 IR(39,4),IR(40,1),IR(40,2),IR(40,3),IR(40,4),IR(41,1),IR(41,2), LOT 530 9 IR(41,3),IR(41,4),IR(42,1),IR(42,2),IR(42,3),IR(42,4),IR(43,1), LOT 540 A IR(43,2),IR(43,3),IR(43,4),IR(44,1),IR(44,2),IR(44,3),IR(44,4), LOT 550 B IR(45,1),IR(45,2),IR(45,3),IR(45,4)/ LOT 560 C 825,13959,12,14, 1270,10314,12,15, 825,14688,12,16, LOT 570 D 14328,14580,12,17, LOT 580 E 4309, 0,12,18, 4309,11318,12,18,10348, 4309,12,19, LOT 590 F 9160, 0,12,20, 9160, 3645,12,20, 9160,14729,12,21, LOT 600 G 1127, 6900,12,22,14108, 5832,12,23,2611, 5832,12,24, LOT 610 H 14621, 5832,12,25, 2612, 5832,12,26, 1251,10422,12,27, LOT 620 I 825,14067,12,28, 1270,10422,12,29, LOT 630 J 825,14796,12,30, 802, 0,12,31/ LOT 640 DATA IR(46,1),IR(46,2),IR(46,3),IR(46,4),IR(47,1),IR(47,2), LOT 650 1 IR(47,3),IR(47,4),IR(48,1),IR(48,2),IR(48,3),IR(48,4)/ LOT 665 2 802,11280,12,31, LOT 670 3 6959, 3839,12,32, 4861, 2736,12,33/ LOT 680 C LOT 690 C GENERA SET FIXED FLOATI PLOT SPACE CGS SI LOT 700 C LOT 710 DATA IR(49,1),IR(49,2),IR(49,3),IR(49,4),IR(50,1),IR(50,2), LOT 720 1 IR(50,3),IR(50,4),IR(51,1),IR(51,2),IR(51,3),IR(51,4),IR(52,1), LOT 730 2 IR(52,2),IR(52,3),IR(52,4),IR(53,1),IR(53,2),IR(53,3),IR(53,4), LOT 740 3 IR(54,1),IR(54,2),IR(54,3),IR(54,4),IR(55,1),IR(55,2),IR(55,3), LOT 750 4 IR(55,4),IR(56,1),IR(56,2),IR(56,3),IR(56,4),IR(57,1),IR(57,2), LOT 760 5 IR(57,3),IR(57,4),IR(58,1),IR(58,2),IR(58,3),IR(58,4)/ LOT 770 6 5252, 4132,13, 1,14006, 0,13, 2, 4641, 3753,13, 3, LOT 780 7 4713, 1278,13, 4,12003,14580,13, 5, 0, 0, 0, 0, LOT 790 8 14284, 2322,13, 9, 2395, 0,13,10,14094, 0,13,11, LOT 800 9 0, 0, 0, 0/ LOT 810 C LOT 820 C BEGIN SCAN REPEAT EXECUT PERFOR INCREM RESTOR IFLT IFEQ LOT 830 C IFGT IFGE IFNE IFLE LOT 840 C LOT 850 DATA IR(59,1),IR(59,2),IR(59,3),IR(59,4),IR(60,1),IR(60,2), LOT 860 1 IR(60,3),IR(60,4),IR(61,1),IR(61,2),IR(61,3),IR(61,4),IR(62,1), LOT 870 2 IR(62,2),IR(62,3),IR(62,4),IR(63,1),IR(63,2),IR(63,3),IR(63,4), LOT 880 3 IR(64,1),IR(64,2),IR(64,3),IR(64,4),IR(65,1),IR(65,2),IR(65,3), LOT 890 4 IR(65,4),IR(66,1),IR(66,2),IR(66,3),IR(66,4),IR(67,1),IR(67,2), LOT 900 5 IR(67,3),IR(67,4),IR(68,1),IR(68,2),IR(68,3),IR(68,4),IR(69,1), LOT 910 6 IR(69,2),IR(69,3),IR(69,4),IR(70,1),IR(70,2),IR(70,3),IR(70,4), LOT 920 7 IR(71,1),IR(71,2),IR(71,3),IR(71,4)/ LOT 930 8 1600,6939,14, 1,13933,10206,14, 2,13273, 3692,14, 3, LOT 940 9 4298, 2774,14, 3,11817, 4797,14, 3, 6942,13270,14, 6, LOT 950 A 13276,15003,14, 8, 6735,14580,14, 9, 6728,12393,14,10, LOT 960 B 6730,14580,14,11, 6730, 3645,14,12, 6737, 3645,14,13, LOT 970 C 6735, 3645,14,14/ LOT 980 C LOT 990 C MDEFIN ADEFIN AERASE MZERO AZERO MERASE MIDENT MSUBTR MDIAG0 LOT1000 C LOT1010 DATA IR(72,1),IR(72,2),IR(72,3),IR(72,4),IR(73,1),IR(73,2), LOT1020 1 IR(73,3),IR(73,4),IR(74,1),IR(74,2),IR(74,3),IR(74,4),IR(75,1), LOT1030 2 IR(75,2),IR(75,3),IR(75,4),IR(76,1),IR(76,2),IR(76,3),IR(76,4), LOT1040 3 IR(77,1),IR(77,2),IR(77,3),IR(77,4),IR(78,1),IR(78,2),IR(78,3), LOT1050 4 IR(78,4),IR(79,1),IR(79,2),IR(79,3),IR(79,4),IR(80,1),IR(80,2), LOT1060 5 IR(80,3),IR(80,4)/ LOT1070 6 9590,4631,15,1, 842, 4631,15, 1, 882, 1247,15, 2, LOT1080 7 10184,13527,15, 2, 1436,13527,15, 2, 9630, 1247,15, 2, LOT1090 8 9724, 4043,15, 3,10011, 2016,18, 2, 9594, 933,15, 4/ LOT1100 C LOT1110 C MINVER INVERT MMULTI LOT1120 C LOT1130 DATA IR(81,1),IR(81,2),IR(81,3),IR(81,4),IR(82,1),IR(82,2), LOT1140 1 IR(82,3),IR(82,4),IR(83,1),IR(83,2),IR(83,3),IR(83,4)/ LOT1150 2 9734,16191,16, 1, 6961, 4151,16, 1, 9849, 9297,17, 1/ LOT1160 C LOT1170 C MMULT MRAISE LOT1180 C LOT1190 DATA IR(84,1),IR(84,2),IR(84,3),IR(84,4),IR(85,1),IR(85,2), LOT1200 1 IR(85,3),IR(85,4)/ LOT1210 2 9849, 9288,17, 1, 9964, 7079,17, 2/ LOT1220 LOT1230 C MADD MSUB MTRANS ATRANS AADD ASUB AMULT AMULTI ASUBST LOT1240 C MSCALA ADIVID ADIV ARAISE LOT1250 C LOT1260 DATA IR(86,1),IR(86,2),IR(86,3),IR(86,4),IR(87,1),IR(87,2), LOT1270 6 IR(87,3),IR(87,4),IR(88,1),IR(88,2),IR(88,3),IR(88,4), LOT1280 7 IR(89,1),IR(89,2),IR(89,3),IR(89,4),IR(90,1),IR(90,2),IR(90,3), LOT1290 8 IR(90,4),IR(91,1),IR(91,2),IR(91,3),IR(91,4),IR(92,1),IR(92,2), LOT1300 9 IR(92,3),IR(92,4),IR(93,1),IR(93,2),IR(93,3),IR(93,4),IR(94,1), LOT1310 A IR(94,2),IR(94,3),IR(94,4),IR(95,1),IR(95,2),IR(95,3),IR(95,4), LOT1320 B IR(96,1),IR(96,2),IR(96,3),IR(96,4),IR(97,1),IR(97,2),IR(97,3), LOT1330 C IR(97,4),IR(98,1),IR(98,2),IR(98,3),IR(98,4)/ LOT1340 D 9508, 2916,18, 1,10011, 1458,18, 2,10035, 1126,18, 3, LOT1350 E 1287, 1126,18, 3, 760, 2916,18, 4, 1263, 1458,18, 5, LOT1360 F 1101, 9288,18, 6, 1101, 9297,18, 6, 1263, 2016,18, 5, LOT1370 G 9993, 1054,18, 6, 846,16285,18, 7, 846,16038,18, 7, LOT1380 H 1216, 7079,18, 8/ LOT1390 C LOT1400 C LOT1410 C LOT1420 DATA IR( 99,1),IR( 99,2),IR( 99,3),IR( 99,4),IR(100,1), LOT1430 1 IR(100,2),IR(100,3),IR(100,4),IR(101,1),IR(101,2),IR(101,3), LOT1440 2 IR(101,4),IR(102,1),IR(102,2),IR(102,3),IR(102,4),IR(103,1), LOT1450 3 IR(103,2),IR(103,3),IR(103,4),IR(104,1),IR(104,2),IR(104,3), LOT1460 4 IR(104,4)/ LOT1470 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, LOT1480 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ LOT1490 C LOT1500 C PARSUM PARPRO RMS AVERAG SUM LOT1510 C LOT1520 DATA IR(105,1),IR(105,2),IR(105,3),IR(105,4),IR(106,1), LOT1530 1 IR(106,2),IR(106,3),IR(106,4),IR(107,1),IR(107,2),IR(107,3), LOT1540 2 IR(107,4),IR(108,1),IR(108,2),IR(108,3),IR(108,4),IR(109,1), LOT1550 3 IR(109,2),IR(109,3),IR(109,4)/ LOT1560 4 11709,14431,20, 1,11709,12165,20,2,13492, 0,20, 3, LOT1570 5 1328,13156,20, 4,14431, 0,20, 5/ LOT1580 C LOT1590 C ROWSUM PRODUC DEFINE MAX MAXIMU MIN MINIMU SORT ORDER LOT1600 C ERASE EXCHAN FLIP CHANGE HIERAR LIST NULL LOT1610 C LOT1620 DATA IR(110,1),IR(110,2),IR(110,3),IR(110,4),IR(111,1), LOT1630 1 IR(111,2),IR(111,3),IR(111,4),IR(112,1),IR(112,2),IR(112,3), LOT1640 2 IR(112,4),IR(113,1),IR(113,2),IR(113,3),IR(113,4),IR(114,1), LOT1650 3 IR(114,2),IR(114,3),IR(114,4),IR(115,1),IR(115,2),IR(115,3), LOT1660 4 IR(115,4),IR(116,1),IR(116,2),IR(116,3),IR(116,4),IR(117,1), LOT1670 5 IR(117,2),IR(117,3),IR(117,4),IR(118,1),IR(118,2),IR(118,3), LOT1680 6 IR(118,4),IR(119,1),IR(119,2),IR(119,3),IR(119,4),IR(120,1), LOT1690 7 IR(120,2),IR(120,3),IR(120,4),IR(121,1),IR(121,2),IR(121,3), LOT1700 8 IR(121,4),IR(122,1),IR(122,2),IR(122,3),IR(122,4),IR(123,1), LOT1710 9 IR(123,2),IR(123,3),IR(123,4),IR(124,1),IR(124,2),IR(124,3), LOT1720 A IR(124,4),IR(125,1),IR(125,2),IR(125,3),IR(125,4),IR(126,1), LOT1730 B IR(126,2),IR(126,3),IR(126,4)/ LOT1740 C 13550,14431,21, 1,12165, 3486,21, 2, 3057, 6944,21, 3, LOT1750 D 9528, 0,21, 5, 9528, 6933,21, 5, 9734, 0,21, 6, LOT1760 E 9734, 6933,21, 6,14274,14580,21, 8,11425, 4131,21, 9, LOT1770 F 4132,13986,21,10, 4296, 5873,21,11, 4707,11664,21,12, LOT1780 G 2404,10400,21,13, 6080,13167,21,14, 9010,14580,21,15, LOT1790 H 0, 0, 0, 0,10785, 8748,21,17/ LOT1800 C LOT1810 C PLOYFI SPOLYF FIT SFIT SOLVE MORTHO LOT1820 C LOT1830 DATA IR(127,1),IR(127,2),IR(127,3),IR(127,4),IR(128,1), LOT1840 1 IR(128,2),IR(128,3),IR(128,4),IR(129,1),IR(129,2),IR(129,3), LOT1850 2 IR(129,4),IR(130,1),IR(130,2),IR(130,3),IR(130,4),IR(131,1), LOT1860 3 IR(131,2),IR(131,3),IR(131,4),IR(132,1),IR(132,2),IR(132,3), LOT1870 4 IR(132,4)/ LOT1880 5 12081,18396,22, 1,14298, 9429,22, 2, 4637, 0,22, 3, LOT1890 6 14022,14580,22, 4,14268,16173,16, 2, 9900,14811,22, 5/ LOT1900 C LOT1910 C COUNT SHORTE EXPAND DUPLIC MOVE DIM AMOVE LOT1920 C MMOVE PROMOT DEMOTE DIMENS LOT1930 C LOT1940 DATA IR(133,1),IR(133,2),IR(133,3),IR(133,4),IR(134,1), LOT1950 1 IR(134,2),IR(134,3),IR(134,4),IR(135,1),IR(135,2),IR(135,3), LOT1960 2 IR(135,4),IR(136,1),IR(136,2),IR(136,3),IR(136,4),IR(137,1), LOT1970 3 IR(137,2),IR(137,3),IR(137,4),IR(138,1),IR(138,2),IR(138,3), LOT1980 4 IR(138,4),IR(139,1),IR(139,2),IR(139,3),IR(139,4),IR(140,1), LOT1990 5 IR(140,2),IR(140,3),IR(140,4),IR(141,1),IR(141,2),IR(141,3), LOT2000 6 IR(141,4),IR(142,1),IR(142,2),IR(142,3),IR(142,4),IR(143,1), LOT2010 7 IR(143,2),IR(143,3),IR(143,4),IR(144,1),IR(144,2),IR(144,3), LOT2020 8 IR(144,4),IR(145,1),IR(145,2),IR(145,3),IR(145,4)/ LOT2030 9 0, 0, 0, 0, 0, 0, 0, 0, 2613,10746,23, 2, LOT2040 A 14082,13667,23, 3, 4309, 1111,23, 4, 3499, 8994,23, 5, LOT2050 B 9904, 3645,23, 6, 3172, 0,23,12, 1095,16173,23, 6, LOT2060 C 9843,16173,23, 6,12165, 9902,23,10, 3064,11480,23,11, LOT2070 D 3172, 4042,23,12/ LOT2080 C LOT2090 C STATIS SSTATI RANKS ACCURA LOT2100 C LOT2110 DATA IR(146,1),IR(146,2),IR(146,3),IR(146,4),IR(147,1), LOT2120 1 IR(147,2),IR(147,3),IR(147,4),IR(148,1),IR(148,2),IR(148,3), LOT2130 2 IR(148,4),IR(149,1),IR(149,2),IR(149,3),IR(149,4),IR(150,1), LOT2140 3 IR(150,2),IR(150,3),IR(150,4)/ LOT2150 4 14392,14842,24, 1,14384, 1278,24, 2,13163, 8532,24, 3, LOT2160 5 813,15796,11, 6, 0, 0, 0, 0/ LOT2170 C LOT2180 C SELECT SEARCH CENSOR LOT2190 C LOT2200 DATA IR(151,1),IR(151,2),IR(151,3),IR(151,4),IR(152,1), LOT2210 1 IR(152,2),IR(152,3),IR(152,4),IR(153,1),IR(153,2),IR(153,3), LOT2220 2 IR(153,4)/ LOT2230 3 13998, 3746,25, 1,13987,13211,25, 2, 2336,14274,25, 3/ LOT2240 C LOT2250 C MVECDI MVECMA MMATV LOT2260 C LOT2270 DATA IR(154,1),IR(154,2),IR(154,3),IR(154,4),IR(155,1), LOT2280 1 IR(155,2),IR(155,3),IR(155,4),IR(156,1),IR(156,2),IR(156,3), LOT2290 2 IR(156,4),IR(157,1),IR(157,2),IR(157,3),IR(157,4),IR(158,1), LOT2300 3 IR(158,2),IR(158,3),IR(158,4),IR(159,1),IR(159,2),IR(159,3), LOT2310 4 IR(159,4)/ LOT2320 5 10076, 2304,26, 1, 0, 0, 0, 0,10076, 2539,26, 2, LOT2330 6 0, 0, 0, 0, 9829,15179,26, 3, 0, 0, 0, 0/ LOT2340 C LOT2350 C MKRONE MTRIAN MEIGEN LOT2360 C LOT2370 DATA IR(160,1),IR(160,2),IR(160,3),IR(160,4),IR(161,1), LOT2380 1 IR(161,2),IR(161,3),IR(161,4),IR(162,1),IR(162,2),IR(162,3), LOT2390 2 IR(162,4)/ LOT2400 3 9792,11318,17, 3,10035, 6602,17, 4, 9621, 5252,17, 5/ LOT2410 C LOT2420 C INTERP LOT2430 C LOT2440 DATA IR(163,1),IR(163,2),IR(163,3),IR(163,4)/ LOT2450 1 6959, 4147,25, 4/ LOT2460 C LOT2470 C MPROPE APROPE SMPROP SAPROP LOT2480 DATA IR(164,1),IR(164,2),IR(164,3),IR(164,4),IR(165,1), LOT2490 1 IR(165,2),IR(165,3),IR(165,4),IR(166,1),IR(166,2),IR(166,3), LOT2500 2 IR(166,4),IR(167,1),IR(167,2),IR(167,3),IR(167,4)/ LOT2510 3 9927,11372,27, 1, 1179,11372,27, 2, LOT2520 4 14218,13543,27, 3,13894,13543,27, 4/ LOT2530 C LOT2540 C ITERATE ISETUP ISOLATE LOT2550 C LOT2560 DATA IR(168,1),IR(168,2),IR(168,3),IR(168,4),IR(169,1), LOT2570 1 IR(169,2),IR(169,3),IR(169,4),IR(170,1),IR(170,2),IR(170,3), LOT2580 2 IR(170,4)/ LOT2590 3 7106,13169,28, 1, 7079,15163,28, 2, 7089, 8795,28, 3/ LOT2600 C LOT2610 C EXTREMA SEPARATE INSERT MAXMIN LOT2620 C LOT2630 DATA IR(171,1),IR(171,2),IR(171,3),IR(171,4),IR(172,1), LOT2640 1 IR(172,2),IR(172,3),IR(172,4),IR(173,1),IR(173,2),IR(173,3), LOT2650 2 IR(173,4),IR(174,1),IR(174,2),IR(174,3),IR(174,4)/ LOT2660 3 4313,13270,29, 4,14002, 1216,29, 2, 6958, 4151,29, 3, LOT2670 4 9528, 9734,29, 4/ LOT2680 C LOT2690 C LAGUER NORMLA HERMIT UCHEBY TCHEBY LEGEND LOT2700 C LOT2710 DATA IR(175,1),IR(175,2),IR(175,3),IR(175,4),IR(176,1), LOT2720 1 IR(176,2),IR(176,3),IR(176,4),IR(177,1),IR(177,2),IR(177,3), LOT2730 2 IR(177,4),IR(178,1),IR(178,2),IR(178,3),IR(178,4),IR(179,1), LOT2740 3 IR(179,2),IR(179,3),IR(179,4),IR(180,1),IR(180,2),IR(180,3), LOT2750 4 IR(180,4)/ LOT2760 5 8782,15462,19, 2,10629, 9802,19, 1, 5985, 9740,19, 3, LOT2770 6 15398, 3724,19, 4,14669, 3724,19, 6, 8890, 4027,19, 5/ LOT2780 C LOT2790 C BJZERO BJONE BYZERO BYONE BIZERO BIONE BKZERO BKZONE LOT2800 C EXIZER EXIONE EXKZER EXKONE KBIZER KBIONE KBKZER KBKONE LOT2810 C LOT2820 DATA IR(181,1),IR(181,2),IR(181,3),IR(181,4),IR(182,1), LOT2830 1 IR(182,2),IR(182,3),IR(182,4),IR(183,1),IR(183,2),IR(183,3), LOT2840 2 IR(183,4),IR(184,1),IR(184,2),IR(184,3),IR(184,4),IR(185,1), LOT2850 3 IR(185,2),IR(185,3),IR(185,4),IR(186,1),IR(186,2),IR(186,3), LOT2860 4 IR(186,4),IR(187,1),IR(187,2),IR(187,3),IR(187,4),IR(188,1), LOT2870 5 IR(188,2),IR(188,3),IR(188,4),IR(189,1),IR(189,2),IR(189,3), LOT2880 6 IR(189,4),IR(190,1),IR(190,2),IR(190,3),IR(190,4),IR(191,1), LOT2890 7 IR(191,2),IR(191,3),IR(191,4),IR(192,1),IR(192,2),IR(192,3), LOT2900 8 IR(192,4),IR(193,1),IR(193,2),IR(193,3),IR(193,4),IR(194,1), LOT2910 9 IR(194,2),IR(194,3),IR(194,4),IR(195,1),IR(195,2),IR(195,3), LOT2920 A IR(195,4),IR(196,1),IR(196,2),IR(196,3),IR(196,4)/ LOT2930 B 1754, 4146,30, 1, 1743,10341,30, 2, 2159, 4146,30, 3, LOT2940 C 2148,10341,30, 4, 1727, 4146,30, 5, 1716,10341,30, 6, LOT2950 D 1781, 4146,30, 7, 1770,10341,30, 8, 4302,19107,30, 9, LOT2960 E 4302,11318,30,10, 4304,19107,30,11, 4304,11318,30,12, LOT2970 F 8082,19107,30,13, 8082,11318,30,14, 8084,19107,30,15, LOT2980 G 8084,11318,30,16/ LOT2990 C LOT3000 C KEXIZE KEXION KEXKZE KEXKON CIZERO CIONE CKZERO CKONE LOT3010 C CEIZER CEIONE CEKZER CEKONE INTJO BESJN HARMON BESIN LOT3020 C BESKN LOT3030 C LOT3040 DATA IR(197,1),IR(197,2),IR(197,3),IR(197,4),IR(198,1), LOT3050 1 IR(198,2),IR(198,3),IR(198,4),IR(199,1),IR(199,2),IR(199,3), LOT3060 2 IR(199,4),IR(200,1),IR(200,2),IR(200,3),IR(200,4),IR(201,1), LOT3070 3 IR(201,2),IR(201,3),IR(201,4),IR(202,1),IR(202,2),IR(202,3), LOT3080 4 IR(202,4),IR(203,1),IR(203,2),IR(203,3),IR(203,4),IR(204,1), LOT3090 5 IR(204,2),IR(204,3),IR(204,4),IR(205,1),IR(205,2),IR(205,3), LOT3100 6 IR(205,4),IR(206,1),IR(206,2),IR(206,3),IR(206,4),IR(207,1), LOT3110 7 IR(207,2),IR(207,3),IR(207,4),IR(208,1),IR(208,2),IR(208,3), LOT3120 8 IR(208,4),IR(209,1),IR(209,2),IR(209,3),IR(209,4),IR(210,1), LOT3130 9 IR(210,2),IR(210,3),IR(210,4),IR(211,1),IR(211,2),IR(211,3), LOT3140 A IR(211,4),IR(212,1),IR(212,2),IR(212,3),IR(212,4),IR(213,1), LOT3150 B IR(213,2),IR(213,3),IR(213,4)/ LOT3160 C 8178, 7268,30,17, 8178, 6980,30,18, 8178, 8726,30,19, LOT3170 D 8178, 8438,30,20, 2456, 4146,30,21, 2445,10341,30,22, LOT3180 E 2510, 4146,30,23, 2499,10341,30,24, 2331,19107,30,25, LOT3190 F 2331,11318,30,26, 2333,19107,30,27, 2333,11318,30,28, LOT3200 G 6959, 7695,30,29, 1612, 7668,30,32, 5877, 9896,30,37, LOT3210 H 1612, 6939,30,38, 1612, 8397,30,39/ LOT3220 C LOT3230 C TWOWAY LOT3240 C LOT3250 DATA IR(214,1),IR(214,2),IR(214,3),IR(214,4)/ LOT3260 1 15216,16819,24,6/ LOT3270 C LOT3280 C FLEXIB LOT3290 C LOT3300 DATA IR(215,1),IR(215,2),IR(215,3),IR(215,4)/ LOT3310 1 4703,17741,13,12/ LOT3320 C LOT3330 C SQUARE LOT3340 C LOT3350 DATA IR(216,1),IR(216,2),IR(216,3),IR(216,4)/ LOT3360 1 14331, 1220,12,34/ LOT3370 C LOT3380 C ACOALE AAVERA LOT3390 C LOT3400 DATA IR(217,1),IR(217,2),IR(217,3),IR(217,4),IR(218,1), LOT3410 1 IR(218,2),IR(218,3),IR(218,4)/ LOT3420 2 825, 1058,18, 9, 778, 4132,18,10/ LOT3430 C LOT3440 C MATCH LOT3450 C LOT3460 DATA IR(219,1),IR(219,2),IR(219,3),IR(219,4)/ LOT3470 1 9524,2403,25,5/ LOT3480 C LOT3490 C HISTOG NHISTO FREQUE LOT3500 C LOT3510 DATA IR(220,1),IR(220,2),IR(220,3),IR(220,4),IR(221,1), LOT3520 1 IR(221,2),IR(221,3),IR(221,4),IR(222,1),IR(222,2),IR(222,3), LOT3530 2 IR(222,4)/ LOT3540 3 6094,14992,24, 8,10431,14406,24, 9, 4865,12965,24,10/ LOT3550 C LOT3560 C CORREL SCORRE LOT3570 C LOT3580 DATA IR(223,1),IR(223,2),IR(223,3),IR(223,4),IR(224,1), LOT3590 1 IR(224,2),IR(224,3),IR(224,4)/ LOT3600 2 2610,13269,24,11,13947,13613,24,12/ LOT3610 C LOT3620 C COMPARE,ONEWAY,SONEWAY,ERROR,CERF,STWOWAY LOT3630 C LOT3640 DATA IR(225,1),IR(225,2),IR(225,3),IR(225,4),IR(226,1),IR(226,2), LOT3650 1 IR(226,3),IR(226,4),IR(227,1),IR(227,2),IR(227,3),IR(227,4), LOT3660 2 IR(228,1),IR(228,2),IR(228,3),IR(228,4),IR(229,1),IR(229,2), LOT3670 3 IR(229,3),IR(229,4),IR(230,1),IR(230,2),IR(230,3),IR(230,4)/ LOT3680 4 2605,11709,14,15,11318,16819,24,13,14270, 4267,24,14, LOT3690 5 4149,11421,21,18, 2340, 4374,21,19,14414,11557,24, 7/ LOT3700 C LOT3710 C CTOF,FTOC,ATOMIC,MOLWT,EINSTEIN,PFTRANS,PFATOMIC,PARTFUNCT,BOLDISTLOT3720 C LOT3730 DATA IR(231,1),IR(231,2),IR(231,3),IR(231,4),IR(232,1),IR(232,2),LOT3740 1 IR(232,3),IR(232,4),IR(233,1),IR(233,2),IR(233,3),IR(233,4),LOT3750 2 IR(234,1),IR(234,2),IR(234,3),IR(234,4),IR(235,1),IR(235,2),LOT3760 3 IR(235,3),IR(235,4),IR(236,1),IR(236,2),IR(236,3),IR(236,4),LOT3770 4 IR(237,1),IR(237,2),IR(237,3),IR(237,4),IR(238,1),IR(238,2),LOT3780 5 IR(238,3),IR(238,4),IR(239,1),IR(239,2),IR(239,3),IR(239,4)/LOT3790 6 2742, 4374,31, 1, 4929, 2187,31, 2, 1284, 9723,31, 3, 9894,17307LOT3800 7 ,31, 4, 3902,14396,31,5,11846,13163,31, 6,11827,14998,31, 7,11709LOT3810 8 ,14763,31, 8, 1875, 3178,31, 9/ LOT3820 C LOT3830 C ROUND LOT3840 C LOT3850 DATA IR(240,1),IR(240,2),IR(240,3),IR(240,4)/13548,10314,13,14/ LOT3860 C LOT3870 C COMPLEX ARITHMETIC - CADD, CSUBTRACT, CMULTIPLY, CDIVIDE, LOT3880 C CRECTANGULAR, CPOLAR LOT3890 C LOT3900 DATA IR(241,1),IR(241,2),IR(241,3),IR(241,4),IR(242,1),IR(242,2),LOT3910 1 IR(242,3),IR(242,4),IR(243,1),IR(243,2),IR(243,3),IR(243,4),LOT3920 2 IR(244,1),IR(244,2),IR(244,3),IR(244,4),IR(245,1),IR(245,2),LOT3930 3 IR(245,3),IR(245,4),IR(246,1),IR(246,2),IR(246,3),IR(246,4)/LOT3940 4 2218, 2916,32, 1, 2721, 2016,32, 2, 2559, 9297,32, 3, LOT3950 5 2304,16285,32, 4, 2678, 2728,32, 5, 2634, 8793,32, 6/ LOT3960 C LOT3970 C ****************************************************************** LOT3980 C * * LOT3990 C * USED THRU IR(246,4):AVAILABLE IR(247,1) THRU IR(300,4) * LOT4000 C * * LOT4010 C ****************************************************************** LOT4020 C LOT4030 C RESET PRINT PUNCH READ ABRIDG APRINT MPRINT LOT4040 C LOT4050 DATA ID(1,1),ID(1,2),ID(1,3),ID(2,1),ID(2,2),ID(2,3),ID(3,1), LOT4060 1 ID(3,2),ID(3,3),ID(4,1),ID(4,2),ID(4,3),ID(5,1),ID(5,2),ID(5,3), LOT4070 2 ID(6,1),ID(6,2),ID(6,3),ID(7,1),ID(7,2),ID(7,3)/ LOT4080 3 13276, 4185,1,12159,10746,2,12245, 2403,3,13258, 2916,5, LOT4090 4 801, 6676,6, 1179, 6959,4, 9927, 6959,7/ LOT4100 C LOT4110 C NPRINT LOT4120 C LOT4130 DATA ID(8,1),ID(8,2),ID(8,3)/ LOT4140 1 10656, 6959,8/ LOT4150 C LOT4160 C A B C D E F LOT4170 C LOT4180 DATA IALPH(1),IALPH(2),IALPH(3),IALPH(4),IALPH(5),IALPH(6)/ LOT4190 1 729, 1458, 2187, 2916, 3645, 4374/ LOT4200 C LOT4210 C V W X Y Z LOT4220 C LOT4230 DATA NALPH(1),NALPH(2),NALPH(3),NALPH(4),NALPH(5)/ LOT4240 1 16038,16767,17496,18225,18954/ LOT4250 C LOT4260 C NO LIST CLOSE UP NEW PAGE LOT4270 C M(XX,) M(X,AX)=M(X,X) M(XAX,) M(AD) M(DA) M(AV) M(V,A) LOT4280 C LOT4290 DATA IRD( 1,1),IRD( 1,2),IRD( 1,3),IRD( 1,4),IRD( 1,5), LOT4300 1 IRD( 1,6),IRD( 2,1),IRD( 2,2),IRD( 2,3),IRD( 2,4),IRD( 2,5), LOT4310 2 IRD( 2,6),IRD( 3,1),IRD( 3,2),IRD( 3,3),IRD( 3,4),IRD( 3,5), LOT4320 3 IRD( 3,6),IRD( 4,1),IRD( 4,2),IRD( 4,3),IRD( 4,4),IRD( 4,5), LOT4330 4 IRD( 4,6),IRD( 5,1),IRD( 5,2),IRD( 5,3),IRD( 5,4),IRD( 5,5), LOT4340 5 IRD( 5,6),IRD( 6,1),IRD( 6,2),IRD( 6,3),IRD( 6,4),IRD( 6,5), LOT4350 6 IRD( 6,6),IRD( 7,1),IRD( 7,2),IRD( 7,3),IRD( 7,4),IRD( 7,5), LOT4360 7 IRD( 7,6),IRD( 8,1),IRD( 8,2),IRD( 8,3),IRD( 8,4),IRD( 8,5), LOT4370 8 IRD( 8,6),IRD( 9,1),IRD( 9,2),IRD( 9,3),IRD( 9,4),IRD( 9,5), LOT4380 9 IRD( 9,6),IRD(10,1),IRD(10,2),IRD(10,3),IRD(10,4),IRD(10,5), LOT4390 A IRD(10,6)/ LOT4400 B 10611, 0, 9010,14580,21,16, 2526,13986,15741, 0,23, 1, LOT4410 C 10364, 0,11698, 3645,13, 8, 9477, 0,18144, 0,51, 1, LOT4420 D 9477, 0,17496, 0,51, 2, 9477, 0,17547, 0,51, 3, LOT4430 E 9477, 0, 837, 0,52, 1, 9477, 0,2943, 0,52, 2, LOT4440 F 9477, 0, 1323, 0,53, 1, 9477, 0,16038, 0,53, 2/ LOT4450 C LOT4460 C DUMMY A B C D LOT4470 C LOT4480 DATA IRD(11,1),IRD(11,2),IRD(11,3),IRD(11,4),IRD(11,5), LOT4490 1 IRD(11,6),IRD(12,1),IRD(12,2),IRD(12,3),IRD(12,4),IRD(12,5), LOT4500 2 IRD(12,6),IRD(13,1),IRD(13,2),IRD(13,3),IRD(13,4),IRD(13,5), LOT4510 3 IRD(13,6),IRD(14,1),IRD(14,2),IRD(14,3),IRD(14,4),IRD(14,5), LOT4520 4 IRD(14,6),IRD(15,1),IRD(15,2),IRD(15,3),IRD(15,4),IRD(15,5), LOT4530 5 IRD(15,6)/ LOT4540 6 0, 0, 0, 0, 0, 0, 3496,10152, 729, 0,54, 2, LOT4550 7 3496,10152, 1458, 0,54, 3, 3496,10152,2187, 0,54, 4, LOT4560 8 3496,10152, 2916, 0,54, 5/ LOT4570 C LOT4580 C ROW SUM F PROBAB LOT4590 C LOT4600 DATA IRD(16,1),IRD(16,2),IRD(16,3),IRD(16,4),IRD(16,5), LOT4610 1 IRD(16,6),IRD(17,1),IRD(17,2),IRD(17,3),IRD(17,4),IRD(17,5), LOT4620 2 IRD(17,6)/ LOT4630 3 13550, 0,14431, 0,21,1, 4374, 0,12165, 1487,24,5/ LOT4640 C LOT4650 C ELLIPT FIRST ELLIPT SECOND ZEROS BJZERO ZEROS BJONE LOT4660 C STRUVE ZERO STRUVE ONE LOT4670 C LOT4680 DATA IRD(18,1),IRD(18,2),IRD(18,3),IRD(18,4),IRD(18,5), LOT4690 1 IRD(18,6),IRD(19,1),IRD(19,2),IRD(19,3),IRD(19,4),IRD(19,5), LOT4700 2 IRD(19,6),IRD(20,1),IRD(20,2),IRD(20,3),IRD(20,4),IRD(20,5), LOT4710 3 IRD(20,6),IRD(21,1),IRD(21,2),IRD(21,3),IRD(21,4),IRD(21,5), LOT4720 4 IRD(21,6),IRD(22,1),IRD(22,2),IRD(22,3),IRD(22,4),IRD(22,5), LOT4730 5 IRD(22,6),IRD(23,1),IRD(23,2),IRD(23,3),IRD(23,4),IRD(23,5), LOT4740 6 IRD(23,6)/ LOT4750 7 3981, 7013, 4635,14391,30,30, 3981, 7013,13989,11317,30,31, LOT4760 8 19107,11448, 1754, 4146,30,33,19107,11448, 1743,10341,30,34, LOT4770 9 14409,15908,19107,10935,30,35,14409,15908,11318, 0,30,36/ LOT4780 C LOT4790 C LOT4800 C LOT4810 DATA IRD(24,1),IRD(24,2),IRD(24,3),IRD(24,4),IRD(24,5), LOT4820 1 IRD(24,6)/ LOT4830 2 0, 0, 0, 0, 0, 0/ LOT4840 C LOT4850 C PAGE PLOT LOT4860 C LOT4870 DATA IRD(25,1),IRD(25,2),IRD(25,3),IRD(25,4),IRD(25,5), LOT4880 1 IRD(25,6)/ LOT4890 2 11698, 3645,12003,14580,13, 6/ LOT4900 C LOT4910 C GAUSS QUADRATURE LOT4920 C LOT4930 DATA IRD(26,1),IRD(26,2),IRD(26,3),IRD(26,4),IRD(26,5), LOT4940 1 IRD(26,6)/ LOT4950 2 5151,14364,12961, 3403,24, 4/ LOT4960 C LOT4970 C DUMMY E F UNIFOR RANDOM LOT4980 C LOT4990 DATA IRD(27,1),IRD(27,2),IRD(27,3),IRD(27,4),IRD(27,5), LOT5000 1 IRD(27,6),IRD(28,1),IRD(28,2),IRD(28,3),IRD(28,4),IRD(28,5), LOT5010 2 IRD(28,6),IRD(29,1),IRD(29,2),IRD(29,3),IRD(29,4),IRD(29,5), LOT5020 3 IRD(29,6)/ 3496,10152, 3645, 0,54, 6, 3496,10152, 4374, 0, LOT5015 4 54, 7,15696, 4797,13163, 3334,24,15/ LOT5020 C LOT5030 C ****************************************************************** LOT5040 C * * LOT5050 C * USED THRU IRD(29,6): AVAILABLE IRD(30,1) THRU IRD(30,6) * LOT5060 C * * LOT5070 C ****************************************************************** LOT5080 C**** THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS LOT5090 C LOT5100 C READ TAPE,CREAD TAPE,WRITE TAPE,SETTAPE,CSET TAPE,ENDFILE TAP, LOT5110 C REWIND TAPE, SKIP TAPE,BACKSPACE TAPE LOT5120 C LOT5130 DATA ITP(1,1),ITP(1,2),ITP(1,3),ITP(1,4),ITP(2,1), LOT5140 1 ITP(2,2),ITP(2,3),ITP(2,4),ITP(3,1),ITP(3,2),ITP(3,3), LOT5150 2 ITP(3,4),ITP(4,1),ITP(4,2),ITP(4,3),ITP(4,4),ITP(5,1), LOT5160 3 ITP(5,2),ITP(5,3),ITP(5,4),ITP(6,1),ITP(6,2),ITP(6,3), LOT5170 4 ITP(6,4),ITP(7,1),ITP(7,2),ITP(7,3),ITP(7,4),ITP(8,1), LOT5180 5 ITP(8,2),ITP(8,3),ITP(8,4),ITP(9,1),ITP(9,2),ITP(9,3), LOT5190 6 ITP(9,4)/ LOT5200 7 13258, 2916,45,1, 2678, 837,46,1,17262,14715,47,1, LOT5210 8 14006, 0,48,1, 2705,14580,49,1, 4027, 4629,50,1, LOT5220 9 13280, 6943,50,2,14157,11664,50,3, 1488, 8548,50,4/ LOT5230 C********************************************************************** LOT5240 C LOT5250 C********************************************************************** LOT5260 C********************************************************************** LOT5270 C **** USED THRU ITP(9,4): AVAILABLE ITP(10,1) THRU ITP(10,4)******** LOT5280 C********************************************************************** LOT5290 C********************************************************************** LOT5300 END LOT5310 SUBROUTINE MATRIX MAT 10 C VERSION 5.00 MATRIX 5/15/70 MAT 20 C MAT 30 C L2=1 ADD MATRICES A+B MADD A(,) N,M, TO B(,) N,M AND S ORE IN C(MAT 40 C L2=2 SUB MATRICES A-B MSUB A(,) N,M FROM B(,)N,M AND STORE IN C(MAT 60 C L2=3 TRANSPOSE MATRIX MTRANS A(,) N,M AND STORE IN C(,) MAT 80 C TRANSPOSE ARRAY ATRANS A(,) N,M AND STORE IN C(,) MAT 90 C L2=4 ARRAY ADD AADD MAT 100 C L2=5 ARRAY SUBTRACT ASUB MAT 110 C L2=6 ARRAY MULTIPLY AMULT MAT 120 C L2=7 ARRAY DIVIDE ADIV MAT 130 C L2=8 ARRAY RAISE ARAISE MAT 140 C GENERAL FORMS FOR ARRAY OPERATIONS MAT 150 C A(,) N,M B(,) N,K STORE IN C(,) ARRAY BY ARRAY MAT 160 C A(,) N,M B(,) STORE IN C(,) ARRAY BY ARRAY MAT 170 C A(,) N,M K STORE IN C(,) ARRAY BY COLUMN MAT 180 C A(,) N,M X STORE IN C(,) ARRAY BY CONSTANT MAT 200 C MAT 220 COMMON /BLOCRC/ NRC,RC(12600) MAT 230 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMAT 240 1ARGS,VWXYZ(8),NERROR MAT 250 DIMENSION ARGS(100) MAT 260 EQUIVALENCE (ARGS(1),RC(12501)) MAT 270 COMMON /SCRAT/ NS,NS2,A(13500) MAT 280 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MAT 290 C MAT 300 C CHECK TO SEE IF WE HAVE CORRECT NUMBER OF ARGUMENTS MAT 310 C MAT 320 NP=NARGS MAT 330 IF (L2-3) 10,20,30 MAT 340 10 IF (NARGS.NE.8.AND.NARGS.NE.10) GO TO 40 MAT 350 GO TO 50 MAT 360 20 IF (NARGS.NE.6) GO TO 40 MAT 370 GO TO 50 MAT 380 30 IF(NARGS.LT.7.OR.NARGS.GT.10.OR.NARGS.EQ.9) GO TO 40 MAT 390 GO TO 50 MAT 400 40 CALL ERROR (10) MAT 410 RETURN MAT 415 C MAT 420 C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS MAT 430 C MAT 440 50 IF(L2.GT.3.AND.NARGS.EQ.7) GO TO 70 MAT 450 60 J=NARGS MAT 460 CALL CKIND (J) MAT 470 IF (J.EQ.0) GO TO 80 MAT 480 CALL ERROR (3) MAT 490 GO TO 80 MAT 500 70 ISAVE=KIND(NARGS) MAT 510 KIND(NARGS)=KIND(NARGS-2) MAT 520 KIND(NARGS-2)=KIND(NARGS-1) MAT 530 KIND(NARGS-1)=ISAVE MAT 540 NARGS=NARGS-1 MAT 550 GO TO 60 MAT 560 C MAT 570 C CHECK TO SEE IF DIMENSIONS ARE CORRECT IF THEY ARE GIVEN MAT 580 C MAT 590 80 IF (NP.NE.10) GO TO 90 MAT 600 IF (IARGS(3).EQ.IARGS(7).AND.IARGS(4).EQ.IARGS(8)) GO TO 90 MAT 610 CALL ERROR (3) MAT 620 RETURN MAT 625 C MAT 630 C CHECK TO SEE IF ARGUMENTS ARE OUT OF RANGE MAT 640 C MAT 660 90 IF((L2.LT.3.OR.L2.GT.3).AND.KIND(NP).EQ.0) GO TO 100 MAT 670 J=2 MAT 680 GO TO 130 MAT 690 100 J=3 MAT 700 IARGS(12)=IARGS(4) MAT 720 120 IARGS(11)=IARGS(3) MAT 750 IF (NP.EQ.10) GO TO 210 MAT 760 IARGS(10)=IARGS(NP) MAT 770 IARGS(9)=IARGS(NP-1) MAT 780 130 IF (NP.EQ.8.OR.(NP.EQ.7.AND.KIND(NP).NE.0)) GO TO 190 MAT 790 IF(NP.EQ.6) GO TO 160 MAT 810 IARGS(6)=IARGS(5) MAT 860 IARGS(8)=1 MAT 870 IARGS(7)=IARGS(3) MAT 880 IARGS(5)=1 MAT 890 GO TO 210 MAT 900 160 IARGS(8)=IARGS(3) MAT 910 IARGS(7)=IARGS(4) MAT 920 GO TO 210 MAT 930 190 IF (NP.EQ.8) GO TO 200 MAT1010 IARGS(5)=IARGS(6) MAT1020 IARGS(6)=IARGS(7) MAT1030 200 IARGS(8)=IARGS(4) MAT1040 IARGS(7)=IARGS(3) MAT1050 210 CALL MTXCHK (J) MAT1060 IF (J-1) 240,220,230 MAT1070 220 CALL ERROR (3) MAT1080 RETURN MAT1090 230 CALL ERROR (17) MAT1100 RETURN MAT1110 C * MAT1120 C CHECK TO SEE IF THERE WERE PREVIOUS ERRORS MAT1130 C * MAT1140 240 IF (NERROR.NE.0) RETURN MAT1150 C * MAT1160 C SUM ELEMENTS IN SCRATCH AREA MAT1170 C SUBTRACT ELEMENTS IN SCRATCH AREA MAT1180 C PRODUCTS AND QUOTIENTS FORMED USING DOUBLE PRECISION IN SCRATCH ARMAT1190 C TRANSPOSE IN SCRATCH AREA MAT1200 C * MAT1210 IROW=IARGS(3) MAT1220 ICOL=IARGS(4) MAT1230 NROWPP=NROW MAT1240 IF (L2-3) 260,250,290 MAT1250 250 IIB=ICOL MAT1260 JJB=IROW MAT1270 NROWPP=0 MAT1280 K=1 MAT1290 GO TO 280 MAT1300 260 NROWP=NROW MAT1310 IBP=IARGS(5) MAT1320 270 IIB=IROW MAT1330 JJB=ICOL MAT1340 K=0 MAT1350 280 IS=1 MAT1360 IAP=IARGS(1) MAT1370 GO TO 320 MAT1380 290 IF (NP.GE.8) GO TO 260 MAT1390 IF (KIND(NP).EQ.1) GO TO 300 MAT1400 IBP=IARGS(5) MAT1410 GO TO 310 MAT1420 300 IARGS(9)=IARGS(5) MAT1430 310 NROWP=0 MAT1440 GO TO 270 MAT1450 320 DO 510 J=1,JJB MAT1460 C COMPUTE ADDRESSES MAT1465 IA=IAP+(J-1)*K MAT1470 IB=IBP MAT1480 DO 500 I=1,IIB MAT1490 GO TO (330,340,370,380,390,400,410,420), L2 MAT1500 330 A(IS)=RC(IA)+RC(IB) MAT1510 GO TO 470 MAT1520 340 A(IS)=RC(IA)-RC(IB) MAT1530 GO TO 470 MAT1540 350 A(IS)=RC(IA)*RC(IB) MAT1550 GO TO 470 MAT1560 360 IF(RC(IB).EQ.0.0) GO TO 365 MAT1562 A(IS)=RC(IA)/RC(IB) MAT1564 GO TO 470 MAT1566 365 A(IS)=0.0 MAT1570 GO TO 470 MAT1580 370 A(IS)=RC(IA) MAT1590 IA=IA+NROW MAT1600 GO TO 490 MAT1610 380 IF (NP.GE.8.OR.(KIND(NP).EQ.0.AND.NP.LT.8)) GO TO 330 MAT1620 A(IS)=RC(IA)+ARGS(NP-2) MAT1630 GO TO 480 MAT1640 390 IF (NP.GE.8.OR.(KIND(NP).EQ.0.AND.NP.LT.8)) GO TO 340 MAT1650 A(IS)=RC(IA)-ARGS(NP-2) MAT1660 GO TO 480 MAT1670 400 IF (NP.GE.8.OR.(KIND(NP).EQ.0.AND.NP.LT.8)) GO TO 350 MAT1680 A(IS)=RC(IA)*ARGS(NP-2) MAT1690 GO TO 470 MAT1700 410 IF (NP.GE.8.OR.(NP.LT.8.AND.KIND(NP).EQ.0)) GO TO 360 MAT1710 IF(ARGS(NP-2).EQ.0.0) GO TO 415 MAT1712 A(IS)=RC(IA)/ARGS(NP-2) MAT1714 GO TO 470 MAT1716 415 A(IS)=0.0 MAT1720 GO TO 470 MAT1730 420 IF (NP.GE.8.OR.(NP.LT.8.AND.KIND(NP).EQ.0)) GO TO 440 MAT1740 IF (RC(IA)) 430,460,430 MAT1750 430 A(IS)=FEXP2(RC(IA),ARGS(NP-2)) MAT1760 GO TO 470 MAT1770 440 IF (RC(IA)) 450,460,450 MAT1780 450 A(IS)=FEXP2(RC(IA),RC(IB)) MAT1790 GO TO 470 MAT1800 460 A(IS)=0.0 MAT1810 470 IB=IB+1 MAT1820 480 IA=IA+1 MAT1830 490 IS=IS+1 MAT1840 500 CONTINUE MAT1850 IAP=IAP+NROWPP MAT1860 IBP=IBP+NROWP MAT1870 510 CONTINUE MAT1880 C * MAT1890 C MOVE SUMS TO WORKSHEET MAT1900 C MOVE DIFFERENCES TO WORKSHEET MAT1910 C MOVE ARRAY PRODUCT TO WORKSHEET MAT1920 C MOVE ARRAY QUOTIENT TO WORKSHEET MAT1930 C MOVE TRANSPOSE TO WORKSHEET MAT1940 C MOVE RAISED MATRIX TO WORKSHEET MAT1950 C * MAT1960 IF (L2.NE.3) GO TO 520 MAT1970 ICP=IARGS(5) MAT1980 GO TO 530 MAT1990 520 ICP=IARGS(9) MAT2000 530 IS=1 MAT2010 DO 550 J=1,JJB MAT2020 IC=ICP MAT2030 DO 540 I=1,IIB MAT2040 RC(IC)=A(IS) MAT2050 IC=IC+1 MAT2060 IS=IS+1 MAT2070 540 CONTINUE MAT2080 ICP=ICP+NROW MAT2090 550 CONTINUE MAT2100 RETURN MAT2110 END MAT2120 SUBROUTINE MDAMAD MDA 10 C VERSION 5.00 MDAMAD 5/15/70 MDA 20 C SUBROUTINE MDAMAD R VARNER 9/26/67 MDA 30 C * MDA 40 C SUBROUTINE TO PRE OR POST MULTIPLY A MATRIX BY A DIAGONAL STORED MDA 50 C AS A COLUMN MDA 60 C L2=1 M(AD) MDA 70 C MATRIX A IS POSTMULTIPLIED BY THE DIAGONAL D STORED IN COL I MDA 80 C GENERAL FORM OF COMMAND MDA 90 C M(AD) A(,) N,K, D IN COL I STORE IN C(,) MDA 100 C L2=2 M(AD) MDA 110 C MATRIX A IS PREMULTIPLIED BY THE DIAGONAL D STORED IN COL I MDA 120 C GENERAL FORM OF COMMAND MDA 130 C M(DA), A(,) N,K K IN COL I STORE IN C(,) MDA 140 C * MDA 150 COMMON /SCRAT/ NS,NS2,A(13500) MDA 160 COMMON /BLOCRC/ NRC,RC(12600) MDA 170 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMDA 180 1ARGS,VWXYZ(8),NERROR MDA 190 DIMENSION ARGS(100) MDA 200 EQUIVALENCE (ARGS(1),RC(12501)) MDA 210 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MDA 220 C MDA 230 C CHECK FOR CORRECT NUMBER OF ARGUMENTS MDA 240 C * MDA 250 IF (NARGS.NE.7) CALL ERROR (10) MDA 260 C * MDA 270 C CHECK TO SEE THAT ALL ARGUMENTS ARE INTEGERS MDA 280 C * MDA 290 J=NARGS MDA 300 CALL CKIND (J) MDA 310 IF (J.NE.0) CALL ERROR (3) MDA 320 C * MDA 330 C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE MDA 340 C COMPUTE ADDRESSES OF COLUMNS MDA 350 C * MDA 360 IARGS(12)=IARGS(4) MDA 370 IARGS(11)=IARGS(3) MDA 380 IARGS(10)=IARGS(7) MDA 390 IARGS(9)=IARGS(6) MDA 400 IARGS(8)=1 MDA 410 GO TO (10,20), L2 MDA 420 10 IARGS(7)=IARGS(4) MDA 430 GO TO 30 MDA 440 20 IARGS(7)=IARGS(3) MDA 450 30 IARGS(6)=IARGS(5) MDA 460 IARGS(5)=1 MDA 470 J=3 MDA 480 CALL MTXCHK (J) MDA 490 IF (J-1) 60,40,50 MDA 500 40 CALL ERROR (3) MDA 510 RETURN MDA 520 50 CALL ERROR (17) MDA 530 RETURN MDA 540 C * MDA 550 C CHECK FOR PREVIOUS ERRORS MDA 560 C * MDA 570 60 IF (NERROR.NE.0) RETURN MDA 580 IP=IARGS(4) MDA 590 JP=IARGS(3) MDA 600 GO TO (80,70), L2 MDA 610 70 I1=0 MDA 620 I2=1 MDA 630 GO TO 90 MDA 640 80 I1=1 MDA 650 I2=0 MDA 660 90 IA=IARGS(1) MDA 670 IDP=IARGS(5) MDA 680 IB=IARGS(9) MDA 690 DO 110 I=1,IP MDA 700 ID=IDP MDA 710 DO 100 J=1,JP MDA 720 RC(IB)=RC(ID)*RC(IA) MDA 730 ID=ID+I2 MDA 740 IA=IA+1 MDA 750 IB=IB+1 MDA 760 100 CONTINUE MDA 770 IB=IB+NROW-JP MDA 780 IA=IA+NROW-JP MDA 790 IDP=IDP+I1 MDA 800 110 CONTINUE MDA 810 RETURN MDA 820 END MDA 830 SUBROUTINE MEIGEN MEI 10 C VERSION 5.00 MEIGEN 5/15/70 MEI 20 C SUBROUTINE MEIGEN WRITTEN BY R VARNER 4/4/68 MEI 30 C * MEI 40 C SUBROUTINE TO COMPUTE EIGNEVALUES AND EIGENVECTORS MEI 50 C GENERAL FORMS OF COMMANDS MEI 60 C MEIGEN A(,,++) R=,, C=,, STORE VALUES IN COL ++ MEI 70 C MEIGEN A(,,++) R=,, C=,, STORE VECTORS IN B(,,++) MEI 80 C MEIGEN A(,,++) R=,, C=,, STORE VALUES IN COL ++ MEI 90 C STORE VECTORS IN B(,,++) MEI 100 C BOTH R AND C MUST BE SPECIFIED MEI 110 C NARGS= 5 COMPUTE ONLY EIGENVALUES MEI 120 C NARGS= 6 COMPUTE ONLY EIGENVECTORS MEI 130 C NARGS= 7 COMPUTE EIGENVALUES AND VECTORS MEI 140 C * MEI 150 COMMON /BLOCRC/ NRC,RC(12600) MEI 160 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMEI 170 1ARGS,VWXYZ(8),NERROR MEI 180 DIMENSION ARGS(100) MEI 190 EQUIVALENCE (ARGS(1),RC(12501)) MEI 200 COMMON /SCRAT/ NS,NS2,A(13500) MEI 210 DIMENSION ISWCH(2) MEI 220 C * MEI 230 C CHECK TO BE SURE THAT MATRIX IS NO BIGGER THEN 54X54 MEI 240 C * MEI 250 IF (IARGS(3).NE.IARGS(4)) CALL ERROR (230) MEI 260 IF (IARGS(3)**2.GT.NS2) CALL ERROR (23) MEI 270 C * MEI 280 C CHECK FOR CORRECT NUMBER OF ARGUMENTS MEI 290 C * MEI 300 IF (NARGS.LT.5.OR.NARGS.GT.7) CALL ERROR (10) MEI 310 C * MEI 320 C CHECK TO SEE IF ARGUMENTS ARE ALL INTEGERS MEI 330 C MEI 340 J=NARGS MEI 350 CALL CKIND (J) MEI 360 IF (J.NE.0) CALL ERROR (3) MEI 370 C * MEI 380 C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE MEI 390 C COMPUTE ADDRESSES MEI 400 C * MEI 410 ISWCH(2)=NARGS-4 MEI 420 ISWCH(1)=0 MEI 430 IF (NARGS.EQ.6) GO TO 10 MEI 440 IADD=1 MEI 450 CALL ADRESS (5,J) MEI 460 IF (J.LE.0) CALL ERROR (11) MEI 470 C * MEI 480 C J CONTAINS ADDRESS OF COLUMN MEI 490 C * MEI 500 IF (NARGS.EQ.5) GO TO 20 MEI 510 IARGS(5)=IARGS(6) MEI 520 IARGS(6)=IARGS(7) MEI 530 10 IADD=2 MEI 540 IARGS(7)=IARGS(3) MEI 550 IARGS(8)=IARGS(4) MEI 560 GO TO 30 MEI 570 20 ISWCH(1)=1 MEI 580 30 CALL MTXCHK (IADD) MEI 590 IF (IADD-1) 60,40,50 MEI 600 40 CALL ERROR (3) MEI 610 RETURN MEI 620 50 CALL ERROR (17) MEI 630 RETURN MEI 640 C * MEI 650 C CHECK FOR PREVIOUS ERRORS MEI 660 C * MEI 670 60 IF (NERROR.NE.0) RETURN MEI 680 IGP=IARGS(5) MEI 690 IG=IARGS(1) MEI 700 CALL HDIAG (RC(IG),IARGS(3),ISWCH,A,RC(J),RC(IGP),NROW,A(3000)) MEI 710 C * MEI 720 C RC(IG) IS LOCATION OF MATRIX TO BE DIAGNOALIZED MEI 730 C IARG(3) GIVES SIZE OF MATRIX MEI 740 C ISWCH (1)=1 IF ONLY EIGENVALUES ARE TO BE COMPUTED MEI 750 C ISWCH (1)=0 COMPUTE EIGENVALUES AND EIGENVECTORS MEI 760 C ISWCH (2) = NARGS-4 AND IS USED FOR STORING RESULTS MEI 770 C A IS LOCATION OF SCRATCH AREA MEI 780 C RC(J) TELLS WHERE TO STORE EIGENVALUES MEI 790 C RC(IGP) IS WHERE EIGENVECTORS ARE STORED MEI 800 C * MEI 810 RETURN MEI 820 END MEI 830 SUBROUTINE MISC2 MIS 10 C VERSION 5.00 MISC2 5/15/70 MIS 20 COMMON /BLOCRC/ NRC,RC(12600) MIS 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMIS 40 1ARGS,VWXYZ(8),NERROR MIS 50 DIMENSION ARGS(100) MIS 60 EQUIVALENCE (ARGS(1),RC(12501)) MIS 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MIS 80 COMMON /SCRAT/ NS,NS2,A(13500) MIS 90 C SUBROUTINE BY CARLA MESSINA NSRDS - NBS JULY 1967 MIS 100 C MIS 110 C L2=4 IS EXPAND $$ TO ,, POWER IN INTERVALS OF ,, START STORE +MIS 120 C THE POWERS MAY BE INTEGER OR NOT MIS 130 C L2=1 IS CLOSE UP ROWS HAVING ** IN ++,++, ETC MIS 140 C L2=2 IS COUNT LENGTH OF COLUMN ++, STORE IN COLUMN ++ MIS 150 C L2=3 IS SHORTEN COL ++ FOR COL ++ = ** STORE IN COL ++ AND COLMIS 160 C L2=5 IS DUPLICATE ,, TIMES THE ARRAY IN ,, ++ R=,, C=,, START MIS 170 C STORING IN ,, ++ MIS 180 C MIS 190 IF (NARGS-2) 10,40,40 MIS 200 10 K=10 MIS 210 20 CALL ERROR (K) MIS 220 30 RETURN MIS 230 40 GO TO (50,80,50,340,540), L2 MIS 240 50 IF (KIND(L2)) 60,60,70 MIS 250 60 K=3 MIS 260 GO TO 20 MIS 270 70 KIND(L2)=0 MIS 280 ARG1=ARGS(L2) MIS 290 IARGS(L2)=IARGS(L2+1) MIS 300 80 CALL CHKCOL (J) MIS 310 IF (J) 60,90,60 MIS 320 90 DO 100 I=1,NARGS MIS 330 100 IARGS(I)=IARGS(I)-1 MIS 340 IF (L2-2) 120,120,110 MIS 350 110 IF (NARGS-5) 10,120,10 MIS 360 120 IF (NERROR.NE.0) GO TO 30 MIS 370 IF (NRMAX) 130,130,140 MIS 380 130 K=9 MIS 390 GO TO 20 MIS 400 140 IF (L2-2) 150,210,250 MIS 410 C CLOSE UP MIS 420 150 DO 200 J=2,NARGS MIS 430 K=IARGS(J) MIS 440 M=1 MIS 450 DO 170 I=1,NRMAX MIS 460 J1=K+I MIS 470 IF (RC(J1)-ARGS1) 160,170,160 MIS 480 160 K1=K+M MIS 490 RC(K1)=RC(J1) MIS 500 M=M+1 MIS 510 170 CONTINUE MIS 520 IF (M-NRMAX) 180,180,200 MIS 530 180 DO 190 I=M,NRMAX MIS 540 J1=K+I MIS 550 190 RC(J1)=0.0 MIS 560 200 CONTINUE MIS 570 GO TO 30 MIS 580 C COUNT MIS 590 210 J1=NRMAX MIS 600 J=IARGS(1)+NRMAX MIS 610 DO 230 I=1,NRMAX MIS 620 IF (RC(J)) 240,220,240 MIS 630 220 J1=J1-1 MIS 640 230 J=J-1 MIS 650 240 ARG1=J1 MIS 660 IARGS(2)=IARGS(2)+1 MIS 670 CALL VECTOR (ARG1,IARGS(2)) MIS 680 GO TO 30 MIS 690 C SHORTEN MIS 700 250 IF (NRMAX-2) 30,260,260 MIS 710 260 DO 290 K=2,NRMAX MIS 720 J1=IARGS(2)+K MIS 730 IF(ARG1-RC(J1-1)) 270,300,280 MIS 740 270 IF(ARG1-RC(J1)) 290,310,310 MIS 750 280 IF(ARG1-RC(J1)) 310,310,290 MIS 760 290 CONTINUE MIS 770 K=203 MIS 780 CALL ERROR (K) MIS 790 GO TO 320 MIS 800 300 NRMAX=K-1 MIS 810 GO TO 320 MIS 820 310 NRMAX=K MIS 830 320 DO 330 I=1,NRMAX MIS 840 K=IARGS(1)+I MIS 850 J=IARGS(4)+I MIS 860 M=IARGS(5)+I MIS 870 K1=IARGS(2)+I MIS 880 RC(M)=RC(K1) MIS 890 330 RC(J)=RC(K) MIS 900 GO TO 30 MIS 910 C EXPAND MIS 920 340 IF (NARGS-4) 10,350,10 MIS 930 350 CALL ADRESS (4,K1) MIS 940 IF (K1) 60,60,360 MIS 950 360 IF (KIND(1)) 400,370,400 MIS 960 370 CALL ADRESS (1,IARGS(1)) MIS 970 IF (IARGS(1)) 60,60,380 MIS 980 380 K=IARGS(1)-1 MIS 990 DO 390 I=1,NRMAX MIS1000 J=K+I MIS1010 390 A(I)=RC(J) MIS1020 GO TO 420 MIS1030 400 DO 410 I=1,NRMAX MIS1040 410 A(I)=ARGS(1) MIS1050 420 IF (KIND(2)) 440,430,440 MIS1060 430 ARGS(2)=IARGS(2) MIS1070 440 IF (KIND(3)) 460,450,460 MIS1080 450 ARGS(3)=IARGS(3) MIS1090 460 IF (ARGS(2)*ARGS(3)) 470,470,480 MIS1100 470 K=20 MIS1110 GO TO 20 MIS1120 480 IF (ABS(ARGS(3))-ABS(ARGS(2))) 490,490,470 MIS1130 490 IF (NERROR.NE.0) GO TO 30 MIS1140 IF (NRMAX) 130,130,500 MIS1150 500 CC=ARGS(3) MIS1160 510 DO 520 I=1,NRMAX MIS1170 K=K1-1+I MIS1180 520 RC(K)=FEXP2(A(I),CC) MIS1190 IF (ABS(CC)+.5E-6-ABS(ARGS(2))) 530,30,30 MIS1200 530 CC=CC+ARGS(3) MIS1210 IARGS(4)=IARGS(4)+1 MIS1220 CALL ADRESS (4,K1) MIS1230 IF (K1) 60,60,510 MIS1240 C DUPLICATE MIS1250 540 IF (NARGS.NE.7) GO TO 10 MIS1260 IF (IARGS(1).LE.0) GO TO 60 MIS1270 K1=MAX0(IARGS(1)*IARGS(4)+IARGS(6)-1,NRMAX) MIS1280 IF (K1.GT.NROW) GO TO 590 MIS1290 J=7 MIS1300 CALL CKIND (J) MIS1310 IF (J.NE.0) GO TO 60 MIS1320 NARGS=6 MIS1330 NDUP=IARGS(1) MIS1340 IARGS(61)=IARGS(6) MIS1350 IARGS(62)=IARGS(7) MIS1360 IARGS(63)=IARGS(4) MIS1370 IARGS(64)=IARGS(5) MIS1380 IARGS(65)=IARGS(6) MIS1390 IARGS(66)=IARGS(7) MIS1400 DO 550 I=1,6 MIS1410 550 IARGS(I)=IARGS(I+1) MIS1420 CALL MOVE MIS1430 IF (NDUP.EQ.1) GO TO 580 MIS1440 DO 570 I=2,NDUP MIS1450 DO 560 J=1,6 MIS1460 560 IARGS(J)=IARGS(J+60) MIS1470 IARGS(5)=IARGS(65)+(I-1)*IARGS(63) MIS1480 570 CALL MOVE MIS1490 580 NRMAX=K1 MIS1500 GO TO 30 MIS1510 590 K=16 MIS1520 GO TO 20 MIS1530 END MIS1540 SUBROUTINE MIST (M,B,LCHK,NLA,IND) MST 10 C VERSION 5.00 MIST 5/15/70 MST 20 DIMENSION B(1), NBC(12) MST 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMST 40 1ARGS,VWXYZ(8),NERROR MST 50 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPRINT,IPUNCH MST 60 MM=M-2 MST 70 NN=NRMAX-3 MST 80 NC=10 MST 90 M1=(M-1)/NC+1 MST 100 NLU=56 MST 110 NCA=0 MST 120 NRA=0 MST 130 DO 120 KEN=1,M1 MST 140 NCP=MIN0(NC,M-NCA) MST 150 NRP=M-LCHK*NCA MST 160 NLP=(1+IND/7)*NRP+5 MST 170 IF (NLP.LT.NLU-NLA) GO TO 10 MST 180 CALL PAGE (4) MST 190 NLA=0 MST 200 10 DO 20 IYA=1,NCP MST 210 I1=NCA+IYA MST 220 20 NBC(IYA)=(IARGS(I1+1)-1)/NROW+1 MST 230 GO TO (30,40,50,60,70,80,90), IND MST 240 30 WRITE (IPRINT,130) MST 250 GO TO 100 MST 260 40 WRITE (IPRINT,140) MST 270 GO TO 100 MST 280 50 WRITE (IPRINT,150) MM MST 290 GO TO 100 MST 300 60 WRITE (IPRINT,160) MST 310 GO TO 100 MST 320 70 WRITE (IPRINT,170) MST 330 GO TO 100 MST 340 80 I1=(IARGS(NRA+3)-1)/NROW+1 MST 350 I2=NCA*M+2 MST 360 WRITE (IPRINT,180) NN,B(I2),I1,NBC(1) MST 370 GO TO 100 MST 380 90 WRITE (IPRINT,190) MST 390 100 WRITE (IPRINT,200) (NBC(I),I=1,NCP) MST 400 WRITE (IPRINT,210) MST 410 DO 110 NAGA=1,NRP MST 420 NBR=NRA+NAGA MST 430 I1=NCA*M+NBR MST 440 I2=I1+(NCP-MAX0(0,LCHK*(NCP-NAGA))-1)*M MST 450 NBR=(IARGS(NBR+1)-1)/NROW+1 MST 460 WRITE (IPRINT,220) NBR,(B(I),I=I1,I2,M) MST 470 IF (IND.NE.7) GO TO 110 MST 480 I1=I1+2*M*M MST 490 I2=I2+2*M*M MST 500 WRITE (IPRINT,230) (B(I),I=I1,I2,M) MST 510 WRITE (IPRINT,210) MST 520 110 CONTINUE MST 530 NLA=NLA+NLP MST 540 NRA=NRA+LCHK*NCP MST 550 120 NCA=NCA+NCP MST 560 RETURN MST 570 C MST 580 130 FORMAT (/1H ,44X,31HSIMPLE CORRELATION COEFFICIENTS) MST 590 140 FORMAT (/1H ,22X,75HSIGNIFICANCE LEVELS OF SIMPLE CORRELATION COEFMST 600 1FICIENTS (ASSUMING NORMALITY)) MST 610 150 FORMAT (/1H ,25X,37HPARTIAL CORRELATION COEFFICIENTS WITH,I3,26H RMST 620 1EMAINING VARIABLES FIXED) MST 630 160 FORMAT (/1H ,22X,76HSIGNIFICANCE LEVELS OF PARTIAL CORRELATION COEMST 640 1FFICIENTS (ASSUMING NORMALITY)) MST 650 170 FORMAT (/1H ,30X,58HSPEARMAN RANK CORRELATION COEFFICIENTS (ADJUSTMST 660 1ED FOR TIES)) MST 670 180 FORMAT (/1H ,8X,79HSIGNIFICANCE LEVEL OF QUADRATIC FIT OVER LINEARMST 680 1 FIT BASED ON F RATIO WITH 1 AND,I5,19H DEGREES OF FREEDOM/1H ,7X,MST 690 213H(FOR EXAMPLE,F7.4,60H IS THE SIGNIFICANCE LEVEL OF THE QUADRATIMST 700 3C TERM WHEN COLUMN,I3,20H IS FITTED TO COLUMN,I3,1H)) MST 710 190 FORMAT (/1H ,17X,86HCONFIDENCE INTERVALS FOR SIMPLE CORRELATION COMST 720 1EFFICIENTS (USING FISHER TRANSFORMATION)/30X,68H95 PER CENT LIMITSMST 730 2 BELOW DIAGONAL, 99 PER CENT LIMITS ABOVE DIAGONAL) MST 740 200 FORMAT (/1H ,6HCOLUMN,10I11) MST 750 210 FORMAT (1H ) MST 760 220 FORMAT (1H ,I4,4X,10F11.4) MST 770 230 FORMAT (1H ,6X,10F11.4) MST 780 END MST 790 SUBROUTINE MKRON MKR 10 C VERSION 5.00 MKRON 5/15/70 MKR 20 C ROUTINE WRITTEN FOR OMNITAB 11/ 3/67 BY S PEAVY MKR 30 C MKR 40 C KRONECKER PRODUCT OF TWO MATRICES A(N,C)*B(M,K)=D MKR 50 C MKR 60 C FIRST FOUR ARGUMENTS DEFINE MATRIX A STARTING POS AND SIZE MKR 70 C NEXT FOUR ARGUMENTS DEFINE MATRIX B STARTING POS AND SIZE MKR 80 C LAST TWO ARGUMENTS INDICATE WHERE RESULT IS TO BE STORED D MKR 90 C COMMAND IS: MKR 100 C MKRON A(,, ++),R=,, C=,,*B(,, ++),R=,, C=,, STORE D(,, ++) MKR 110 C MKR 120 C MKR 130 COMMON /BLOCRC/ NRC,RC(12600) MKR 140 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMKR 150 1ARGS,VWXYZ(8),NERROR MKR 160 DIMENSION ARGS(100) MKR 170 EQUIVALENCE (ARGS(1),RC(12501)) MKR 180 COMMON /SCRAT/ NS,NS2,A(13500) MKR 190 IF (NARGS.NE.10) CALL ERROR (10) MKR 200 J=NARGS MKR 210 CALL CKIND (J) MKR 220 IF (J.NE.0) CALL ERROR (3) MKR 230 IF (NERROR.NE.0) RETURN MKR 240 IARGS(11)=IARGS(3)*IARGS(7) MKR 250 IARGS(12)=IARGS(4)*IARGS(8) MKR 260 J=3 MKR 270 CALL MTXCHK (J) MKR 280 IF (J.EQ.0) GO TO 10 MKR 290 CALL ERROR (17) MKR 300 RETURN MKR 310 10 NRA=IARGS(3) MKR 320 NCA=IARGS(4) MKR 330 NRB=IARGS(7) MKR 340 NCB=IARGS(8) MKR 350 NDS=1 MKR 360 KA=IARGS(1) MKR 370 DO 40 ICA=1,NCA MKR 380 LA=IARGS(5) MKR 390 DO 30 ICB=1,NCB MKR 400 K=KA MKR 410 DO 20 IRA=1,NRA MKR 420 T=RC(K) MKR 430 K=K+1 MKR 440 L=LA MKR 450 DO 20 IRB=1,NRB MKR 460 A(NDS)=T*RC(L) MKR 470 L=L+1 MKR 480 20 NDS=NDS+1 MKR 490 30 LA=LA+NROW MKR 500 40 KA=KA+NROW MKR 510 NCR=IARGS(11) MKR 520 NCC=IARGS(12) MKR 530 NDS=1 MKR 540 KA=IARGS(9) MKR 550 DO 60 I=1,NCC MKR 560 K=KA MKR 570 DO 50 J=1,NCR MKR 580 RC(K)=A(NDS) MKR 590 NDS=NDS+1 MKR 600 50 K=K+1 MKR 610 60 KA=KA+NROW MKR 620 RETURN MKR 630 END MKR 640 SUBROUTINE MMULT MMU 10 C VERSION 5.00 MMULT 5/15/70 MMU 20 C SUBROUTINE MMULT 10/ 4/67 MMU 30 C * MMU 40 C SUBROUTINE TO MULTIPLY MATRICES MMU 50 C GENERAL FORMS OF MMULT MMU 60 C MMULT A(,) N,K, BY B(,) K,M AND STORE IN C(,) MMU 70 C * MMU 80 COMMON /SCRAT/ NS,NS2,A(13500) MMU 90 COMMON /BLOCRC/ NRC,RC(12600) MMU 100 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMMU 110 1ARGS,VWXYZ(8),NERROR MMU 120 DIMENSION ARGS(100) MMU 130 EQUIVALENCE (ARGS(1),RC(12501)) MMU 140 DOUBLE PRECISION X,SUM MMU 150 DIMENSION X(1) MMU 160 EQUIVALENCE (X,A) MMU 170 C * MMU 180 C CHECK TO SEE IF WE HAVE CORRECT NUMBER OF ARGUMENTS MMU 190 C * MMU 200 10 IF(NARGS.NE.10) CALL ERROR(10) MMU 210 C * MMU 220 C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS MMU 230 C * MMU 240 J=NARGS MMU 250 CALL CKIND (J) MMU 260 IF (J.EQ.0) GO TO 20 MMU 270 CALL ERROR (3) MMU 280 C * MMU 290 C CHECK TO SEE IF DIMENSIONS ARE CORRECT MMU 300 C * MMU 310 20 IF(IARGS(4).NE.IARGS(7)) CALL ERROR (26) MMU 380 C * MMU 420 C CHECK TO SEE IF ARGUMENTS ARE OUT OF RANGE MMU 430 C FIND COLUMN ADDRESSES MMU 440 C * MMU 450 70 IARGS(12)=IARGS(NARGS-2) MMU 490 80 IARGS(11)=IARGS(3) MMU 500 100 J=3 MMU 630 CALL MTXCHK (J) MMU 640 IF (J-1) 130,110,120 MMU 650 110 CALL ERROR (3) MMU 660 RETURN MMU 670 120 CALL ERROR (17) MMU 680 RETURN MMU 690 C * MMU 700 C CHECK FOR PREVIOUS ERRORS MMU 710 C * MMU 720 130 IF (NERROR.NE.0) RETURN MMU 730 IROWA=IARGS(3) MMU 740 ICOLA=IARGS(4) MMU 750 ICOLB=IARGS(8) MMU 760 C BEGIN MULTIPLICATION MMU 770 C * MMU 780 ISP=1 MMU 790 IBP=IARGS(5) MMU 800 DO 160 ICB=1,ICOLB MMU 810 IAP=IARGS(1) MMU 820 DO 150 IRA=1,IROWA MMU 830 IS=NS2 MMU 840 IA=IAP MMU 850 IB=IBP MMU 860 DO 140 J=1,ICOLA MMU 870 X(IS)=RC(IA)*RC(IB) MMU 880 IS=IS-1 MMU 890 IA=IA+NROW MMU 900 IB=IB+1 MMU 910 140 CONTINUE MMU 920 C * MMU 930 C CALL ROUTINE TO SORT PRODUCTS AND SUM MMU 940 C * MMU 950 CALL SORTSM (ICOLA,SUM) MMU 960 A(ISP)=SUM MMU 970 ISP=ISP+1 MMU 980 150 IAP=IAP+1 MMU 990 160 IBP=IBP+NROW MMU1000 C * MMU1010 C STORE MATRIX PRODCUT MMU1020 C * MMU1030 IS=1 MMU1040 IC=IARGS(9) MMU1050 DO 180 J=1,ICOLB MMU1060 DO 170 I=1,IROWA MMU1070 RC(IC)=A(IS) MMU1080 IS=IS+1 MMU1090 IC=IC+1 MMU1100 170 CONTINUE MMU1110 180 IC=IC+NROW-IROWA MMU1120 RETURN MMU1130 END MMU1140 SUBROUTINE MOP MOP 10 C VERSION 5.00 MOP 5/15/70 MOP 20 C SUBROUTINE TO DO MDEFINE,ADEFINE,MZERO,AZERO,MERASE,AERASE,MIDENT MOP 30 C S. PEAVY FOR OMNITAB 1108 4/2/68 MOP 40 C COMMANDS ARE AS FOLLOWS MOP 50 C MOP 60 C MDEFINE MATRIX IN R , C SIZE N X M TO EQUAL K MOP 70 C ADEFINE ARRAY IN R , C SIZE N X M TO EQUAL K MOP 80 C MZERO MATRIX IN R , C SIZE N X M MOP 90 C AZERO ARRAY IN R , C SIZE N X M MOP 100 C MERASE MATRIX IN R , C SIZE N X M MOP 110 C AERASE ARRAY IN R , C SIZE N X M MOP 120 C MIDENT MATRIX IN R , C SIZE N X M MOP 130 C MDIAGO MATRIX IN R , C SIZE N X M EQUAL TO E ON DIAGONAL MOP 140 C MOP 280 C L2=1 MDEFINE,ADEFINE MOP 290 C L2=2 MZERO,AZERO,MERASE,AERASE MOP 300 C L2=3 MIDENT MOP 310 C L2=4 MDIAGONAL MOP 320 C MOP 330 COMMON /BLOCRC/ NRC,RC(12600) MOP 340 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMOP 350 1ARGS,VWXYZ(8),NERROR MOP 360 DIMENSION ARGS(100) MOP 370 EQUIVALENCE (ARGS(1),RC(12501)) MOP 380 COMMON /SCRAT/ NS,NS2,A(13500) MOP 390 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MOP 400 DATA ONE/1.0/,ZERO/0.0/ MOP 410 GO TO (10,50,60,80), L2 MOP 420 10 IF(NARGS.NE.5) CALL ERROR (10) MOP 430 IF (KIND(NARGS).NE.1) CALL ERROR (3) MOP 440 IF (NARGS.EQ.4) IARGS(4)=IARGS(3) MOP 450 CONST=ARGS(NARGS) MOP 460 CONSTA=ARGS(NARGS) MOP 470 J=NARGS-1 MOP 480 20 CALL CKIND (J) MOP 490 IF (J.NE.0) CALL ERROR (3) MOP 500 J=1 MOP 510 CALL MTXCHK (J) MOP 520 IF (J.NE.0) CALL ERROR (17) MOP 530 IF (NERROR.NE.0) RETURN MOP 540 JB=IARGS(1) MOP 550 N=IARGS(3) MOP 560 K=IARGS(4) MOP 570 JA=JB MOP 580 IF (L2.EQ.4) GO TO 90 MOP 590 DO 40 KA=1,K MOP 600 JC=JB MOP 610 DO 30 NA=1,N MOP 620 RC(JC)=CONST MOP 630 30 JC=JC+1 MOP 640 IF (KA.GT.N) GO TO 40 MOP 650 RC(JA)=CONSTA MOP 660 JA=JA+NROW+1 MOP 670 40 JB=JB+NROW MOP 680 RETURN MOP 690 50 IF(NARGS.NE.4) CALL ERROR (10) MOP 700 CONST=ZERO MOP 710 CONSTA=ZERO MOP 720 J=NARGS MOP 730 IF (NARGS.EQ.4) GO TO 20 MOP 740 IARGS(4)=IARGS(3) MOP 750 J=NARGS-1 MOP 760 GO TO 20 MOP 770 60 IF(NARGS.NE.4) CALL ERROR (10) MOP 780 CONST=ZERO MOP 790 CONSTA=ONE MOP 800 J=NARGS MOP 810 GO TO 20 MOP 820 80 J=NARGS-1 MOP 910 IF (NARGS.NE.5) CALL ERROR(10) MOP 920 GO TO 20 MOP 930 90 IF (KIND(NARGS).EQ.0) GO TO 110 MOP 970 DO 100 NA=1,N MOP 980 RC(JB)=ARGS(NARGS) MOP 990 100 JB=JB+1+NROW MOP1000 RETURN MOP1010 110 KIND(5)=0 MOP1020 CALL ADRESS (5,M) MOP1030 IF (M.GT.0) GO TO 120 MOP1040 CALL ERROR (11) MOP1050 RETURN MOP1060 120 DO 130 NA=1,NA MOP1070 A(NA)=RC(M) MOP1080 130 M=M+1 MOP1090 DO 140 NA=1,N MOP1100 RC(JB)=A(NA) MOP1110 140 JB=JB+1+NROW MOP1120 RETURN MOP1130 END MOP1140 SUBROUTINE MOVE MOV 10 C VERSION 5.00 MOVE 5/15/70 MOV 20 COMMON /BLOCRC/ NRC,RC(12600) MOV 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMOV 40 1ARGS,VWXYZ(8),NERROR MOV 50 DIMENSION ARGS(100) MOV 60 EQUIVALENCE (ARGS(1),RC(12501)) MOV 70 C THIS ROUTINE IS ALSO CALLED BLOCKTRANSFER MOV 80 IF (NARGS.EQ.6) GO TO 50 MOV 90 K=10 MOV 100 10 CALL ERROR (K) MOV 110 20 RETURN MOV 120 30 K=20 MOV 130 GO TO 10 MOV 140 40 K=11 MOV 150 GO TO 10 MOV 160 50 IARGS(9)=IARGS(1)+IARGS(3)-1 MOV 170 IARGS(13)=IARGS(5)+IARGS(3)-1 MOV 180 IF (KIND(1)+KIND(3)+KIND(4)+KIND(5).NE.0) GO TO 30 MOV 190 IF (IARGS(1).GT.0.AND.IARGS(3).GT.0.AND.IARGS(5).GT.0.AND.IARGS(9)MOV 200 1.LE.NROW.AND.IARGS(13).LE.NROW) GO TO 60 MOV 210 K=16 MOV 220 GO TO 10 MOV 230 60 IARGS(10)=IARGS(2)+IARGS(4)-1 MOV 240 KIND(10)=0 MOV 250 IARGS(14)=IARGS(6)+IARGS(4)-1 MOV 260 KIND(14)=0 MOV 270 DO 70 I=2,14,4 MOV 280 CALL ADRESS (I,IARGS(I)) MOV 290 IF (IARGS(I)) 30,40,70 MOV 300 70 IARGS(I)=IARGS(I)-1 MOV 310 C MOV 320 C IF MOVE IS UP, IR = -1, IF DOWN, IR = +1 MOV 330 C IF MOVE IS LEFT, IC = -1, IF RIGHT , IC = +1 MOV 340 C DIRECTION OF MOVE IS SUCH THAT THE TWO AREAS CAN BE OVERLAPPING MOV 350 C AND IT WILL BE DONE PROPERLY. MOV 360 C MOV 370 IR=ISIGN(1,IARGS(5)-IARGS(1)) MOV 380 IC=ISIGN(1,IARGS(6)-IARGS(2)) MOV 390 MM=IARGS(4*IR+5)+IARGS(4*IC+6) MOV 400 NN=IARGS(4*IR+9)+IARGS(4*IC+10) MOV 410 IC=IC*NROW MOV 420 MMM=IARGS(3) MOV 430 NNN=IARGS(4) MOV 440 DO 90 J=1,NNN MOV 450 M=MM MOV 460 N=NN MOV 470 DO 80 I=1,MMM MOV 480 RC(N)=RC(M) MOV 490 M=M-IR MOV 500 80 N=N-IR MOV 510 MM=MM-IC MOV 520 90 NN=NN-IC MOV 530 GO TO 20 MOV 540 END MOV 550 SUBROUTINE MPROP MPR 10 C VERSION 5.00 MPROP 5/15/70 MPR 20 C WRITTEN FOR OMNITAB BY S PEAVY 5/ 7/68 MPR 30 C COMMAND IS AS FOLLOWS, X=A OR M DEPENDING APROP OR MPROP IS REQUIRMPR 40 C I XPROP OF MATRIX (,, ++) NO OF ROWS ,, NO OF COL ++ MPR 50 C INFORMATION PRINTED AND NO STORAGE MPR 60 C MPR 70 C II XPROP MATRIX (,, ++) SIZE ,, BY ++ PROPERTIES STORED ++ MPR 80 C PROPERTIES PRINTED AND STORED MPR 90 C MPR 100 C 111 XPROP MATRIX (,, ++) R=,, C=,, PROP ++ COL NORMS (,, ++ ) MPR 110 C SAME AS II PLUS STORAGE OF COLUMN NORMS MPR 120 C MPR 130 C IV XPROP (,, ++) R=,, C=,, PROP ++ COL NORMS (,, ++) ROW NORMS(MPR 140 C SAME AS III PLUS STORAGE OF ROW NORMS, ALSO (R+1,++) OF NORM MPR 150 C AVERAGES WILL CONTAIN GRAND AVERAGE, IF X=A. MPR 160 C MPR 170 C V XPROP ( ,, ++) R=,, C=,, COL NORMS(,, ++) MPR 180 C SAME AS III EXCEPT PROPERTIES WILL NOT BE STORED MPR 190 C MPR 200 C VI XPROP (,, ++) R=,, C=,, COL NORMS(,, ++) ROW NORMS (,, ++) MPR 210 C SAME AS IV EXECPT PROPERTIES WILL NOT BE STORED MPR 220 C MPR 230 C VII SXPROP MPR 240 C IF COMMANDS I-VI ARE PREFACED WITH AN S PRINTOUT MPR 250 C OF PROPERTIES WILL BE SUPPRESSED MPR 260 C MPR 270 C L2 OPTIONS MPR 280 C L2= 1 MPROP: L2=3 SMPROP MPR 290 C L2= 2 APROP: L2=4 SAPROP MPR 300 C MPR 310 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH MPR 320 COMMON /SCRAT/ NS,NS2,A(13500) MPR 330 COMMON /BLOCRC/ NRC,RC(12600) MPR 340 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMPR 350 1ARGS,VWXYZ(8),NERROR MPR 360 DIMENSION ARGS(100) MPR 370 EQUIVALENCE (ARGS(1),RC(12501)) MPR 380 DOUBLE PRECISION AP MPR 390 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MPR 400 DIMENSION IRSLT(6), ERR(3), IPROP(5), IRSLTP(11), IRSLTA(2,5) MPR 410 DATA NO/3H NO/,IYES/3HYES/,IBLK/3H /,LOWRA/3H LO/,LOWRB/3HWER/,IMPR 420 1PPRA/3H UP/,IPPRB/3HPER/,IANDA/3H AN/,IANDB/3HD /,IRWA,IRWB/3H MPR 430 2,3HROW/,ICLMA,ICLMB/3HCOL,3HUNM/,IBTHH,IBTHHA/3H ,3H T/,IBTHA,IMPR 440 3BTHB/3HWO-,3HWAY/,NOA,NOAB/3H ,3H NO/ MPR 450 IF(L2.LE.2.OR.NARGS.NE.4) GO TO 5 MPR 455 CALL ERROR (233) MPR 460 RETURN MPR 465 5 IF (NARGS.LT.4.OR.NARGS.GT.9) CALL ERROR (10) MPR 467 LOC=IARGS(1) MPR 470 J=NARGS MPR 480 CALL CKIND (J) MPR 490 IF (J.NE.0) CALL ERROR (3) MPR 500 K=5 MPR 510 J=1 MPR 520 IF (NARGS-5) 60,30,10 MPR 530 10 IF (NARGS.EQ.6.OR.NARGS.EQ.8) GO TO 40 MPR 540 IS=IARGS(5) MPR 550 J=2 MPR 560 K=9 MPR 570 IF (NARGS.EQ.7) GO TO 20 MPR 580 IARGS(11)=IARGS(3) MPR 590 IARGS(12)=1 MPR 600 IARGS(10)=IARGS(9) MPR 610 IARGS(9)=IARGS(8) MPR 620 K=13 MPR 630 J=3 MPR 640 IF (L2.GT.2) IARGS(11)=IARGS(11)+1 MPR 650 20 IARGS(5)=IARGS(6) MPR 660 IARGS(6)=IARGS(7) MPR 670 IARGS(7)=1 MPR 680 IARGS(8)=IARGS(4) MPR 690 IARGS(K)=IS MPR 700 30 CALL ADRESS (K,KPROP) MPR 710 IF (KPROP.LE.0) CALL ERROR (11) MPR 720 GO TO 60 MPR 730 40 J=2 MPR 740 IF (NARGS.EQ.6) GO TO 50 MPR 750 IARGS(9)=IARGS(7) MPR 760 IARGS(10)=IARGS(8) MPR 770 IARGS(11)=IARGS(3) MPR 780 IARGS(12)=1 MPR 790 J=3 MPR 800 IF (L2.GT.2) IARGS(11)=IARGS(11)+1 MPR 810 50 IARGS(7)=1 MPR 820 IARGS(8)=IARGS(4) MPR 830 60 CALL MTXCHK (J) MPR 840 KARGS=K MPR 850 IF (J.NE.0) CALL ERROR (17) MPR 860 IF (NERROR.NE.0) RETURN MPR 870 K=IARGS(1) MPR 880 IF (L2.EQ.2.OR.L2.EQ.4) GO TO 110 MPR 890 C COMMAND IS MPROP MPR 900 C IS MATRIX A SQUARE ONE MPR 910 IF (IARGS(3).NE.IARGS(4)) GO TO 90 MPR 920 C YES MPR 930 CALL INVCHK (RC(K),NROW,IARGS(3),A(100),IARGS(3)+1,A,1,ERR,IND) MPR 940 KA=K MPR 950 M=100 MPR 960 L=IARGS(3) MPR 970 DO 80 I=1,L MPR 980 KB=KA MPR 990 DO 70 J=1,L MPR1000 A(M)=RC(KB) MPR1010 KB=KB+1 MPR1020 70 M=M+1 MPR1030 80 KA=KA+NROW MPR1040 CALL DETRNK (A(100),L,L,DET,RANK) MPR1050 CALL PVTRI (RC(K),NROW,IARGS(3),INDU,INDB) MPR1060 CALL PROCHK (RC(K),NROW,IARGS(3),IARGS(4),IPROP,A(1),NS2) MPR1070 A(30)=0. MPR1080 IF (INDU.EQ.0) A(30)=A(30)+1.0 MPR1090 IF (INDB.EQ.0) A(30)=A(30)+2.0 MPR1100 A(19)=DET MPR1110 A(20)=RANK MPR1120 A(21)=ERR(1) MPR1130 A(22)=ERR(2) MPR1140 A(23)=ERR(3) MPR1150 A(24)=0. MPR1160 IF (IPROP(3).EQ.0) A(24)=1.0 MPR1170 IF (IPROP(3).EQ.1) A(24)=2.0 MPR1180 A(25)=0. MPR1190 IF (IPROP(2).LT.2) A(25)=IPROP(2)+1 MPR1200 A(26)=0. MPR1210 IF (IPROP(2).GT.2) A(26)=IPROP(2)-2 MPR1220 A(27)=0. MPR1230 IF (IPROP(1).EQ.0) A(27)=1. MPR1240 A(28)=0.0 MPR1250 IF (IPROP(4).LT.2) A(28)=IPROP(4)+1 MPR1260 A(29)=0. MPR1270 IF (IPROP(5).LT.2) A(29)=IPROP(5)+1 MPR1280 GO TO 110 MPR1290 90 CALL ORTHRV (RC(K),NROW,IARGS(3),IARGS(4),IPROP(4),A(1),NS2,AP) MPR1300 A(1)=AP MPR1305 DO 100 I=19,31 MPR1310 100 A(I)=0.0 MPR1320 110 CALL RCSUM (RC(K),NROW,IARGS(3),IARGS(4),A(101)) MPR1330 L=IARGS(3) MPR1340 IF (L.GT.IARGS(4)) L=IARGS(4) MPR1350 ITRACE=L MPR1360 IPOS=0 MPR1370 IZERO=0 MPR1380 INEG=0 MPR1390 TRACE=0.0 MPR1400 AMX=RC(K) MPR1410 AMN=AMX MPR1420 LA=IARGS(3)+IARGS(4) MPR1430 AVG=A(LA+102)/FLOAT(IARGS(3)*IARGS(4)) MPR1440 ABSMX=ABS(AMX) MPR1450 ABSMN=ABS(AMN) MPR1460 ABSMNZ=ABSMN MPR1470 SSQ=0.0 MPR1480 SRSQ=0.0 MPR1490 SCSQ=0.0 MPR1500 IF (ABSMNZ.EQ.0.0) ABSMNZ=1.E35 MPR1510 KA=K MPR1520 DO 120 I=1,L MPR1530 TRACE=TRACE+RC(KA) MPR1540 120 KA=KA+NROW+1 MPR1550 IN=IARGS(3) MPR1560 JK=IARGS(4) MPR1570 KA=K MPR1580 FIN=IN MPR1590 FJK=JK MPR1600 DO 200 J=1,JK MPR1610 KB=KA MPR1620 DO 190 I=1,IN MPR1630 KC=IARGS(4)+I MPR1640 SSQ=SSQ+(RC(KB)-AVG)**2 MPR1650 SCSQ=SCSQ+(RC(KB)-A(J+100)/FIN)**2 MPR1660 SRSQ=SRSQ+(RC(KB)-A(KC+100)/FJK)**2 MPR1670 IF (RC(KB)) 130,140,150 MPR1680 130 INEG=INEG+1 MPR1690 GO TO 160 MPR1700 140 IZERO=IZERO+1 MPR1710 GO TO 160 MPR1720 150 IPOS=IPOS+1 MPR1730 160 IF (AMX.GT.RC(KB)) GO TO 170 MPR1740 AMX=RC(KB) MPR1750 GO TO 180 MPR1760 170 IF (AMN.GT.RC(KB)) AMN=RC(KB) MPR1770 180 RCAB=ABS(RC(KB)) MPR1780 IF (ABSMX.LT.RCAB) ABSMX=RCAB MPR1790 IF (ABSMN.GT.RCAB) ABSMN=RCAB MPR1800 IF (ABSMNZ.GT.RCAB) IF (RCAB) 190,190,185 MPR1805 GO TO 190 MPR1810 185 ABSMNZ=RCAB MPR1820 190 KB=KB+1 MPR1830 200 KA=KA+NROW MPR1840 IF (L2.EQ.2.OR.L2.EQ.4.OR.IARGS(3).NE.IARGS(4)) GO TO 250 MPR1850 ISTOCR=0 MPR1860 ISTCHC=0 MPR1870 IF (AMN.LT.0.0) GO TO 240 MPR1880 DO 210 J=1,JK MPR1890 IF (A(J+100).EQ.1.0) GO TO 210 MPR1900 GO TO 220 MPR1910 210 CONTINUE MPR1920 ISTCHC=2 MPR1930 220 DO 230 I=1,IN MPR1940 M=I+JK MPR1950 IF (A(M+100).EQ.1.0) GO TO 230 MPR1960 GO TO 240 MPR1970 230 CONTINUE MPR1980 ISTOCR=1 MPR1990 240 A(31)=ISTCHC+ISTOCR MPR2000 250 A(1)=TRACE MPR2010 TR2=0.0 MPR2020 KB=K MPR2030 JKK=JK MPR2040 IF (JK.GT.IN) JKK=IN MPR2050 DO 260 J=2,JKK MPR2060 KA=K MPR2070 KB=KB+NROW+1 MPR2080 KC=K+J-1 MPR2090 KD=K+(J-1)*NROW MPR2100 II=J-1 MPR2110 DO 260 I=1,II MPR2120 TR2=TR2+(RC(KA)*RC(KB)-RC(KC)*RC(KD)) MPR2130 KA=KA+NROW+1 MPR2140 KC=KC+NROW MPR2150 260 KD=KD+1 MPR2160 A(2)=TR2 MPR2170 A(3)=AMX MPR2180 A(4)=AMN MPR2190 A(5)=ABSMX MPR2200 A(6)=ABSMN MPR2210 A(7)=ABSMNZ MPR2220 A(8)=IPOS MPR2230 A(9)=IZERO MPR2240 A(10)=INEG MPR2250 A(11)=A(LA+101) MPR2260 A(12)=AVG MPR2270 A(13)=A(LA+103) MPR2280 A(14)=SSQ MPR2290 A(15)=SRSQ MPR2300 A(16)=SCSQ MPR2310 A(17)=A(LA+104) MPR2320 A(18)=A(17)/FLOAT(IARGS(3)*IARGS(4)) MPR2330 IF (L2.GE.3) GO TO 570 MPR2340 CALL PAGE (4) MPR2350 IF (L2.NE.1) GO TO 370 MPR2360 WRITE (IPRINT,640) IARGS(3),IARGS(4),LOC,IARGS(2) MPR2370 IF (MOD(NARGS,2).EQ.0) GO TO 270 MPR2380 WRITE (IPRINT,650) IARGS(KARGS) MPR2390 270 WRITE (IPRINT,660) ITRACE,(A(I),I=1,7),IPOS,IZERO,INEG,(A(I),I=11,MPR2400 116) MPR2410 WRITE (IPRINT,670) A(17),A(18) MPR2420 WRITE (IPRINT,680) MPR2430 IF (IARGS(3).NE.IARGS(4)) GO TO 390 MPR2440 IRANK=A(20)+.5E-5 MPR2450 WRITE (IPRINT,690) A(19),IRANK,(A(I),I=21,23) MPR2460 DO 280 I=1,6 MPR2470 IRSLT(I)=IYES MPR2480 IRSLTP(I)=A(I+23) MPR2490 IF (A(I+23).EQ.0.) IRSLT(I)=NO MPR2500 280 CONTINUE MPR2510 C SET IRSLT(I),I=1,6 FOR YES OR NO. ALSO A(I),I=24,29 MPR2520 DO 290 I=1,5 MPR2530 IRSLTA(1,I)=IBLK MPR2540 290 IRSLTA(2,I)=IBLK MPR2550 IRSLTA(1,3)=NOA MPR2560 IRSLTA(2,3)=NOAB MPR2570 IF (INDU.NE.0.AND.INDB.NE.0) GO TO 320 MPR2580 IF (INDU.NE.0) GO TO 310 MPR2590 IF (INDB.EQ.0) GO TO 300 MPR2600 IRSLTA(1,1)=IPPRA MPR2610 IRSLTA(2,1)=IPPRB MPR2620 GO TO 320 MPR2630 300 IRSLTA(1,1)=IPPRA MPR2640 IRSLTA(2,1)=IPPRB MPR2650 IRSLTA(1,2)=IANDA MPR2660 IRSLTA(2,2)=IANDB MPR2670 310 IRSLTA(1,3)=LOWRA MPR2680 IRSLTA(2,3)=LOWRB MPR2690 320 IRSLTA(1,5)=NOA MPR2700 IRSLTA(2,5)=NOAB MPR2710 IF (ISTOCR+ISTCHC.EQ.3) GO TO 340 MPR2720 IF (ISTOCR.EQ.0) GO TO 330 MPR2730 IRSLTA(1,5)=IRWA MPR2740 IRSLTA(2,5)=IRWB MPR2750 GO TO 350 MPR2760 330 IF (ISTCHC.EQ.0) GO TO 350 MPR2770 IRSLTA(1,5)=ICLMA MPR2780 IRSLTA(2,5)=ICLMB MPR2790 GO TO 350 MPR2800 340 IRSLTA(1,4)=IBTHH MPR2810 IRSLTA(2,4)=IBTHHA MPR2820 IRSLTA(1,5)=IBTHA MPR2830 IRSLTA(2,5)=IBTHB MPR2840 350 IRSLTP(7)=A(30) MPR2850 IRSLTP(8)=A(31) MPR2860 WRITE (IPRINT,700) (IRSLT(I),IRSLTP(I),I=1,6) MPR2870 WRITE (IPRINT,710) ((IRSLTA(I,J),I=1,2),J=1,3),IRSLTP(7),((IRSLTA(MPR2880 1I,J),I=1,2),J=4,5),IRSLTP(8) MPR2890 DO 360 I=1,2 MPR2900 360 WRITE (IPRINT,720) MPR2910 WRITE (IPRINT,730) MPR2920 GO TO 570 MPR2930 C APROP PRINT OUT MPR2940 370 WRITE (IPRINT,740) IARGS(3),IARGS(4),LOC,IARGS(2) MPR2950 IF (MOD(NARGS,2).EQ.0) GO TO 380 MPR2960 WRITE (IPRINT,650) IARGS(KARGS) MPR2970 380 WRITE (IPRINT,660) ITRACE,(A(I),I=1,7),IPOS,IZERO,INEG,(A(I),I=11,MPR2980 116) MPR2990 WRITE (IPRINT,670) A(17),A(18) MPR3000 GO TO 570 MPR3010 C MPROP PRINT OUT FOR A NON-SQUARE MATRIX MPR3020 390 DO 400 I=1,2 MPR3030 IRSLTA(1,I)=NOA MPR3040 400 IRSLTA(2,I)=NOAB MPR3050 IF (IPROP(4).EQ.2) GO TO 550 MPR3060 IF (IABS(IPROP(4))-4) 410,480,480 MPR3070 410 DO 420 I=1,2 MPR3080 IRSLTA(1,I)=IRWA MPR3090 420 IRSLTA(2,I)=IRWB MPR3100 IF (IPROP(4)) 430,430,440 MPR3110 430 A(26)=2 MPR3120 GO TO 450 MPR3130 440 A(26)=1 MPR3140 450 IF (IPROP(5)) 460,460,470 MPR3150 460 A(27)=2 MPR3160 GO TO 550 MPR3170 470 A(27)=1 MPR3180 GO TO 550 MPR3190 480 DO 490 I=1,2 MPR3200 IRSLTA(1,I)=ICLMA MPR3210 490 IRSLTA(2,I)=ICLMB MPR3220 IF (IPROP(4)) 500,500,510 MPR3230 500 A(26)=4 MPR3240 GO TO 520 MPR3250 510 A(26)=3 MPR3260 520 IF (IPROP(5)) 530,530,540 MPR3270 530 A(27)=4 MPR3280 GO TO 550 MPR3290 540 A(27)=3 MPR3300 550 IRSLTP(1)=A(26) MPR3310 IRSLTP(2)=A(27) MPR3320 WRITE (IPRINT,750) ((IRSLTA(J,I),J=1,2),IRSLTP(I),I=1,2) MPR3330 DO 560 I=1,22 MPR3340 560 WRITE (IPRINT,720) MPR3350 WRITE (IPRINT,760) MPR3360 570 IF (NARGS.EQ.4) RETURN MPR3370 IF (MOD(NARGS,2).EQ.0) GO TO 610 MPR3380 IP=31 MPR3390 IF (IARGS(3).EQ.IARGS(4)) GO TO 590 MPR3400 IP=27 MPR3410 DO 580 I=19,25 MPR3420 580 A(I)=0.0 MPR3430 590 IF (MOD(L2,2).EQ.0) IP=18 MPR3440 IF (NROW.LT.IP) IP=NROW MPR3450 DO 600 I=1,IP MPR3460 RC(KPROP)=A(I) MPR3470 600 KPROP=KPROP+1 MPR3480 IF (NARGS.EQ.5) RETURN MPR3490 610 KA=IARGS(5) MPR3500 ANRMX=IARGS(3) MPR3510 DO 620 I=1,JK MPR3520 RC(KA)=A(I+100)/ANRMX MPR3530 620 KA=KA+NROW MPR3540 IF (NARGS.LT.8) RETURN MPR3550 KA=IARGS(9) MPR3560 ANRMX=IARGS(4) MPR3570 KB=JK+101 MPR3580 DO 630 I=1,IN MPR3590 RC(KA)=A(KB)/ANRMX MPR3600 KA=KA+1 MPR3610 630 KB=KB+1 MPR3620 IF (L2.GT.2) RC(KA)=AVG MPR3630 RETURN MPR3640 C MPR3650 640 FORMAT (1H0,39X,14HPROPERTIES OF ,I3,3H X ,I3,27H MATRIX STARTING MPR3660 1LOCATION (,I3,1H,,I3,1H)) MPR3670 650 FORMAT (23X,3HCOL,I7) MPR3680 660 FORMAT (30X,7HGENERAL/23X,1HR/23X,9H1 TRACE (,I3,13H VALUES USED),MPR3690 17X,1PE15.6/23X,32H2 TRACE NO. 2 ,E15.6//23X,32H3MPR3700 2 MAXIMUM ELEMENT ,E15.6/23X,20H4 MINUMUM ELEMENT ,MPR3710 3 12X ,E15.6/23X,32H5 MAXIMUM ELEMENT IN ABS VALUE ,E15.6/23XMPR3720 4,32H6 MINUMUM ELEMENT IN ABS VALUE ,E15.6/23X,32H7 MIN NON-ZERO EMPR3730 5LEM IN ABS VAL ,E15.6//23X,32H8 NUMBER OF POSITIVE ELEMENTS ,10MPR3740 6X,I5/,23X,32H9 NUMBER OF ZERO ELEMENTS ,10X,I5/22X,33H10 NUMMPR3750 7BER OF NEGATIVE ELEMENTS ,10X,I5//22X,33H11 SUM OF TERMS MPR3760 8 ,E15.6/22X,33H12 AVERAGE ,E15.6/22MPR3770 9X,33H13 SUM OF SQUARES ,E15.6/22X,33H14 SUM OF SQUAMPR3780 $RES ABOUT MEAN ,E15.6/22X,33H15 WITHIN ROWS SUM OF SQUARES MPR3790 $,E15.6/22X,33H16 WITHIN COLS SUM OF SQUARES ,E15.6) MPR3800 670 FORMAT (22X,33H17 SUM OF ABSOLUTE VALUES ,1PE15.6/22X,33H18MPR3810 1 AVERAGE OF ABSOLUTE VALUES ,E15.6) MPR3820 680 FORMAT (1H0,29X,8HSPECIFIC/) MPR3830 690 FORMAT (22X,33H19 DETERMINANT ,1PE15.6/22X,33H18MPR3840 1 RANK ,7X,I8/30X,5HNORMS/22X,33H21 SQ ROOMPR3850 2T OF SUM OF B(I,J)**2 ,E15.1/22X,33H22 N*MAX(B(I,J)) MPR3860 3 ,E15.1/22X,33H23 MAX VAL OF ROW SUM ,E15.1) MPR3870 700 FORMAT (1H0,21X,32H24 NORMALITY ,13X,A3,2H*(,I1MPR3880 1,1H)/22X,33H25 SYMMETRY ,12X,A3,2H*(,I1,1H)/2MPR3890 22X,33H26 SKEW SYMMETRY ,12X,A3,2H*(,I1,1H)/22X,33HMPR3900 327 DIAGONALITY ,12X,A3,2H*(,I1,1H)/22X,33H28 ORTMPR3910 4HOGONALITY: A,A=I ,12X,A3,2H*(,I1,1H)/22X,2H29,17X,19HA,AMPR3920 5=DIAGONAL MATRIX,7X,A3,2H*(,I1,1H)//) MPR3930 710 FORMAT(22X,13H30 TRIANGULAR,20X,3A3,A1,2A3,3H**(,I1,1H)/22X,33H31 MPR3940 1STOCHASTIC (R AND/OR C SUMS=1),3X,4A3,4H***(,I1,1H)) MPR3950 720 FORMAT (1H ) MPR3960 730 FORMAT (9X,79H* IF ANSWER IS YES, (R,C)=1 OR 2. (1, IF EXACT; 2, MPR3970 1IF TOLERANCE IS SATISFIED.)/11X,25HIF ANSWER IS NO, (R,C)=0.//8X,1MPR3980 20HTRIANGULAR/8X,69H** (R,C)=0,IF ANSWER IS NO; (R,C)=1, IF UPPER PMPR3990 3ART OF MATRIX IS ZERO;/11X,74H(R,C)=2, IF LOWER PART IS ZERO; (R,CMPR4000 4)=3, IF ALL OFF DIAGONAL ELEMENTS = 0.//7X,10HSTOCHASTIC/7X,75H***MPR4010 5 (R,C)=0, IF MATRIX IS NOT STOCHASTIC; (R,C)=1, IF SUM OF EACH ROWMPR4020 6 = 1; /11X,75H(R,C)=2, IF SUM OF EACH COLUMN=1; (R,C)=3, IF SUM OFMPR4030 7 EACH ROW AND COLUMN=1.) MPR4040 740 FORMAT (1H0,39X,14HPROPERTIES OF ,I3,3H X ,I3,26H ARRAY STARTING LMPR4050 1OCATION (,I3,1H,,I3,1H)) MPR4060 750 FORMAT(22X,32H26 ORTHOGONATLITY; A,A=I ,9X,2A3,2H*(,I1,1H)/MPR4070 1 22X,2H27,17X,19HA,A=DIAGONAL MATRIX,3X2A3,2H*(,I1,1H)) MPR4080 760 FORMAT (9X,86H* (R,C)=0, IF MATRIX IS NOT ORTHOGONAL; (R,C)=1 OR 2MPR4090 1 IF MATRIX IS ORTHOGONAL ROW WISE;/11X,97H(R,C)=3 OR 4, IF MATRIX MPR4100 2IS ORTHOGONAL COLUMN WISE. ( (R,C)=1, IF I=1 OR 3 ORTHOGONALITY ISMPR4110 3 EXACT;/11X,50HFOR I=2 OR 4 RELATIVE WITHIN ERROR BOUND OF .1E.6))MPR4120 END MPR4130 SUBROUTINE MRAISE MRA 10 C VERSION 5.00 MRAISE 5/15/70 MRA 20 C * MRA 30 C SUBROUTINE TO RAISE A MATRIX TO A POWER 9/13/67 MRA 40 C GENERAL FORMS OF MRAISE MRA 50 C MRAISE A(,) N,N TO M POWER AND STORE IN C(,) MRA 60 C M MAY BE INTEGER OR REAL MRA 80 C IF M=0 C=IDENTITY MATRIX MRA 90 C IF M=1 C=A MRA 100 C * MRA 110 COMMON /BLOCRC/ NRC,RC(12600) MRA 120 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMRA 130 1ARGS,VWXYZ(8),NERROR MRA 140 DIMENSION ARGS(100) MRA 150 EQUIVALENCE (ARGS(1),RC(12501)) MRA 160 COMMON /SCRAT/ NS,NS2,A(13500) MRA 170 DOUBLE PRECISION X,SUM MRA 180 DIMENSION X(1) MRA 190 EQUIVALENCE (X,A) MRA 200 C * MRA 210 C CHECK NUMBER OF ARGUMENTS MRA 220 C * MRA 230 IF(NARGS.NE.7) CALL ERROR (10) MRA 240 C * MRA 250 C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGER MRA 260 C * MRA 270 J=NARGS MRA 280 CALL CKIND (J) MRA 290 IF (J.EQ.0) GO TO 20 MRA 300 IF (KIND(NARGS-2).NE.0) GO TO 10 MRA 310 CALL ERROR (3) MRA 320 GO TO 20 MRA 330 10 IARGS(NARGS-2)=ARGS(NARGS-2) MRA 340 C * MRA 350 C CHECK TO SEE IF M (POWER) IS NEGATIVE MRA 360 C * MRA 370 20 IF (IARGS(NARGS-2).LT.0) CALL ERROR (3) MRA 380 C * MRA 390 C CHECK TO SEE IF DIMENSIONS ARE CORRECT MRA 400 C * MRA 410 IF (IARGS(3).NE.IARGS(4)) CALL ERROR (3) MRA 430 C * MRA 440 C CHECK TO SEE IF ARGUMENTS ARE OUT OF RANGE MRA 450 C * MRA 460 30 NPOW=IARGS(NARGS-2)-1 MRA 470 40 IARGS(5)=IARGS(NARGS-1) MRA 500 IARGS(6)=IARGS(NARGS) MRA 510 IARGS(7)=IARGS(3) MRA 520 IARGS(8)=IARGS(4) MRA 530 J=2 MRA 540 CALL MTXCHK (J) MRA 550 IF (J-1) 70,50,60 MRA 560 50 CALL ERROR (3) MRA 570 RETURN MRA 580 60 CALL ERROR (17) MRA 590 RETURN MRA 600 C * MRA 610 C CHECK TO SEE IF PREVIOUS ERRORS MRA 620 C * MRA 630 70 IF (NERROR.NE.0) RETURN MRA 640 ISIZE=IARGS(3) MRA 650 C * MRA 660 C BEGIN MULTIPLICATION MRA 670 C * MRA 680 C * MRA 690 C MOVE ORIGINAL MATRIX TO SCRATCH AREA (COLUMWIZE) MRA 700 C * MRA 710 IF (NPOW) 80,90,110 MRA 720 80 IEXT=1 MRA 730 GO TO 100 MRA 740 90 IEXT=2 MRA 750 100 ISAV=IARGS(5) MRA 760 GO TO 120 MRA 770 110 IEXT=3 MRA 780 120 IP=IARGS(1) MRA 790 IC=1 MRA 800 DO 220 J=1,ISIZE MRA 810 DO 180 I=1,ISIZE MRA 820 GO TO (130,160,170), IEXT MRA 830 130 IF (I.EQ.J) GO TO 140 MRA 840 RC(ISAV)=0.0 MRA 850 GO TO 150 MRA 860 140 RC(ISAV)=1.0 MRA 870 150 ISAV=ISAV+1 MRA 880 GO TO 180 MRA 890 160 RC(ISAV)=RC(IP) MRA 900 IP=IP+1 MRA 910 GO TO 150 MRA 920 170 A(IC)=RC(IP) MRA 930 IC=IC+1 MRA 940 IP=IP+1 MRA 950 180 CONTINUE MRA 960 GO TO (190,200,210), IEXT MRA 970 190 ISAV=ISAV+NROW-ISIZE MRA 980 GO TO 220 MRA 990 200 ISAV=ISAV+NROW-ISIZE MRA1000 210 IP=IP+NROW-ISIZE MRA1010 220 CONTINUE MRA1020 IF (IEXT.LE.2) RETURN MRA1030 IXP=NS-ISIZE*2 MRA1040 DO 280 K=1,NPOW MRA1050 ISAVP=IARGS(5) MRA1060 IMP=NS2 MRA1070 IF (K.GT.1) GO TO 230 MRA1080 IRP=IARGS(1) MRA1090 GO TO 240 MRA1100 230 IRP=IARGS(5) MRA1110 240 DO 280 I=1,ISIZE MRA1120 ISAV=ISAVP MRA1130 IC=1 MRA1140 IR=IRP MRA1150 IX=IXP MRA1160 C * MRA1170 C SAVE ROW OF MATRIX MRA1180 C * MRA1190 DO 250 J=1,ISIZE MRA1200 A(IX)=RC(IR) MRA1210 IX=IX-1 MRA1220 IR=IR+NROW MRA1230 250 CONTINUE MRA1240 DO 270 J=1,ISIZE MRA1250 IX=IXP MRA1260 IM=IMP MRA1270 DO 260 JP=1,ISIZE MRA1280 X(IM)=A(IX)*A(IC) MRA1290 IM=IM-1 MRA1300 IX=IX-1 MRA1310 IC=IC+1 MRA1320 260 CONTINUE MRA1330 CALL SORTSM (ISIZE,SUM) MRA1340 RC(ISAV)=SUM MRA1350 ISAV=ISAV+NROW MRA1360 270 CONTINUE MRA1370 ISAVP=ISAVP+1 MRA1380 IRP=IRP+1 MRA1390 280 CONTINUE MRA1400 RETURN MRA1410 END MRA1420 SUBROUTINE MSCROW MSC 10 C VERSION 5.00 MSCROW 5/15/70 MSC 20 COMMON /BLOCRC/ NRC,RC(12600) MSC 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMSC 40 1ARGS,VWXYZ(8),NERROR MSC 50 DIMENSION ARGS(100) MSC 60 EQUIVALENCE (ARGS(1),RC(12501)) MSC 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MSC 80 C SUBROUTINE BY CARLA MESSINA 221.04 JUNE 1967 MSC 90 C TYPE 1 IS PARSUM OF COL ++, STORE IN COL ++ MSC 100 C TYPE 2 IS PARPRODUCT OF COL ++, STORE IN COL ++ MSC 110 C TYPE 3 IS ROOT MEAN SQUARE RMS OF COL ++, STORE IN COL MSC 120 C TYPE 4 IS AVERAGE OF COL ++, STORE IN COL ++ (DOWN TO NMSC 130 C TYPE 5 IS SUM COL ++, STORE IN COL ++ (DOWN TO NRMAX) MSC 140 C SUM COL ++ FROM ROW ,, TO ROW ,, STORE IN COL ++ MSC 150 C SUM COL ++ FROM ROWS NUMBERED ,, ,, ,, ,, ETC STORE MSC 160 C THE THREE TYPES OF SUM ARE IDENTIFIED BY THE NO. OF NARGS =2,3 ANDMSC 170 ELEM=0.0 MSC 180 IF (NARGS-2) 10,40,40 MSC 190 10 K=10 MSC 200 20 CALL ERROR (K) MSC 210 30 RETURN MSC 220 40 CALL ADRESS (1,J1) MSC 230 IF (J1) 50,50,60 MSC 240 50 K=3 MSC 250 GO TO 20 MSC 260 60 CALL ADRESS (NARGS,J2) MSC 270 IF (J2) 50,50,70 MSC 280 70 IF (NARGS-3) 210,80,80 MSC 290 80 IF (L2-5) 10,90,10 MSC 300 90 NARG1=NARGS-1 MSC 310 DO 110 I=2,NARG1 MSC 320 IF (KIND(I).NE.0) GO TO 130 MSC 330 IF (IARGS(I)) 130,130,100 MSC 340 100 IF (IARGS(I)-NROW) 110,110,130 MSC 350 110 CONTINUE MSC 360 IF (NERROR.NE.0) GO TO 30 MSC 370 IF (NARGS-4) 120,120,180 MSC 380 C MSC 390 C SUM FROM ROW ,, TO ROW ,, MSC 400 C MSC 410 120 IF (IARGS(2)-IARGS(3)) 140,140,130 MSC 420 130 I=IARGS(2) MSC 430 IARGS(2)=IARGS(3) MSC 440 IARGS(3)=I MSC 450 140 IF (NRMAX) 150,150,160 MSC 460 150 K=9 MSC 470 GO TO 20 MSC 480 160 J=J1+IARGS(2) MSC 490 ELEM=ELEM+RC(J-1) MSC 500 IARGS(2)=IARGS(2)+1 MSC 510 IF (IARGS(2)-IARGS(3)) 160,160,170 MSC 520 170 CALL VECTOR (ELEM,J2) MSC 530 GO TO 30 MSC 540 180 IF (NRMAX) 150,150,190 MSC 550 C MSC 560 C SUM DISCRETE ROWS MSC 570 C MSC 580 190 DO 200 I=2,NARG1 MSC 590 J=J1+IARGS(I) MSC 600 200 ELEM=ELEM+RC(J-1) MSC 610 GO TO 170 MSC 620 210 IF (NERROR.NE.0) GO TO 30 MSC 630 IF (NRMAX) 150,150,220 MSC 640 220 FNRMAX=NRMAX MSC 650 C MSC 660 C PARSUM, PARPRODUCT MSC 670 C MSC 680 IF (L2-3) 230,260,280 MSC 690 230 J=L2-1 MSC 700 RC(J2)=RC(J1) MSC 710 IF (NRMAX.EQ.1) GO TO 30 MSC 720 DO 250 I=2,NRMAX MSC 730 J1=J1+1 MSC 740 J2=J2+1 MSC 750 IF (J.EQ.0) GO TO 240 MSC 760 RC(J2)=RC(J2-1)*RC(J1) MSC 770 GO TO 250 MSC 780 240 RC(J2)=RC(J2-1)+RC(J1) MSC 790 250 CONTINUE MSC 800 GO TO 30 MSC 810 C MSC 820 C RMS MSC 830 C MSC 840 260 DO 270 I=1,NRMAX MSC 850 J=J1+I MSC 860 270 ELEM=ELEM+RC(J-1)**2 MSC 870 ELEM=FSQRT(ELEM/FNRMAX) MSC 880 GO TO 170 MSC 890 C MSC 900 C AVERAGE, SUM ENTIRE COLUMN MSC 910 C MSC 920 280 DO 290 I=1,NRMAX MSC 930 J=J1+I MSC 940 290 ELEM=ELEM+RC(J-1) MSC 950 IF (L2-5) 300,170,170 MSC 960 300 ELEM=ELEM/FNRMAX MSC 970 GO TO 170 MSC 980 END MSC 990 SUBROUTINE MTRIAN MTR 10 C VERSION 5.00 MTRIAN 5/15/70 MTR 20 C MTRIAN SUBROUTINE FOR OMNITAB 11/27/67 BY S PEAVY MTR 30 C MTR 40 C TRIANGULARIZATION OF NON-SINGULAR, REAL SYMMETRIC MATRIX MTR 50 C A=TT, LOWER TRINGLE IS COMPUTED MTR 60 C COMMAND IS: MTR 70 C MTRIAN A(,, ++),R=,, C=,, STORE T IN (,, ++) MTR 80 C OR MTR 90 C MTRIAN A(,, ++),R=,, C=,, STORE T IN(,, ++) AND T INVERSE (,, ++)MTR 100 C THE UPPER TRIANGLE IS SET = 0. MTR 110 C MTR 120 COMMON /SCRAT/ NS,NS2,A(13500) MTR 130 COMMON /BLOCRC/ NRC,RC(12600) MTR 140 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMTR 150 1ARGS,VWXYZ(8),NERROR MTR 160 DIMENSION ARGS(100) MTR 170 EQUIVALENCE (ARGS(1),RC(12501)) MTR 180 DIMENSION X(2) MTR 190 DOUBLE PRECISION X,SUM MTR 200 EQUIVALENCE (X,A) MTR 210 KRR=7 MTR 220 KRRA=7 MTR 230 KRRB=7 MTR 240 KRRC=7 MTR 250 J=2 MTR 260 IF (NARGS.EQ.6.OR.NARGS.EQ.8) GO TO 10 MTR 270 CALL ERROR (10) MTR 280 RETURN MTR 290 10 IF (IARGS(3).EQ.IARGS(4)) GO TO 20 MTR 300 CALL ERROR (KRR) MTR 310 RETURN MTR 320 20 IF (NARGS.EQ.6) GO TO 30 MTR 330 J=3 MTR 340 IARGS(9)=IARGS(7) MTR 350 IARGS(10)=IARGS(8) MTR 360 IARGS(11)=IARGS(3) MTR 370 IARGS(12)=IARGS(4) MTR 380 30 IARGS(7)=IARGS(3) MTR 390 IARGS(8)=IARGS(4) MTR 400 CALL MTXCHK (J) MTR 410 IF (J-1) 60,40,50 MTR 420 40 CALL ERROR (3) MTR 430 RETURN MTR 440 50 CALL ERROR (17) MTR 450 RETURN MTR 460 60 IF (NERROR.NE.0) RETURN MTR 470 IR=IARGS(3) MTR 480 IRM=IR-1 MTR 490 K=IARGS(1) MTR 500 DO 70 I=1,IR MTR 510 IF (RC(K).GT.0.0) GO TO 70 MTR 520 C *** ERRA -MATRIX CAN NOT BE TRIANLIZED SINCE ONE OF THE TERMS ON MTR 530 C THE DIAG. IS ZERO OR LESS. MTR 540 CALL ERROR (KRRA) MTR 550 RETURN MTR 560 70 K=K+1+NROW MTR 570 K=IARGS(1) MTR 580 CALL SYMV (RC(K),NROW,IR,M) MTR 590 IF (M.LE.1) GO TO 80 MTR 600 C *** NON-SYMMETRIC MATRIX MTR 610 CALL ERROR (KRRC) MTR 620 RETURN MTR 630 80 M=2 MTR 640 A(1)=FSQRT(RC(K)) MTR 650 K=K+1 MTR 660 DO 90 I=2,IR MTR 670 A(M)=RC(K)/A(1) MTR 680 K=K+1 MTR 690 90 M=M+1 MTR 700 KA=IARGS(1) MTR 710 KB=KA+NROW+1 MTR 720 MA=2 MTR 730 DO 140 I=2,IR MTR 740 MB=MA MTR 750 L=NS2-1 MTR 760 X(NS2)=RC(KB) MTR 770 M=(I-1)*IR+I MTR 780 II=I-1 MTR 790 DO 100 J=1,II MTR 800 X(L)=-(A(MB)**2) MTR 810 L=L-1 MTR 820 100 MB=MB-IR MTR 830 CALL SORTSM (I,SUM) MTR 840 IF (SUM.GT.0.0) GO TO 110 MTR 850 C *** ERRB-LEADING SUBMATRIX IS SINGULAR MTR 860 CALL ERROR (KRRB) MTR 870 RETURN MTR 880 110 S=SUM MTR 890 S=FSQRT(S) MTR 900 A(M)=S MTR 910 M=M+1 MTR 920 IF (I.EQ.IR) GO TO 140 MTR 930 IP=I+1 MTR 940 KC=KB+1 MTR 950 DO 130 J=IP,IR MTR 960 X(NS2)=RC(KC) MTR 970 KC=KC+1 MTR 980 L=NS2-1 MTR 990 MC=J MTR1000 MD=I MTR1010 DO 120 JJ=1,II MTR1020 X(L)=-A(MC)*A(MD) MTR1030 MC=MC+IR MTR1040 MD=MD+IR MTR1050 120 L=L-1 MTR1060 CALL SORTSM (I,SUM) MTR1070 A(M)=SUM/S MTR1080 130 M=M+1 MTR1090 MA=MA+IR+1 MTR1100 140 KB=KB+NROW+1 MTR1110 K=IARGS(5)-1 MTR1120 KB=IARGS(5) MTR1130 DO 180 I=1,IR MTR1140 KA=K+I MTR1150 M=(I-1)*IR+I MTR1160 KC=KB MTR1170 DO 150 J=I,IR MTR1180 RC(KA)=A(M) MTR1190 KA=KA+1 MTR1200 150 M=M+1 MTR1210 IF (I.EQ.0) GO TO 170 MTR1220 II=I-1 MTR1230 DO 160 J=1,II MTR1240 RC(KC)=0.0 MTR1250 160 KC=KC+1 MTR1260 170 KB=KB+NROW MTR1270 180 K=K+NROW MTR1280 IF (NARGS.EQ.6) RETURN MTR1290 KC=IARGS(5) MTR1300 DO 210 I=1,IR MTR1310 M=(I-1)*IR+I MTR1320 A(M)=1.0/RC(KC) MTR1330 IF (I.EQ.IR) GO TO 210 MTR1340 M=M+1 MTR1350 IP=I+1 MTR1360 KB=KC+NROW+1 MTR1370 JC=1 MTR1380 DO 200 J=IP,IR MTR1390 KA=KC+J-I MTR1400 MA=(I-1)*IR+I MTR1410 L=NS2 MTR1420 DO 190 JA=1,JC MTR1430 X(L)=RC(KA)*A(MA) MTR1440 MA=MA+1 MTR1450 KA=KA+NROW MTR1460 190 L=L-1 MTR1470 CALL SORTSM (JC,SUM) MTR1480 S=SUM MTR1490 A(M)=-S/RC(KB) MTR1500 KB=KB+NROW+1 MTR1510 M=M+1 MTR1520 200 JC=JC+1 MTR1530 210 KC=KC+NROW+1 MTR1540 K=IARGS(9)-1 MTR1550 KB=IARGS(9) MTR1560 DO 250 I=1,IR MTR1570 KA=K+I MTR1580 M=(I-1)*IR+I MTR1590 KC=KB MTR1600 DO 220 J=I,IR MTR1610 RC(KA)=A(M) MTR1620 KA=KA+1 MTR1630 220 M=M+1 MTR1640 IF (I.EQ.1) GO TO 240 MTR1650 II=I-1 MTR1660 DO 230 J=1,II MTR1670 RC(KC)=0. MTR1680 230 KC=KC+1 MTR1690 240 KB=KB+NROW MTR1700 250 K=K+NROW MTR1710 RETURN MTR1720 END MTR1730 SUBROUTINE MTXCHK (J) MCK 10 C VERSION 5.00 MTXCHK 5/15/70 MCK 20 C S PEAVY FOR OMNITAB 10/24/67 MCK 30 C J AS INPUT = NO OF MATRICES TO BE CHECKED MCK 40 C IARGS(1), IARGS(5),...,IARGS(4*(J-1)+1) STARTING ROW OF MAT MCK 50 C IARGS(2), IARGS(6),...,IARGS(4*(J-1)+2) STARTING COLUMN OF MAT MCK 60 C IARGS(3), IARGS(7),...,IARGS(4*(J-1)+3) NO. OF ROWS MCK 70 C IARGS(4), IARGS(8),...,IARGS(4*(J-1)+4) NO OF COLUMNS MCK 80 C MCK 90 C UPON RETURN MCK 100 C J=0 IF ALL MATRICES ARE IN WORK SHEET MCK 110 C AND MCK 120 C IARGS(1),IARGS(5),...,IARGS(4*(J-1)+1) WILL CONTAIN STARTING MCK 130 C ADDRESS OF MATRIX MCK 140 C J GT ZERO IF MATRIX IS NOT IN WORK SHEET MCK 150 C J=1 SOME IARGS ARE NEGATIVE, J=2 MATRIX TO BIG FOR WORK SHEET MCK 160 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMCK 170 1ARGS,VWXYZ(8),NERROR MCK 180 JA=J MCK 220 JB=4*J MCK 230 J=0 MCK 240 DO 10 I=1,JB MCK 250 IF (IARGS(I).GT.0) GO TO 10 MCK 260 J=1 MCK 270 RETURN MCK 280 10 CONTINUE MCK 290 DO 20 I=1,JB,4 MCK 300 IF (IARGS(I)+IARGS(I+2)-1.GT.NROW) GO TO 30 MCK 310 IF (IARGS(I+1)+IARGS(I+3)-1.GT.NCOL) GO TO 30 MCK 320 20 IARGS(I)=IARGS(I)+(IARGS(I+1)-1)*NROW MCK 330 RETURN MCK 340 30 J=2 MCK 350 RETURN MCK 360 END MCK 370 SUBROUTINE MXTXP (X,N,NP,K,A,L2,NASIZE,XP) MXP 10 C VERSION 5.00 MXTXP 5/15/70 MXP 20 C SUBROUTINE MXTXP R VARNER 2/12/68 MXP 30 C * MXP 40 C X IS MATLIX TO BE USED MXP 50 C N IS DIMENSIONED SIZE OF A MXP 60 C NP IS NUMBER OF ROWS IN A MXP 70 C K IS NUMBER OF COLUMNS IN A MXP 80 C L2=1 MULTIPLY X TIMES X TRANSPOSED MXP 90 C L2=2 MULTIPLY X TRANSPOSED TIMES X MXP 100 C NASIZE IS SIZE OF A DIVIDED BY 2 MXP 110 C A IS SCRATCH AREA WHERE MATRIX IS TO BE STORED MXP 120 C * MXP 130 DOUBLE PRECISION XP,SUM MXP 140 DIMENSION X(N,1), A(1), XP(1) MXP 150 IC=1 MXP 160 GO TO (10,40), L2 MXP 170 C COMPUTE X TIMES X TRANSPOSED MXP 180 C * MXP 190 10 DO 30 KK=1,NP MXP 200 DO 30 I=1,NP MXP 210 IS=NASIZE MXP 220 DO 20 J=1,K MXP 230 XP(IS)=X(I,J)*X(KK,J) MXP 240 20 IS=IS-1 MXP 250 CALL SORTSM (K,SUM) MXP 260 A(IC)=SUM MXP 270 30 IC=IC+1 MXP 280 RETURN MXP 290 C * MXP 300 C COMPUTE X TRANSPOSED TIMES X MXP 310 C * MXP 320 40 DO 60 L=1,K MXP 330 DO 60 J=1,K MXP 340 IS=NASIZE MXP 350 DO 50 I=1,NP MXP 360 XP(IS)=X(I,J)*X(I,L) MXP 370 50 IS=IS-1 MXP 380 CALL SORTSM (NP,SUM) MXP 390 A(IC)=SUM MXP 400 60 IC=IC+1 MXP 410 RETURN MXP 420 END MXP 430 SUBROUTINE MXTX MXT 10 C VERSION 5.00 MXTX 5/15/70 MXT 20 C SUBROUTINE MXTX R.V. 5/7/68 MXT 30 C * MXT 40 C SUBROUTINE TO MULTIPLY MATRIX A BY ITS TRANSPOSE MXT 50 C OR TRANSPOSE OF MATRIX A BY MATRIX A MXT 60 C L2=1 MULTIPLY MATRIX BY ITS TRANSPOSE MXT 70 C GENERAL FORM OF COMMAND MXT 80 C M(XXT) A(,) N,K, STORE IN C(,) N,K DEFINE X MXT 90 C L2=2 MULTIPLY TRANSPOSE OF MATRIX BY ITSELF MXT 110 C GENERAL FORM OF COMMAD MXT 120 C M(XTX) A(,) N,K STORE IN C(,) N,K DEFINE X MXT 130 C * MXT 150 COMMON /SCRAT/ NS,NS2,A(13500) MXT 160 COMMON /BLOCRC/ NRC,RC(12600) MXT 170 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NMXT 180 1ARGS,VWXYZ(8),NERROR MXT 190 DIMENSION ARGS(100) MXT 200 EQUIVALENCE (ARGS(1),RC(12501)) MXT 210 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG MXT 220 C DOUBLE PRECISION AP(3000) MXT 230 EQUIVALENCE (A,AP) MXT 240 C * MXT 250 C CHECK FOR CORRECT NUMBER OF AGRUMENTS MXT 260 C * MXT 270 C * MXT 280 C DECIDE WHETHER COMMAND IS M(XAX') OR M(X'AX) MXT 290 C L2=3 MEANS M(XAX') L2=2 NARGS.GT. 6 MEANS M(X'AX) MXT 300 C * MXT 310 IF (L2-2) 30,10,20 MXT 320 10 IF (NARGS.LE.6) GO TO 30 MXT 330 20 L2=4-L2 MXT 340 CALL TRANSF MXT 350 RETURN MXT 360 30 IF(NARGS.NE.6) CALL ERROR (10) MXT 370 C * MXT 380 C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS MXT 390 C * MXT 400 J=NARGS MXT 410 CALL CKIND (J) MXT 420 IF (J.NE.0) CALL ERROR (3) MXT 430 C * MXT 440 C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE MXT 450 C COMPUTE ADDRESSES MXT 460 C * MXT 470 40 GO TO (50,60), L2 MXT 520 50 IARGS(8)=IARGS(3) MXT 530 IARGS(7)=IARGS(3) MXT 540 GO TO 70 MXT 550 60 IARGS(8)=IARGS(4) MXT 560 IARGS(7)=IARGS(4) MXT 570 70 J=2 MXT 580 CALL MTXCHK (J) MXT 590 IF (J-1) 100,80,90 MXT 600 80 CALL ERROR (3) MXT 610 RETURN MXT 620 90 CALL ERROR (17) MXT 630 RETURN MXT 640 C * MXT 650 C CHECK FOR PREVIOUS ERRORS MXT 660 C * MXT 670 100 IF (NERROR.NE.0) RETURN MXT 680 IG=IARGS(1) MXT 690 CALL MXTXP (RC(IG),NROW,IARGS(3),IARGS(4),A,L2,NS2,AP) MXT 700 GO TO (110,120), L2 MXT 710 110 NROWP=IARGS(3) MXT 720 GO TO 130 MXT 730 120 NROWP=IARGS(4) MXT 740 130 NCOLP=NROWP MXT 750 IG=IARGS(5) MXT 760 CALL STORMT (RC(IG),NROW,NROWP,NCOLP,A) MXT 770 C * MXT 780 C MOVE FROM SCRATCH AREA TO STORAGE MXT 790 C * MXT 800 RETURN MXT 810 END MXT 820 SUBROUTINE NNAME (NAME) NNA 10 C VERSIONS 5.00 NNAME 5/15/70 NNA 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND NNA 30 DIMENSION NAME(2), MISC(6) NNA 40 C NNA 50 C THIS SUBROUTINE ASSEMBLES A NAME UP TO THE FIRST NON-LETTER OR UP NNA 60 C SIX LETTER, WHICHEVER IS FIRST. THE INDEX, M, IS INITIALLY POINTINNNA 70 C THE FIRST LETTER, IT IS LEFT POINTING AT THE FIRST NON-LETTER. NNA 80 C NNA 90 C SPACE OUT SO THAT TABLES LIES ALL ON ONE PAGE NNA 100 C NNA 110 C NNA 120 C CONVERSION TABLE FOR ALPHABETIC TO NUMERIC AS USED BY OMNITAB. NNA 130 C NNA 140 C A 729 27 1 NNA 150 C B 1458 54 2 NNA 160 C C 2187 81 3 NNA 170 C D 2916 108 4 NNA 180 C E 3645 135 5 NNA 190 C F 4374 162 6 NNA 200 C G 5103 189 7 NNA 210 C H 5832 216 8 NNA 220 C I 6561 243 9 NNA 230 C J 7290 270 10 NNA 240 C K 8019 297 11 NNA 250 C L 8747 324 12 NNA 260 C M 9477 351 13 NNA 270 C N 10206 378 14 NNA 280 C O 10935 405 15 NNA 290 C P 11664 432 16 NNA 300 C Q 12393 459 17 NNA 310 C R 13122 486 18 NNA 320 C S 13851 513 19 NNA 330 C T 14580 540 20 NNA 340 C U 15309 567 21 NNA 350 C V 16038 594 22 NNA 360 C W 16767 621 23 NNA 370 C X 17496 648 24 NNA 380 C Y 18225 675 25 NNA 390 C Z 18954 702 26 NNA 400 C NNA 410 C NNA 420 C THE FIRST THREE CHARACTERS GO INTO THE FIST WORD OF NAME NNA 430 C THE SECOND THREE CHARACTERS GO INTO THE SECOND WORD OF NAME NNA 440 C NNA 450 C NNA 460 DO 10 I=1,6 NNA 470 10 MISC(I)=0 NNA 480 DO 20 I=1,6 NNA 490 L=KARD(M)-9 NNA 500 IF (L.LT.1.OR.L.GE.27) GO TO 40 NNA 510 MISC(I)=L NNA 520 20 M=M+1 NNA 530 30 IF (KARD(M).LT.10.OR.KARD(M).GE.36) GO TO 40 NNA 540 M=M+1 NNA 550 GO TO 30 NNA 560 40 NAME(1)=MISC(3)+27*(MISC(2)+27*MISC(1)) NNA 570 NAME(2)=MISC(6)+27*(MISC(5)+27*MISC(4)) NNA 580 RETURN NNA 590 END NNA 600 FUNCTION NONBLA (I) NON 10 C VERSION 5.00 NONBLA 5/15/70 NON 20 C NON 30 C SCAN KARD STARTING AT KARD(I) UNTIL A NON-BLANK CHARACTER IS NON 40 C FOUND. POINT M AT IT AND ALSO RETURN IT AS FUNCTION VALUE. NON 50 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND NON 60 M=I NON 70 10 IF (KARD(M).NE.44) GO TO 20 NON 80 M=M+1 NON 90 GO TO 10 NON 100 20 NONBLA=KARD(M) NON 110 RETURN NON 120 END NON 130 SUBROUTINE NOTEPR(J) NOT 10 C VERSION 5.00 NOTEPR 5/15/70 NOT 20 C WRITTEN BY STP 4/21/70 NOT 30 C NOT 40 C IF J=0 BLANK OUT NOTE VARIABLE NOT 50 C IF J=1 STORE IN NOTE(1) THRU NOTE(60) FROM NEWCD (M-2) 60 CHAR NOT 60 C IF J=2 STORE IN NOTE(61) THRU NORE(120) FROM NEWCD (M-2) 60 CHAR NOT 70 C IF J=3 PRINT OUT NOTE(1) THRU NOTE(120) NOT 80 C NOT 90 COMMON/BLOCKA/MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND NOT 100 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH NOT 110 COMMON/NOTE/NOTE(120) NOT 120 DATA IBLANK/1H / NOT 130 IF (J.NE.0) GO TO 20 NOT 140 DO 10 I=1,120 NOT 150 10 NOTE(I)=IBLANK NOT 160 RETURN NOT 170 20 IF(J.NE.3) GO TO 40 NOT 180 IF(NPAGE.EQ.0) CALL PAGE(0) NOT 190 WRITE (IPRINT,30) (NOTE(I),I=2,120) NOT 200 RETURN NOT 210 30 FORMAT(1X,119A1) NOT 220 40 MA=M+60 NOT 230 M=M+1 NOT 240 IF(MA.GT.82) MA=82 NOT 250 MB=(J-1)*60+1 NOT 260 MC=MB+59 NOT 270 IF(J.NE.1.AND.J.NE.2) RETURN NOT 280 DO 100 I=MB,MC NOT 290 100 NOTE(I)=IBLANK NOT 300 I=MB NOT 310 DO 110 IC=M,MA NOT 320 NOTE(I)=NEWCD(IC-2) NOT 330 110 I=I+1 NOT 340 RETURN NOT 350 END NOT 360 SUBROUTINE OANOVA (YSUM,SU,ND9,FM,M,N,ND7,SSQ,IHC,NSU,B) OAN 10 C VERSION 5.00 OANOVA 5/15/70 OAN 20 C COMPUTE AND PRINT ANALYSIS OF VARIANCE OAN 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/09/69 OAN 40 C ***** OAN 50 COMMON/BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, OAN 60 1NARGS,VWXYZ(8),NERROR OAN 70 COMMON/BLOCKE/NAME(4),L1,L2,ISRFLG OAN 90 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH OAN 100 COMMON/SCRAT/NS,NS2,A(13500) OAN 110 DIMENSION B(1),IHC(1) OAN 160 DOUBLE PRECISION YSUM OAN 170 C ***** OAN 180 1850 RESMS = YSUM/SU OAN 190 NSUA = NSU OAN 200 IT = 1 OAN 210 IF (L2.EQ.3) IT=3 OAN 220 WRITE (IPRINT,1860) IHC(IT),IHC(IT+1) OAN 230 1860 FORMAT (////50X,20HANALYSIS OF VARIANCE/24X,73H-DEPENDENT ON ORDEROAN 240 1 VARIABLES ARE ENTERED, UNLESS VECTORS ARE ORTHOGONAL-// OAN 250 21X,2A3,4X, 21H SS=RED. DUE TO COEF.,21H CUM. MS REDUCTIOOAN 260 3N ,6H D.F.,21H CUM. RESIDUAL MS ,6H D.F.,11H F(COEF=0),6H POAN 270 4(F),11H F(COEFS=0),6H P(F)/) OAN 280 IND9 = ND9+M OAN 290 ASUM = 0.0 OAN 300 VR = SU-FM OAN 340 RESSS = VR*SSQ OAN 350 IND7 = ND7+M OAN 400 A(IND7) = RESSS OAN 410 IF(M.EQ.1) GO TO 1866 OAN 415 DO 1865 I1=2,M OAN 420 IND7 = IND7-1 OAN 430 A(IND7) = A(IND7+1) + A(IND9) OAN 440 1865 IND9 = IND9-1 OAN 450 1866 V1F2 = FM+1.0 OAN 460 B(1) = A(IND9-1) OAN 470 B(2) = A(IND9-2) OAN 480 A(IND9-1) = YSUM OAN 482 A(IND9-2) = RESSS OAN 484 CALL RFORMT (A(IND9-2),M+2,8,NW1,NDEC1,18,A(1),A(1),0,0) OAN 490 A(IND9-1) = B(1) OAN 492 A(IND9-2) = B(2) OAN 494 CALL RFORMT (A(IND9),M,8,NW2,NDEC2,18,A(1),A(1),0,0) OAN 496 SSU=SU OAN 498 DO 1867 I=1,M OAN 500 SSU=SSU-1.0 OAN 505 B(I)=A(IND7)/SSU OAN 510 1867 IND7=IND7+1 OAN 515 IND7=IND7-M OAN 520 CALL RFORMT(B(1),M,8,NW3,NDEC3,18,A(1),A(1),0,0) OAN 525 SSU = SU OAN 530 DO 1950 I=1,M OAN 540 NSUA = NSUA-1 OAN 550 ASUM = ASUM+A(IND9) OAN 560 SSU = SSU-1.0 OAN 570 CR = ASUM/FLOAT(I) OAN 580 IF (ABS(SSU).GT.0.0) GO TO 1880 OAN 590 RESMS = 0.0 OAN 600 1870 F1 = 0.0 OAN 610 F2 = 0.0 OAN 620 PF1 = 1.0 OAN 630 PF2 = 1.0 OAN 640 GO TO 1890 OAN 650 1880 RESMS = A(IND7)/SSU OAN 660 V1F2 = V1F2-1.0 OAN 670 IF (ABS(RESMS).LE.0.0) GO TO 1870 OAN 680 C NEVER POOL OAN 690 F1 = A(IND9)/SSQ OAN 700 CALL PROB (1.,VR,F1,PF1) OAN 710 C TEST HIGHER SUB-HYPOTHESES OAN 720 F2 = ((A(IND7)+A(IND9)-RESSS)/V1F2)/SSQ OAN 730 CALL PROB (V1F2,VR,F2,PF2) OAN 740 1890 II = IABS(I-1) OAN 750 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(IND9),B( 1),21-NW1,1) OAN 760 CALL RFORMT (A(1),1,8,NW2,NDEC2,0, CR ,B(22),21-NW2,1) OAN 770 CALL RFORMT (A(1),1,8,NW3,NDEC3,0, RESMS ,B(43),21-NW3,1) OAN 780 IF (L2.EQ.1) GO TO 1920 OAN 790 WRITE (IPRINT,1900) IARGS(I+3),(B(I1),I1=1,42),I,(B(I2),I2=43,63),OAN 800 1NSUA,F1,PF1,F2,PF2 OAN 810 1900 FORMAT (1X,I4,6X,42A1,I6,21A1,I6,2(0PF11.3,F6.3)) OAN 820 GO TO 1940 OAN 830 1920 WRITE (IPRINT,1900) II,(B(I1),I1=1,42),I,(B(I2),I2=43,63), OAN 840 1NSUA,F1,PF1,F2,PF2 OAN 850 1940 IND7 = IND7+1 OAN 860 1950 IND9 = IND9+1 OAN 870 1951 FORMAT (/,1X,10HRESIDUAL ,21A1,21X,I6) OAN 880 1952 FORMAT (1X, 10HTOTAL ,21A1,21X,I6) OAN 890 F1 = RESSS OAN 900 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,F1, B(1),21-NW1,1) OAN 910 WRITE (IPRINT,1951) (B(I),I=1,21),NSUA OAN 920 F2 = YSUM OAN 930 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,F2,B(1),21-NW1,1) OAN 940 WRITE (IPRINT,1952) (B(I),I=1,21),NSU OAN 950 RETURN OAN 960 END OAN 970 SUBROUTINE OCOEFF (M1,N,ND18,ND17,IND19S,IND18S,IHC,B,IND7S,NSU,SSOCO 10 1,SSOLD,YSUM) OCO 20 C VERSION 5.00 OCOEFF 5/15/70 OCO 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/14/69. OCO 40 C ***** OCO 50 COMMON/BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, OCO 60 1NARGS,VWXYZ(8),NERROR OCO 70 COMMON/BLOCKE/NAME(4),L1,L2,ISRFLG OCO 90 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH OCO 100 COMMON/SCRAT/NS,NS2,A(13500) OCO 110 DIMENSION B(1),IHC(1) OCO 160 DOUBLE PRECISION YSUM OCO 165 C ***** OCO 170 IT = 1 OCO 180 IF (L2.EQ.3) IT=3 OCO 190 M = M1+1 OCO 200 WRITE (IPRINT,1960) IHC(IT),IHC(IT+1),IHC(IT),IHC(IT+1) OCO 210 1960 FORMAT (////20X,32HESTIMATES FROM LEAST SQUARES FIT,38X,18HFIT OMIOCO 220 1TTING LAST ,2A3//1X,2A3,5X,11HCOEFFICIENT,8X,14HS.D. OF COEFF.,4X,OCO 230 25HRATIO,3X,12H*ACC. DIGITS,9X,11HCOEFFICIENT,7X,14HS.D. OF COEFF.,OCO 240 35X,5HRATIO/) OCO 250 IND18 = N+ND18+1 OCO 260 IND17 = ND17+1 OCO 270 IND1 = IND19S+1 OCO 280 IND19 = IND18S+1 OCO 290 IND7 = IND7S+1 OCO 300 CALL RFORMT (A(IND19),M1+1,8,NW1,NDEC1,18,A(1),A(1),0,0) OCO 310 CALL RFORMT (A(IND1 ),M1+1,8,NW2,NDEC2,18,A(1),A(1),0,0) OCO 320 IF (M1.EQ.0) GO TO 2005 OCO 330 CALL RFORMT (A(IND18),M1 ,8,NW3,NDEC3,18,A(1),A(1),0,0) OCO 340 CALL RFORMT (A(IND17),M1 ,8,NW4,NDEC4,18,A(1),A(1),0,0) OCO 350 DO 2000 J=1,M1 OCO 360 IF (A(IND1)) 1982,1981,1982 OCO 370 1981 F1 = 0.0 OCO 380 GO TO 1983 OCO 390 1982 F1 = A(IND19)/A(IND1) OCO 400 1983 IF (A(IND17)) 1985,1984,1985 OCO 410 1984 F2 = 0.0 OCO 420 GO TO 1986 OCO 430 1985 F2 = A(IND18)/A(IND17) OCO 440 1986 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(IND19),B(1),20-NW1,1) OCO 450 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(IND1 ),B(21),20-NW2,1) OCO 460 CALL RFORMT (A(1),1,8,NW3,NDEC3,0,A(IND18),B(41),20-NW3,1) OCO 470 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,A(IND17),B(61),20-NW4,1) OCO 480 JJ = L2/3 OCO 490 JJ = IABS(J-1)*(1-JJ)+IARGS(J+3)*JJ OCO 500 WRITE (IPRINT,1990) JJ,(B(I1),I1=1,40),F1,A(IND7),(B(I2),I2=41,80)OCO 510 1,F2 OCO 520 1990 FORMAT (1X,I4,2X, 40A1,0PF7.2,6X,F5.2,8X,40A1,F7.2) OCO 530 IND7 = IND7+1 OCO 540 IND19 = IND19+1 OCO 550 IND17 = IND17+1 OCO 560 IND1 = IND1+1 OCO 570 2000 IND18 = IND18+1 OCO 580 2005 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(IND19),B(1),20-NW1,1) OCO 590 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(IND1 ),B(21),20-NW2,1) OCO 600 F1 = A(IND19)/A(IND1 ) OCO 610 NSUA = NSU-M OCO 620 NRM1= NSU-M1 OCO 630 JJ = L2/3 OCO 640 JJ = IABS(M1)*(1-JJ)+IARGS(M1+4)*JJ OCO 650 WRITE (IPRINT,1990) JJ,(B(I),I=1,40),F1,A(IND7) OCO 660 CALL RFORMT (SSOLD,1,8,NW2,NDEC2,18,A(1),A(1),0,0) OCO 670 B(52)=SS OCO 672 C ADJUST FOR M1=0 OCO 674 IF(M1.NE.0) GO TO 2009 OCO 676 B(52) = YSUM/FLOAT(N) OCO 678 B(52) = FSQRT(B(52)) OCO 680 2009 CALL RFORMT (B(52),1,8,NW4,NDEC4,18,A(1),A(1),0,0) OCO 682 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,SSOLD,B(1),20-NW2,0) OCO 690 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,B(52),B(21),20-NW4,0) OCO 700 WRITE (IPRINT,2010) (B(I),I=1,40),NSU,M,NSUA,NSU,M1,NRM1 OCO 710 2010 FORMAT (/1X,30HRESIDUAL STANDARD DEVIATION = ,3X,20A1,26X,20A1/4X,OCO 720 128HBASED ON DEGREES OF FREEDOM ,9X,I4,1H-,I2,3H = ,I3,33X,I4,1H-, OCO 730 2I2,3H = ,I3//120H * THE NUMBER OF CORRECTLY COMPUTED DIGITS IN EACOCO 740 3H COEFFICIENT USUALLY DIFFERS BY LESS THEN 1 FROM THE NUMBER GIVENOCO 750 4 HERE) OCO 760 RETURN OCO 770 END OCO 780 SUBROUTINE OCOVAR (M,ND7,MD1,IHC,B,IHT) OCV 10 C VERSION 5.00 OCOVAR 5/15/70 OCV 20 C PRINT VARIANCE-COVARIANCE MATRIX OCV 30 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 10/10/69. OCV 40 C ***** OCV 50 COMMON/BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, OCV 60 1NARGS,VWXYZ(8),NERROR OCV 70 COMMON/BLOCKE/NAME(4),L1,L2,ISRFLG OCV 80 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH OCV 90 COMMON/SCRAT/NS,NS2,A(13500) OCV 100 DIMENSION IHC(1),B(1),IHT(1) OCV 110 1750 IND7 = ND7+1 OCV 120 1791 FORMAT (////31X,56HVARIANCE-COVARIANCE MATRIX OF THE ESTIMATED COEOCV 130 1FFICIENTS) OCV 140 1792 FORMAT (/1X,2A3,1X,7(6X,I5,4X)) OCV 150 1793 FORMAT (1X,I4,3X,106A1) OCV 160 WRITE (IPRINT,1791) OCV 180 CALL RFORMT (A(IND7),MD1,8,NW1,NDEC1,13,A(1),A(1),0,0) OCV 190 IF (L2.EQ.1) I6=-1 OCV 200 IF (L2.EQ.3) I6=3 OCV 210 C I1END = NUMBER OF BLOCKS OF PRINTING OCV 220 I1END=(M+6)/7 OCV 230 DO 1820 I1=1,I1END OCV 240 I3BEG=7*(I1-1)+1 OCV 250 I2BEG=I3BEG+I6 OCV 260 I2END = MIN0 (M+I6,I2BEG+6) OCV 270 IF (L2-2) 1811,1811,1813 OCV 280 1811 I7END=I2END+1-I2BEG OCV 290 DO 1812 I7=1,I7END OCV 300 1812 IHT(I7)=I2BEG-1+I7 OCV 310 WRITE (IPRINT,1792) IHC(L2),IHC(L2+1),(IHT(I7),I7=1,I7END) OCV 320 GO TO 1814 OCV 330 1813 WRITE (IPRINT,1792) IHC(L2),IHC(L2+1),(IARGS(I2),I2=I2BEG,I2END) OCV 340 1814 WRITE (IPRINT,1793) OCV 350 LOC1 = IND7+(I3BEG*(I3BEG+1))/2-1 OCV 360 C I3 IS FOR LOOP ON ROWS OCV 370 DO 1820 I3=I3BEG,M OCV 380 I4END=MIN0 (I3,I3BEG+6) + 1 - I3BEG OCV 390 C I4 IS FOR LOOP ON COLUMNS OCV 400 DO 1815 I4 = 1, I4END OCV 410 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(LOC1),B(15*I4-14),15-NW1,0) OCV 420 1815 LOC1=LOC1+1 OCV 430 I5END = 15*I4END OCV 440 IF (L2.EQ.1) I8 =I3-1 OCV 450 IF (L2.EQ.3) I8=IARGS(I3+3) OCV 460 WRITE (IPRINT,1793) I8,(B(I5),I5=1,I5END) OCV 470 1820 LOC1 = LOC1-I4END+I3 OCV 480 RETURN OCV 490 END OCV 500 SUBROUTINE OMCONV (NWCD,KRD,KRDEND) OMC 10 C VERSION 5.00 OMCONV 5/15/70 OMC 20 COMMON /ABCDEF/ L(48) OMC 30 C OMC 40 C ARRAY L CONTAINS THE ALPHABET FORMATTED 1H OMC 50 C OMC 60 C THIS ROUTINE CONVERTS INPUT CARD IMAGES TO A STANARD CODE SO OMC 70 C THAT OMNITAB CAN DEAL WITH THE CHARACTERS AS INTEGERS. OMC 80 C OMC 90 C OMC 100 C THIS ROUTINE IS INCLUDED ONLY FOR COMPLETENESS. IT SHOULD BE OMC 110 C REWRITTEN IN ASSEMBLY LANGAUGE FOR EACH COMPUTER. ALSO, IT OMC 120 C CANNOT MEET ASA STANDARDS BECAUSE ASA DOES NOT REQUIRE THAT DATA OMC 130 C READ WITH FORMAT A1 BE STORED THE SAME AS HOLLERITH DATA SETUP OMC 140 C WITH 1H ALTHOUGH THEY WILL BE THE SAME ON MOST COMPUTERS. OMC 150 C OMC 160 C ALSO, ASA DOES NOT RECONGNIZE THE CHARACTER ' APOSTROPHE OMC 170 C OMC 210 DIMENSION NWCD(1), KRD(1) OMC 220 DO 30 I=1,KRDEND OMC 230 K=NWCD(I) OMC 240 C SPECIAL CASE CHECK FOR BLANKS OMC 250 IF(K.NE.L(45)) GO TO 10 OMC 260 J=45 OMC 270 GO TO 30 OMC 280 C OMC 290 C THE UPPER BOUND OR LIMIT ON J MUST BE CHANGED IF MORE CHARACTERS OMC 300 C ARE ADDED TO THE VECTOR L IN LABEL COMMON ABCDEF OMC 310 C OMC 320 10 DO 20 J=1,48 OMC 330 IF(K.EQ.L(J)) GO TO 30 OMC 340 20 CONTINUE OMC 350 J=47 OMC 360 30 KRD(I)=J-1 OMC 370 RETURN OMC 380 END OMC 410 SUBROUTINE OMNIT OMN 10 C VERSION 5.00 OMNIT 5/15/70 OMN 20 C *************** THIS IS THE MAIN OMNITAB ROUTINE *****************OMN 30 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND OMN 40 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) OMN 50 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST OMN 60 COMMON /BLOCRC/ NRC,RC(12600) OMN 70 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NOMN 80 1ARGS,VWXYZ(8),NERROR OMN 90 DIMENSION ARGS(100) OMN 100 EQUIVALENCE (ARGS(1),RC(12501)) OMN 110 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG OMN 120 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH OMN 130 C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS OMN 150 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP OMN 160 C ******************************************************************OMN 170 DATA IBLANK/1H /,LETSGO/-1/ OMN 180 C OMN 190 C THIS IS THE MAIN OMNITAB PROGRAM OMN 200 C OMN 210 C OMN 220 C SUBROUTINES CALLED BY THIS PROGRAM.. OMN 230 C SETUP,INPUT,ERROR,STMT,NNAME,AARGS,ASTER,SETQ,READQ,STORE,XECUTE OMN 240 C AERR,XOMNIT,XFORMT,LOOKUP OMN 250 C OMN 260 C OMN 270 C MOD = 1 INTERPETIVE MODE OMN 280 C = 2 DATA MODE (READ SET) OMN 290 C = 3 STORAGE MODE (BETWEEN BEGIN AND FINISH) OMN 300 C =4 IMPLIED STORAGE MODE (STATEMENT NUMBER GIVEN) OMN 310 C OMN 320 C OMN 330 C 0 = 0, 1 = 1, ETC., 9 = 9, A = 10, B = 11, ETC, Z= 35, / = 36 OMN 340 C . = 37, - = 38, + = 39, * = 40, ( = 41 ) = 42, , = 43 OMN 350 C BLANK = 44, = = 45, $ AND OTHERS = 46 OMN 360 C OMN 370 CALL SETUP OMN 460 10 IF (MODE.EQ.3) NSTMT=NSTMT+10 OMN 470 IF (MODE.EQ.4) MODE=1 OMN 480 NAME(1)=0 OMN 490 NAME(2)=0 OMN 500 NAME(3)=0 OMN 510 NAME(4)=0 OMN 520 NARGS=0 OMN 530 J=0 OMN 540 C OMN 550 C CHECK FOR ACCUMULATED ERRORS DURING LAST EXECUTED COMMAND OMN 560 C OMN 570 CALL AERR (0) OMN 580 20 CALL INPUT OMN 590 C OMN 600 C SCANNING BEGINS WITH THE THIRD CHARACTER. THE FIRST TWO ARE DUMMY OMN 610 C TO KEEP THE PROGRAM OUT OF TROUBLE. SCANNING TERMINATES WITH A $ OMN 620 C A $ HAS BEEN PLANTED IN THE (KRDEND+1)-TH POSITION. OMN 630 C OMN 640 M=2 OMN 650 30 M=M+1 OMN 660 K=KARD(M) OMN 670 IF (K.GE.36) IF (K-46) 45,40,30 OMN 675 IF (K.GE.10) GO TO 60 OMN 680 C OMN 690 C A NUMBER IS THE FIRST ALPHANUMERIC CHARACTER ENCOUNTERED, ERROR IFOMN 700 C IN MODE 3 OMN 710 C OMN 720 CALL OUTPUT OMN 730 IF (MODE.NE.3) GO TO 50 OMN 740 35 CALL ERROR (2) OMN 750 GO TO 20 OMN 760 40 IF (MODE.NE.4) CALL OUTPUT OMN 770 GO TO 10 OMN 780 C CHECK FOR * OR ' OMN 790 45 IF (K-40) 30,190,30 OMN 800 50 CALL STMT (NSTMT) OMN 810 IF (KARG.NE.0) IF (MODE-2) 35,185,35 OMN 815 C OMN 820 C IF AN ILLEGAL STATEMENT NUMBER WAS FOUND, KARG = 1 (KARG = 0 IF OMN 830 C LEGAL) OMN 840 C OMN 850 MODE=4 OMN 860 C OMN 870 C M IS POINTING AT THE FIRST LETTER ON THE CARD, ASSEMBLE NAME. OMN 880 C OMN 890 60 CALL NNAME (NAME(1)) OMN 900 C OMN 910 C OMN 920 C CHECK THE FIRST NAME FOR SPECIAL NAMES... OMN 930 C OMNITAB, FORMAT, NOTE, FOOTNOTE, HEAD,TITLE OMN 940 C OMN 950 C OMNITAB OMN 960 C OMN 970 IF (NAME(1).NE.11300.OR.NAME(2).NE.7102)IF(LETSGO) 65,67,67 OMN 975 C OMN 980 C IF NOT THE FIRST OMNITAB CARD, WRITE EOF RECORD. OMN 990 C OMN1000 IF(LETSGO.NE.(-1)) WRITE (ISCRAT,390) OMN1010 LETSGO=LETSGO+1 OMN1020 65 CALL XOMNIT (LETSGO) OMN1030 IF(LETSGO.NE.(-1)) GO TO 10 OMN1040 LETSGO=0 OMN1050 C OMN1060 C FINISH OMN1070 C OMN1080 67 IF (NAME(1).NE.4631.OR.NAME(2).NE.7082) GO TO 70 OMN1090 MODE=1 OMN1100 GO TO 40 OMN1110 C OMN1120 C FORMAT OMN1130 C OMN1140 70 IF (MODE.NE.4) CALL OUTPUT OMN1150 IF (NAME(1).NE.4797.OR.NAME(2).NE.9524) GO TO 90 OMN1160 CALL XFORMT OMN1170 80 IF (MODE.GE.3) CALL ERROR (202) OMN1180 IF (MODE.NE.3) MODE=1 OMN1190 GO TO 10 OMN1200 C OMN1210 C NOTE OMN1220 C OMN1230 90 IF (NAME(1).NE.10631.OR.NAME(2).NE.3645) GO TO 100 OMN1240 K=KARD(M) OMN1243 IF (K.EQ.1.OR.K.EQ.2) GO TO 95 OMN1245 IF (NPAGE.EQ.0) CALL PAGE (0) OMN1247 WRITE (IPRINT,400) (NEWCD(I-2),I=M,82) OMN1250 LNCNT=LNCNT+1 OMN1260 GO TO 80 OMN1270 95 CALL NOTEPR (K) OMN1273 GO TO 80 OMN1275 C OMN1280 C HEAD OMN1290 C OMN1300 100 IF (NAME(1).NE.5968.OR.NAME(2).NE.2916) GO TO 110 OMN1310 CALL XHEAD OMN1320 GO TO 80 OMN1330 C OMN1340 C TITLES. TITLEX = TITLE5, TITLEY = TITLE6 OMN1350 C OMN1360 110 IF (NAME(1).NE.14843) GO TO 160 OMN1370 C CHECK NAME TITLE OMN1380 IF (NAME(2).EQ.8883) GO TO 120 OMN1390 C CHECK TITLEX, TITLEY OMN1400 K=5 OMN1410 M=M+1 OMN1420 IF(NAME(2).NE.8908) IF (NAME(2)-8907) 160,130,160 OMN1425 K=6 OMN1430 GO TO 130 OMN1440 120 K=KARD(M) OMN1450 IF(K.GE.1.AND.K.LE.4) GO TO 130 OMN1460 CALL ERROR (209) OMN1470 K=1 OMN1480 130 MM=MIN0(M+59,81) OMN1490 DO 140 I=1,60 OMN1500 140 ITLE(I,K)=IBLANK OMN1510 I=1 OMN1520 DO 150 MA=M,MM OMN1530 ITLE(I,K)=NEWCD(MA-1) OMN1540 150 I=I+1 OMN1550 GO TO 80 OMN1560 C OMN1570 C STOP OMN1580 C OMN1590 160 IF (NAME(1).NE.14406.OR.NAME(2).NE.11664) GO TO 170 OMN1600 WRITE (ISCRAT,390) OMN1610 CALL XSTOP OMN1620 STOP OMN1630 C OMN1640 C M IS POINTING AT THE FIRST NON-LETTER AFTER NAME. LOOK FOR OMN1650 C POSSIBLE NAME QUALIFIER OR ARGUMENTS OR END OF CARD. OMN1660 C OMN1670 170 K=KARD(M) OMN1680 IF (K.LT.36) IF (K-10) 190,175,175 OMN1685 IF (K.EQ.40) GO TO 190 OMN1690 IF (K.EQ.46) GO TO 320 OMN1700 M=M+1 OMN1710 GO TO 170 OMN1720 C OMN1730 C A LETTER FOUND, ASSEMBLE SECOND NAME (COMMAND QUALIFIER). OMN1740 C OMN1750 175 CALL NNAME (NAME(3)) OMN1760 C OMN1770 C CHECK SPECIAL CASE OF NAMES M(XAX'), M(X'AX), M(XX'), M(X'X) OMN1780 C OMN1790 C SKIP ONE CHARACTER (') IF FIRST NAME =(M ) OMN1800 C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS OMN1810 C IS NAME(3) EQUAL TO TAP AND NAME(4)=E OMN1820 IF (NAME(3).NE.14623.OR.NAME(4).NE.3645) GO TO 180 OMN1830 CALL TAPOP OMN1840 GO TO 190 OMN1850 C ************************************************************* OMN1860 180 IF (NAME(1).EQ.9477) M=M+1 OMN1870 GO TO 190 OMN1880 C OMN1890 C SCAN FOR ARGUMENTS AND END OF CARD OMN1900 C OMN1910 185 M=3 OMN1920 190 J=J+1 OMN1930 GO TO 210 OMN1940 200 M=M+1 OMN1950 210 K=KARD(M) OMN1960 IF (K.GE.10) IF (K-40) 200,255,315 OMN1965 C OMN1970 C NUMBER FOUND, CONVERT ARGUMENT. IF KARG RETURNED = 0, NUMBER IS OMN1980 C INTEGER,IF KARG = 1, NUMBER IS FLOATING POINT, IF KARG = -1, ERROROMN1990 C OMN2000 CALL AARGS OMN2010 IF (KARG) 10,230,220 OMN2020 220 ARGTAB(J)=0. OMN2030 J=J+1 OMN2040 GO TO 240 OMN2050 C OMN2060 C ARGUMENT IS AN INTEGER. ADD A BIAS OF 8192 THEN CHECK THAT IT IS OMN2070 C .GT. 0 OMN2080 C OMN2090 230 ARG=ARG+8192. OMN2100 IF (ARG.GT.0.) GO TO 240 OMN2110 CALL ERROR (18) OMN2120 GO TO 10 OMN2130 240 ARGTAB(J)=ARG OMN2140 250 NARGS=NARGS+1 OMN2150 GO TO 190 OMN2160 C OMN2170 C ASTERISK FOUND, CONVERT OMN2180 C OMN2190 C IF BRACKETED BY SINGLE ASTERISKS, QUANTITY IS TO BE USED AS A OMN2200 C FLOATING POINT ARGUMENT.IF BRACKETED BY DOUBLE ASTERISKS, QUANTITYOMN2210 C IS TO BE TRUNCATED AND USED AS AN INTEGER ARGUMENT. OMN2220 C OMN2230 255 KARG=1 OMN2240 M=M+1 OMN2250 IF (KARD(M).NE.40) GO TO 260 OMN2260 KARG=0 OMN2270 M=M+1 OMN2280 260 MS=M OMN2290 CALL ASTER OMN2300 C OMN2310 C THE TERMINAL ASTERISK(S) HAVE BEEN CHECKED TO BE THE SAME AS THE OMN2320 C INITIAL SET (IF NO ERROR) AND M IS POINTING AT THE FIRST CHARACTEROMN2330 C AFTER THE LAST ASTERISK. OMN2340 C OMN2350 C KARG RETURNED AS 1 = ERROR FOUND OMN2360 C 2 = FLOATING POINT CONSTANT, Z.B. *PI* OMN2370 C 3 = INTEGER NAMED VARIABLE, Z.B. **NRMAX** OMN2380 C 4 = FL. PT. NAMED VARIABLE, Z.B. *NRMAX* OMN2390 C 5 = INTEGER ROW-COLUMN, Z.B. **3,40** OMN2400 C 6 = FL. PT. ROW-COLUMN, Z.B. *1,2* OMN2410 C 7 = STRING OF ASTERISKS Z.B. *** OMN2420 C OMN2430 C A STRING OF THREE OR MORE ASTERISKS IMPLIES -THRU- OMN2440 C EXAMPLE.. OMN2450 C ERASE 1 2 3 4 12 13 14 15 16 20 IS EQUIVALENT TO OMN2460 C ERASE 1 *** 4, 12 *** 16, 20 OMN2470 C OMN2480 C PRINT 1 20 19 18 17 16 15 13 IS EQUIVALENT TO OMN2490 C PRINT 1, 20 *** 14 OMN2500 C OMN2510 C OMN2520 GO TO (270,220,280,280,290,290,300), KARG OMN2530 270 M=MS OMN2540 GO TO 210 OMN2550 280 ARGTAB(J)=-2.*ARG-FLOAT(KARG-3) OMN2560 GO TO 250 OMN2570 290 ARGTAB(J)=-(ARG+8208.) OMN2580 ARG2=ARG2+8192. OMN2590 IF (KARG.EQ.6) ARG2=-ARG2 OMN2600 J=J+1 OMN2610 ARGTAB(J)=ARG2 OMN2620 GO TO 250 OMN2630 300 IF (J.GT.0) GO TO 310 OMN2640 CALL ERROR (211) OMN2650 GO TO 210 OMN2660 310 ARGTAB(J)=-1. OMN2670 GO TO 190 OMN2680 C OMN2690 C OMN2700 C ARGTAB SETUP OMN2710 C OMN2720 C IF ENTRY .GT. 0, IT IS AN INTEGER CONSTANT (Z.B. COLUMN NUMBER) OMN2730 C TO WHICH A BIAS OF 8192 HAS BEEN ADDED. THIS IS TO SAY THAT A OMN2740 C NEGATIVE INTEGER ARGUMENT MAY NOT BE EXPLICITLY GIVEN OR MODIFIED OMN2750 C TO BE LESS THAT -8191. OMN2760 C OMN2770 C IF ENTRY .EQ.0, THE NEXT ENTRY IS A FLOATING POINT CONSTANT. OMN2780 C OMN2790 C IF ENTRY .LT. 0, ARGUMENT IS A VARIABLE. SET SIGN POSITIVE AND. OMN2800 C OMN2810 C IF ENTRY .LT. 16, IT IS A NAMED VARIABLE REFERENCE NUMBER OMN2820 C OMN2830 C 2,3 NRMAX 6,7 V 10,11 X OMN2840 C IF 4,5 COLTOP 8.9 W 12,13 Y OMN2850 C 14,15 Z OMN2860 C OMN2870 C OMN2880 C V,W,X,Y,Z, ARE FOR PROGRAMMING CONVENIENCE ONLY AND DO NOTOMN2890 C AFFECT THE OPERATION OF OMNITAB OMN2900 C OMN2910 C IF ENTRY IS EVEN, CURRENT VALUE TO BE TRUNCATED AND USED OMN2920 C AS AN INTEGER ARGUEMENT. OMN2930 C IF ENTRY IS ODD. THE CURRENT VALUE IS TO BE USED AS A OMN2940 C FLOATING POINT ARGUMENT. OMN2950 C OMN2960 C IF ENTRY .GT. 16, IT IS A WORKSHEET REFERENCE (ROW,COLUMN) TO OMN2970 C WHICH A BAIS OF 8192. HAS BEEN ADDED. OMN2980 C ENTRY - 8208 = ROW NUMBER OMN2990 C ABS(NEXT ENTRY) = COLUMN NUMBER TO WHICH A BAIS OF 8192. OMN3000 C HAS BEEN ADDED. OMN3010 C OMN3020 C IF NEXT ENTRY IS NEGATIVE, WORKSHEET CONTENTS ARE TO BE OMN3030 C USED AS A FLOATING POINT CONSTANT. IF +, WORKSHEET VALUE OMN3040 C TO BE TRUNCATED AND USED AS AN INTEGER ARGUMENT. OMN3050 C OMN3060 C OMN3070 315 IF (K.NE.46) GO TO 200 OMN3080 C OMN3090 C THE TERMINATION OF CARD FOUND ( $ ENCOUNTERED) OMN3100 C OMN3110 320 IF (J.EQ.0) J=1 OMN3120 IF (MODE.NE.2.OR.NAME(1).NE.0) GO TO 350 OMN3130 C OMN3140 C IN INPUT MODE AND NO POSSIBLE NAME, RETURN TO SET OR READ ROUTINE OMN3150 C OMN3160 330 CALL EXPAND (J,ARGTAB) OMN3170 IF (ISRFLG.EQ.0) GO TO 340 OMN3180 CALL SETQ OMN3190 GO TO 10 OMN3200 340 CALL READQ OMN3210 GO TO 10 OMN3220 C OMN3230 C LOOK UP NAME (AND POSSIBLE QUALIFIER) IN DICTIONARY. RETURN OMN3240 C COORDINATES OF ENTRY. IF L1 = 0, NAME NOT FOUND OMN3250 C OMN3260 350 CALL LOOKUP OMN3270 IF (L1.NE.0) GO TO 360 OMN3280 IF (MODE.EQ.2) GO TO 330 OMN3290 CALL ERROR (1) OMN3300 GO TO 10 OMN3310 C OMN3320 C NAME FOUND OMN3330 C OMN3340 C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS OMN3350 C STATEMENT WAS 220 IF (MODE.EQ.2) MODE=1 OMN3360 360 IF (MODE.EQ.2) GO TO 370 OMN3370 C ******************************************************************OMN3380 IF (MODE.EQ.1) GO TO 380 OMN3390 CALL STORE (J) OMN3400 GO TO 10 OMN3410 C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS OMN3420 370 MODE=1 OMN3430 INUNIT=INUNIP OMN3440 C ******************************************************************OMN3450 380 CALL EXPAND (J,ARGTAB) OMN3460 CALL XECUTE OMN3470 GO TO 10 OMN3480 C OMN3490 390 FORMAT (1HZ,83X) OMN3500 400 FORMAT (1X,80A1) OMN3510 END OMN3520 SUBROUTINE ONEWAY ONE 10 C VERSION 5.00 ONEWAY 5/15/70 ONE 20 C ONE 30 C ******************************************************************ONE 40 C OMNITAB * ONEWAY STAT. ANALYSIS. ONE 50 C WRITTEN BY DAVID HAGBEN, SEL, NBS. 10/25/69. ONE 60 C ONEWAY ANALYSIS OF DATA IN ++ WITH TAG IN ++ STORE IN ++,++,... ONE 70 C TAG NUMBERS DIFFERENTIATE BETWEEN GROUPS ONE 80 C WHEN TAG IS NON-POSITIVE ZERO WEIGHT IS GIVEN TO MEASUREMENTS ONE 90 C NUMBER OF GROUPS MUST BE GREATER THAN 1 AND MUST NOT EXCEED NLNTH2ONE 100 C NRMAX MUST NOT EXCEED NLNTH1 ONE 110 C SLOPE IN ANOVA IS ONLY GIVEN IF FPROB FOR BETWEEN IS LESS THEN .10ONE 120 C ******************************************************************ONE 130 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NONE 140 1ARGS,VWXYZ(8),NERROR ONE 150 COMMON /BLOCRC/ NRC,RC(12600) ONE 160 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ONE 170 DIMENSION ARGS(100) ONE 180 EQUIVALENCE (ARGS(1),RC(12501)) ONE 190 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH ONE 200 COMMON /SCRAT/ NS,NS2,A(13500) ONE 210 COMMON /ABCDEF/ L(48) ONE 220 EQUIVALENCE (BLANK,L(45)), (SLO,L(22)), (HIGH,L(18)) ONE 230 C NLNTH1 = LENGTH OF ARRAYS = 2700, MUST BE CHANGED IF NS CHANGED ONE 240 C 5*NLNTH1 MUYST BE LE NS DIMENSION A3(NLNTH1) ONE 250 DIMENSION A2(2700), A3(2700), A4(2700), A5(2700) ONE 260 EQUIVALENCE (A2(1),A(2701)) ONE 270 EQUIVALENCE (A3(1),A(5401)), (A4(1),A(8101)), (A5(1),A(10801)) ONE 280 C NLNTH2 = LENGTH OF ARRAY = 540, MUST BE CHANGED IF NS CHANGED ONE 290 C 10*NLNTH2 LE NLNTH1 DIMENSION B1(NLNTH2) ONE 300 DIMENSION B1(540), B2(540), B3(540), B4(540), B5(540), B6(540), B7ONE 310 1(540), B8(540), B9(540), B10(540) ONE 320 EQUIVALENCE (B1(1),A(1)), (B2(1),A(541)), (B3(1),A(1081)), (B4(1),ONE 330 1A(1621)), (B5(1),A(2161)), (B6(1),A(2701)), (B7(1),A(3241)), (B8(1ONE 340 2),A(3781)), (B9(1),A(4321)), (B10(1),A(4861)) ONE 350 C ONE 360 C EXECUTE TIME CAN BE CONSIDERABLY SHORTENED USING LESS ACCURATE ONE 370 C VERSION OF FPPT. ONE 380 C ONE 390 C ******************************************************************ONE 400 C ONE 410 NLNTH1=NS/5 ONE 420 NLNTH2=NLNTH1/5 ONE 430 C ERROR CHECKING ONE 440 IF (NRMAX.GT.NLNTH1) GO TO 50 ONE 450 IF (NRMAX.EQ.0) CALL ERROR (9) ONE 460 IF (NARGS.EQ.6) GO TO 40 ONE 470 IF (NARGS.EQ.2.AND.L2.EQ.13) GO TO 40 ONE 480 IF (NARGS.EQ.2.AND.L2.EQ.14) GO TO 10 ONE 490 IF (NARGS.EQ.3) GO TO 20 ONE 500 CALL ERROR (10) ONE 510 RETURN ONE 520 10 CALL ERROR (236) ONE 530 RETURN ONE 540 20 DO 30 I=4,6 ONE 550 IARGS(I)=IARGS(3)+1 ONE 560 30 KIND(I)=0 ONE 570 NARGS=6 ONE 580 40 CALL CHKCOL (J) ONE 590 IF (J.EQ.0) GO TO 60 ONE 600 50 CALL ERROR (11) ONE 610 60 IF (NERROR.NE.0) GO TO 510 ONE 620 C MOVE Y AND TAG TO SCRATCH AREA MOVING TO BOTTOM IF TAG ONE 630 C NON-POSITIVE, CONVERT TAG TO INTEGER, COMPUTE NZW AND K, SET UP I ONE 640 M11=IARGS(1)-1 ONE 650 M12=IARGS(2)-1 ONE 660 K=0 ONE 670 NZW=0 ONE 680 DO 80 I=1,NRMAX ONE 690 M02=M11+I ONE 700 M03=M12+I ONE 710 IF (RC(M03).GE.1.0) GO TO 70 ONE 720 NZW=NZW+1 ONE 730 M01=NRMAX-NZW+1 ONE 740 A3(M01)=RC(M02) ONE 750 A4(M01)=0.0 ONE 760 GO TO 80 ONE 770 70 J=I-NZW ONE 780 A3(J)=RC(M02) ONE 790 A4(J)=AINT(RC(M03)+1.E-8) ONE 800 80 K=MAX0(K,INT(A4(J)+1.0E-6)) ONE 810 NZW=NRMAX-NZW ONE 820 IF (NZW.LE.K) GO TO 50 ONE 830 IF (K.LT.2) GO TO 50 ONE 840 IF (K.GT.NLNTH2) GO TO 50 ONE 850 M34=NZW+1 ONE 860 C COMPUTE NI,MEAN,S(R),SETUP MIN + MAX,IBAR, FOR I=1,K ONE 870 DO 90 I=1,NLNTH1 ONE 880 90 A(I)=0.0 ONE 890 CALL RANKO (NZW,A3(1),A2(1),A5(1),A(49)) ONE 900 A(49)=12.0*A(49) ONE 910 A(133)=NZW ONE 920 DO 100 I=1,NZW ONE 930 M40=A4(I) ONE 940 B2(M40)=B2(M40)+1.0 ONE 950 B3(M40)=B3(M40)+A3(I) ONE 960 B5(M40)=B5(M40)+A5(I) ONE 970 B6(M40)=A3(I) ONE 980 B7(M40)=A3(I) ONE 990 A(21)=A(21)+A3(I) ONE1000 100 A(101)=A(101)+A4(I) ONE1010 A(21)=A(21)/A(133) ONE1020 A(101)=A(101)/A(133) ONE1030 DO 110 I=1,K ONE1040 IF (B2(I).GT.0.0) B3(I)=B3(I)/B2(I) ONE1050 B8(I)=B3(I) ONE1060 C COMPUTE MIN,MAX,SD,S,SS,DF,MS,F,FPROB,S(1/NI),S(NI**3),S(R**2/NONE1070 110 B9(I)=B2(I) ONE1080 DO 120 I=1,NZW ONE1090 M40=A4(I)+.0001 ONE1100 B6(M40)=AMIN1(B6(M40),A3(I)) ONE1110 B7(M40)=AMAX1(B7(M40),A3(I)) ONE1120 B4(M40)=B4(M40)+(A3(I)-B3(M40))**2 ONE1130 A(1)=A(1)+(B3(M40)-A(21))**2 ONE1140 A(4)=A(4)+(A3(I)-B3(M40))**2 ONE1150 120 A(5)=A(5)+(A3(I)-A(21))**2 ONE1160 A(17)=0.0 ONE1170 A(22)=B3(1) ONE1180 A(23)=B3(1) ONE1190 A(24)=FSQRT(B4(1)) ONE1200 A(25)=0. ONE1210 A(26)=B6(1) ONE1220 A(27)=B7(1) ONE1230 A(48)=0.0 ONE1240 DO 150 I=1,K ONE1250 B10(I)=(B2(I)*(B2(I)-1.0))/B4(I) ONE1260 A(126)=A(126)+B10(I)*B3(I) ONE1270 A(127)=A(127)+B10(I) ONE1280 IF (B2(I)-1.) 150,140,130 ONE1290 130 B4(I)=FSQRT(B4(I)/(B2(I)-1.0)) ONE1300 A(121)=A(121)+(B2(I)-1.0)*FLOG(B4(I)*B4(I)) ONE1310 A(131)=A(131)+1. ONE1320 A(25)=AMAX1(A(25),B4(I)) ONE1330 A(24)=AMIN1(A(24),B4(I)) ONE1340 A(120)=A(120)+1.0/(B2(I)-1.0) ONE1350 140 A(2)=A(2)+B2(I)*(FLOAT(I)-A(101))*(B3(I)-A(21)) ONE1360 A(114)=A(114)+B2(I)*((FLOAT(I)-A(101))**2) ONE1370 A(22)=AMIN1(A(22),B3(I)) ONE1380 A(23)=AMAX1(A(23),B3(I)) ONE1390 A(26)=AMIN1(A(26),B6(I)) ONE1400 A(27)=AMAX1(A(27),B7(I)) ONE1410 A(17)=A(17)+B5(I)**2/B2(I) ONE1420 A(18)=A(18)+1./B2(I) ONE1430 A(48)=A(48)+(B3(I)-A(21))**2 ONE1440 A(122)=A(122)+B4(I)**2 ONE1450 A(129)=A(129)+B2(I)**2 ONE1460 150 A(118)=A(118)+B2(I)**3 ONE1470 A(126)=A(126)/A(127) ONE1480 A(2)=A(2)**2/A(114) ONE1490 A(3)=A(1)-A(2) ONE1500 C DEGREES OF FREEDOM FROM ANOVA ONE1510 M1=K-1 ONE1520 A(136)=FLOAT(M1) ONE1530 M2=1 ONE1540 M3=K-2 ONE1550 M4=NZW-K ONE1560 A(134)=FLOAT(M4) ONE1570 M5=NZW-1 ONE1580 C MEAN SQUARES ONE1590 A(6)=A(1)/A(136) ONE1600 A(7)=A(2)/FLOAT(M2) ONE1610 A(8)=A(3)/FLOAT(M3) ONE1620 A(9)=A(4)/FLOAT(M4) ONE1630 A(10)=A(5)/FLOAT(M5) ONE1640 A(11)=A(6)/A(9) ONE1650 A(12)=A(7)/((A(3)+A(4))/(A(133)-2.)) ONE1660 A(13)=A(8)/A(9) ONE1670 CALL PROB (A(136),FLOAT(M4),A(11),A(14)) ONE1680 CALL PROB (FLOAT(M2),FLOAT(M4),A(12),A(15)) ONE1690 CALL PROB (FLOAT(M3),FLOAT(NZW-2),A(13),A(16)) ONE1700 C COMPUTE FOR KRUSKAL-WALLIS TEST ONE1710 A(117)=NZW*(NZW+1) ONE1720 A(17)=(12.*A(17))/A(117)-3.*FLOAT(NZW+1) ONE1730 A(102)=1.0-A(49)/FLOAT(NZW**3-NZW) ONE1740 A(17)=A(17)/A(102) ONE1750 A(106)=(FLOAT(NZW**3)-A(118))/A(117) ONE1760 A(105)=FLOAT(2*M1)-.4*FLOAT(3*K*M3+NZW*(2*K*(K-3)+1))/A(117)-6.*A(ONE1770 118)/5. ONE1780 A(103)=A(136)*(A(136)*(A(106)-A(136))-A(105))/(.5*A(105)*A(106)) ONE1790 A(104)=(A(106)-A(136))*A(103)/A(136) ONE1800 A(19)=A(17)*(A(106)-A(136))/(A(136)*(A(106)-A(17))) ONE1810 CALL PROB (AINT(A(103)+.5),AINT(A(104)+.5),A(19),A(20)) ONE1820 C COMPUTE TOTAL STATISTICS ONE1830 A(31)=FSQRT(A(9)) ONE1840 A(32)=FSQRT(A(48)/A(136)) ONE1850 A(33)=FSQRT(A(10)) ONE1860 A(34)=A(31)/FSQRT(A(133)) ONE1870 A(35)=A(32)/FSQRT(FLOAT(K)) ONE1880 A(36)=A(33)/FSQRT(A(133)) ONE1890 CALL TPCTPT (FLOAT(M4),A(37)) ONE1900 CALL TPCTPT (A(136),A(38)) ONE1910 CALL TPCTPT (FLOAT(M5),A(39)) ONE1920 A(41)=A(21)-A(34)*A(37) ONE1930 A(42)=A(21)-A(35)*A(38) ONE1940 A(43)=A(21)-A(36)*A(39) ONE1950 A(44)=A(21)+A(34)*A(37) ONE1960 A(45)=A(21)+A(35)*A(38) ONE1970 A(46)=A(21)+A(36)*A(39) ONE1980 C SORT XBAR FOR MULTIPLE COMPARISIONS OF MEANS ONE1990 DO 160 I=1,M1 ONE2000 M37=K-I ONE2010 DO 160 J=1,M37 ONE2020 IF (B8(J).LE.B8(J+1)) GO TO 160 ONE2030 A(113)=B8(J) ONE2040 B8(J)=B8(J+1) ONE2050 B8(J+1)=A(113) ONE2060 A(113)=B9(J) ONE2070 B9(J)=B9(J+1) ONE2080 B9(J+1)=A(113) ONE2090 160 CONTINUE ONE2100 CALL FPPT (A(136),FLOAT(M4),.05,A(115)) ONE2110 A(116)=A(31)*FSQRT(A(136)*A(115)) ONE2120 C TESTS FOR HOMOGENEITY OF VARIANCES ONE2130 A(51)=(A(25)*A(25))/A(122) ONE2140 A(123) = AINT (A(133)/FLOAT(K)-0.5) ONE2150 CALL PROB (A(123),A(123)*(A(131)-1.),(A(131)-1.)*A(51)/(1.-A(51)),ONE2155 1 A(52)) ONE2160 A(52) = (A(131)-1.)*A(52) ONE2165 IF (A(52).GT.1.) A(52)=1.0 ONE2170 A(57)=(A(25)/A(24))**2 ONE2180 A(121)=A(134)*FLOG(A(9))-A(121) ONE2190 A(124)=(A(120)-1.0/A(134))/(3.*A(136)) ONE2200 A(125)=(A(131)+1.)/(A(124)*A(124)) ONE2210 A(53)=(A(125)*A(121))/((A(131)-1.0)*(A(125)/(1.0-A(124)+2.0/A(125)ONE2220 1)-A(121))) ONE2230 CALL PROB (A(131)-1.0,AINT(A(125)+.5),A(53),A(54)) ONE2240 A(130)=(A(133)-A(129)/A(133))/A(136) ONE2250 A(47)=(A(6)-A(9))/A(130) ONE2260 C COMPUTATIONS ARE NOW COMPLETE ************************************ONE2270 M0=L2-12 ONE2280 GO TO (170,480), M0 ONE2290 C AUTOMATIC PRINTING WHEN L2=13 ONE2300 C FORMAT STATEMENTS ONE2310 170 CALL PAGE (4) ONE2320 C PRINT ANOVA ONE2330 WRITE (IPRINT,520) ONE2340 WRITE (IPRINT,530) M1,A(1),A(6),A(11),A(14) ONE2350 IF (K.LT.3) GO TO 180 ONE2360 IF (A(14).GE..10) GO TO 180 ONE2370 WRITE (IPRINT,540) M2,A(2),A(7),A(12),A(15) ONE2380 WRITE (IPRINT,550) M3,A(3),A(8),A(13),A(16) ONE2390 180 WRITE (IPRINT,560) M4,A(4),A(9) ONE2400 WRITE (IPRINT,570) M5,A(5) ONE2410 C PRINT KRUSKAL-WALLIS TEST ONE2420 WRITE (IPRINT,580) A(17),A(20) ONE2430 C PRINT ESTIMATES ONE2440 WRITE (IPRINT,590) ONE2450 DO 220 I=1,K ONE2460 A(107)=BLANK ONE2470 A(108)=BLANK ONE2480 IF (B2(I)-1.0) 220,190,190 ONE2490 190 IF (B3(I).LE.A(22)) A(107)=SLO ONE2500 IF (B3(I).GE.A(23)) A(107)=HIGH ONE2510 IF (B4(I).LE.A(24)) A(108)=SLO ONE2520 IF (B4(I).GE.A(25)) A(108)=HIGH ONE2530 M8=B2(I) ONE2540 IF (M8-1) 220,200,210 ONE2550 200 WRITE (IPRINT,610) I,M8,B3(I),A(107),B6(I),B7(I),B5(I) ONE2560 GO TO 220 ONE2570 210 A(109)=B4(I)/FSQRT(B2(I)) ONE2580 CALL TPCTPT (FLOAT(M8-1),A(112)) ONE2590 A(110)=B3(I)-A(109)*A(112) ONE2600 A(111)=B3(I)+A(109)*A(112) ONE2610 WRITE (IPRINT,600) I,M8,B3(I),A(107),B4(I),A(108),A(109),B6(I),B7(ONE2620 1I),B5(I),A(110),A(111) ONE2630 220 CONTINUE ONE2640 WRITE (IPRINT,620) NZW,A(21),A(26),A(27),A(31),A(34),A(41),A(44),AONE2650 1(32),A(35),A(42),A(45),A(33),A(36),A(43),A(46) ONE2660 C COMPUTE AND PRINT FOR MULTIPLE COMPARISIONS ONE2670 IF (A(14)-0.10) 230,450,450 ONE2680 230 IF (M4.LT.4) GO TO 340 ONE2690 WRITE (IPRINT,630) ONE2700 C NEWMAN-KEULS-HARTLEY ONE2710 WRITE (IPRINT,640) ONE2720 J=1 ONE2730 M28=0 ONE2740 240 I=K ONE2750 250 IF (I-M28) 330,330,260 ONE2760 260 IF (I.EQ.J) GO TO 280 ONE2770 A(135)=ABS(B8(I)-B8(J)) ONE2780 C MANDEL APPROXIMATION TO PRECENT POINT OF STUDENTIZED RANGE ONE2790 A(137)=I-J+1 ONE2800 RX=-.283917+2.63532*(A(134)-1.00123)**(-.95862) ONE2810 U1=-.314115+2.38301*(A(134)-1.03428)**(-.864005) ONE2820 U2=3.65951*U1**2-1.00891*U1-0.166346 ONE2830 C=2.3849867-2.9051857*(A(137)-0.57583164)**(-.069648109) ONE2840 V1=1.30153-1.95073*(A(137)+.394915)**(-.139783) ONE2850 V2=4.72863*V1**2+0.404271*V1-0.135104 ONE2860 A(119)=6.15075+4.441409*RX+6.7514569*C+7.4671282*U1*V1-.157537*U2*ONE2870 1V2 ONE2880 A(119)=A(119)*FSQRT(.5*(1.0/B9(I)+1.0/B9(J)))*A(31) ONE2890 IF (A(135)-A(119)) 280,280,270 ONE2900 270 I=I-1 ONE2910 GO TO 250 ONE2920 280 IF (J.EQ.1) GO TO 310 ONE2930 IF (J-M28) 290,290,300 ONE2940 290 WRITE (IPRINT,670) ONE2950 GO TO 310 ONE2960 300 WRITE (IPRINT,680) ONE2970 310 WRITE (IPRINT,660) (B8(M29),M29=J,I) ONE2980 IF (I-K) 320,340,340 ONE2990 320 M28=I ONE3000 330 J=J+1 ONE3010 GO TO 240 ONE3020 C SCHEFFE METHOD ONE3030 340 WRITE (IPRINT,650) ONE3040 J=1 ONE3050 M28=0 ONE3060 350 I=K ONE3070 360 IF (I-M28) 440,440,370 ONE3080 370 IF (I.EQ.J) GO TO 390 ONE3090 A(135)=ABS(B8(I)-B8(J)) ONE3100 A(119)=A(116)*FSQRT(1.0/B9(I)+1.0/B9(J)) ONE3110 IF (A(135)-A(119)) 390,390,380 ONE3120 380 I=I-1 ONE3130 GO TO 360 ONE3140 390 IF (J.EQ.1) GO TO 420 ONE3150 IF (J-M28) 400,400,410 ONE3160 400 WRITE (IPRINT,670) ONE3170 GO TO 420 ONE3180 410 WRITE (IPRINT,680) ONE3190 420 WRITE (IPRINT,660) (B8(M29),M29=J,I) ONE3200 IF (I-K) 430,450,450 ONE3210 430 M28=I ONE3220 440 J=J+1 ONE3230 GO TO 350 ONE3240 450 IF (A(131).LT.2.0) GO TO 480 ONE3250 WRITE (IPRINT,690) A(51),A(52),A(53),A(54),A(57) ONE3260 IF (A(52).GT..10.AND.A(54).GT..10) GO TO 470 ONE3270 DO 460 I=1,K ONE3280 A(55)=A(55)+B10(I)*(B3(I)-A(126))**2 ONE3290 460 A(128)=A(128)+(1.-B10(I)/A(127))**2/(B2(I)-1.) ONE3300 A(128)=(FLOAT(K**2)-1.)/(3.*A(128)) ONE3310 A(55)=(A(55)/FLOAT(M1))/(1.+(2.*FLOAT(M3))/(3.*A(128))) ONE3320 CALL PROB (FLOAT(M1),AINT(A(128)+.5),A(55),A(56)) ONE3330 WRITE (IPRINT,700) A(55),A(56) ONE3340 470 WRITE (IPRINT,710) A(47) ONE3350 C AUTOMATIC PRINTOUT IS FINISHED - NOW STORE RESULTS ***************ONE3360 C ONE3370 480 IF (NARGS.EQ.2) GO TO 510 ONE3380 M13=IARGS(3) ONE3390 M14=IARGS(4) ONE3400 M15=IARGS(5) ONE3410 M16=IARGS(6) ONE3420 DO 500 I=1,K ONE3430 C DONT STORE IF N=0 ONE3440 IF (B2(I).LE.0.0) GO TO 490 ONE3450 C TAG ONE3460 RC(M13)=I ONE3470 C N ONE3480 RC(M14)=B2(I) ONE3490 C XBAR ONE3500 RC(M15)=B3(I) ONE3510 C STANDARD DEVIATION ONE3520 RC(M16)=B4(I) ONE3530 490 M13=M13+1 ONE3540 M14=M14+1 ONE3550 M15=M15+1 ONE3560 500 M16=M16+1 ONE3570 510 RETURN ONE3580 C ONE3590 C ONE3600 520 FORMAT (//,48X,20HANALYSIS OF VARIANCE//17X,6HSOURCE,14X,4HD.F.,4XONE3610 1,14HSUM OF SQUARES,5X,12HMEAN SQUARES,9X,7HF RATIO,4X,7HF PROB./) ONE3620 530 FORMAT (17X,14HBETWEEN GROUPS,5X,I4,1P2E18.6,4X,0PF11.3,F10.3) ONE3630 540 FORMAT (20X,5HSLOPE,14X,I4,1P2E18.6,3X0PF11.3,F10.3) ONE3640 550 FORMAT (20X,16HDEVS. ABOUT LINE,3X,I4,1P2E18.6,3X,0PF11.3,F10.3) ONE3650 560 FORMAT (17X,13HWITHIN GROUPS,6X,I4,1P2E18.6) ONE3660 570 FORMAT (17X,5HTOTAL,14X,I4,1PE18.6//) ONE3670 580 FORMAT (11X,65HKRUSKAL-WALLIS RANK TEST FOR DIFFERENCE BETWEEN GROONE3680 1UP MEANS * H = ,0PF9.3,10H, F PROB =,F6.3,10H (APPROX.)/) ONE3690 590 FORMAT (55X,9HESTIMATES//1X,5HGROUP,5X,3HNO.,6X,4HMEAN,7X,11HWITHIONE3700 1N S.D.,2X,12HS.D. OF MEAN,5X,7HMINIMUM,7X,7HMAXIMUM,6X,4HS(R),4X,2ONE3710 23H95HCT CONF INT FOR MEAN/) ONE3720 600 FORMAT (1X,I4,I8,1PE14.5,A1,E13.5,A1,E13.5,2E14.5,0PF9.1,1PE13.5,3ONE3730 1H TO,E12.5) ONE3740 610 FORMAT (1X,I4,I8,1PE14.5,A1,3X,24H ESTIMATE NOT AVAILABLE ,1P2E14.ONE3750 15,0PF9.1,3X,25H********** TO ***********) ONE3760 620 FORMAT (/,1X,5HTOTAL,I7,1PE14.5,28X,2E14.5/7X,20HFIXED EFFECTS MODONE3770 1EL ,2E14.5,37X,E13.5,3H TO,E12.5/7X,20HRANDOM EFFECTS MODEL, 2E14.ONE3780 25,37X,E13.5,3H TO,E12.5/7X,14HUNGROUPED DATA,6X,2E14.5,37X,E13.5,3ONE3790 3H TO,E12.5/) ONE3800 630 FORMAT (1X,120HPAIRWISE MULTIPLE COMPARISION OF MEANS. THE MEANS AONE3810 1RE PUT IN INCREASING ORDER IN GROUPS SEPARATED BY *****. A MEAN IONE3820 2S /120H ADJUDGED NON-SIGNIFICANTLY DIFFERENT FROM ANY MEAN IN THEONE3830 3 SAME GROUP AND SIGNIFICANTLY DIFFERENT AT THE .05 LEVEL FROM /120ONE3840 4H ANY MEAN IN ANOTHER GROUP. ***** ***** INDICATES ADJACENT GROUPONE3850 5S HAVE NO COMMON MEAN. ) ONE3860 640 FORMAT (/3X,89HNEWMAN-KEULS TECHNIQUE, HARTLEY MODIFICATION. (APPRONE3870 1OXIMATE IF GROUP NUMBERS ARE UNEQUAL.)) ONE3880 650 FORMAT (/3X,18HSCHEFFE TECHNIQUE.) ONE3890 660 FORMAT (3X,9(1PE12.5,1H,)) ONE3900 670 FORMAT (6X,5H*****) ONE3910 680 FORMAT (3X,11H***** *****) ONE3920 690 FORMAT (/,36H TESTS FOR HOMOGENEITY OF VARIANCES./7X,13HCOCHRAN,S ONE3930 1C =31H MAX. VARIANCE/SUM(VARIANCES) =,F6.4,5H, P =,F6.3,10H (APPROONE3940 2X.)/7X,16HBARTLETT-BOX F =,F9.3,5H, P =,F6.3/7X,37HMAXIMUM VARIANCONE3950 3E / MINIMUM VARIANCE =,F10.3) ONE3960 700 FORMAT (7X,70HAPPROX BETWEEN MEANS F-TEST IN PRESENCE OF HETEROGENONE3970 1EOUS VARIANCE. F =,F8.3,5H P =,F6.3) ONE3980 710 FORMAT (/,1X,35HMODEL II - COMPONENTS OF VARIANCE. /7X,29HESTIMATEONE3990 1 OF BETWEEN COMPONENT,1PE15.7) ONE4000 END ONE4010 SUBROUTINE OPONE (N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX) OPO 10 C VERSION 5.00 OPONE 5/15/70 OPO 20 C SUBROUTINE TO PRINT PAGE 1 OF POLYFIT AND FIT OPO 30 C ***** OPO 40 C WRITTEN BY DAVID HOGBEN, SEL. NBS. 10/14/69. OPO 50 COMMON/BLOCRC/NRC,RC(12600) OPO 60 COMMON/BLOCKE/NAME(4),L1,L2,ISRFLG OPO 70 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH OPO 80 COMMON/SCRAT/NS,NS2,A(13500) OPO 90 COMMON/KFMT/KFMT(100) OPO 100 COMMON/FMAT/IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) OPO 110 COMMON/BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, OPO 120 1NARGS,VWXYZ(8),NERROR OPO 130 DIMENSION ARGS(100),IIRGS(100) OPO 140 EQUIVALENCE (ARGS(1),RC(12501)),(IIRGS(1),KFMT(1)) OPO 150 DIMENSION B(1) OPO 160 C ***** OPO 170 C ***** OPO 180 C ***** OPO 190 C ***** OPO 200 IF (L2.EQ.1) GO TO 1620 OPO 210 IF (MX.GT.1) GO TO 1640 OPO 220 1620 WRITE (IPRINT,1625) (LHEAD(I1),I1=13,24),(LHEAD(I2),I2=1,12), OPO 230 1 IARGS(IX),IARGS(1) OPO 240 1625 FORMAT (//5X,2(4X,12A1,4X),6X,9HPREDICTED,8X,12HSTD. DEV. OF,25X, OPO 250 1 4HSTD./2X,3HROW,3X, 9HIN COLUMN,I5,6X, 9HIN COLUMN,I5,10X,6HVALUEOPO 260 2S,10X,12HPRED. VALUES,8X,9HRESIDUALS,8X,4HRES.,3X,7HWEIGHTS/) OPO 270 GO TO 1660 OPO 280 1640 IF (MX.GT.2) GO TO 1650 OPO 290 WRITE (IPRINT,1645) (LHEAD(I),I=1,12),IARGS(NX+4),IARGS(NX+5), OPO 300 1 IARGS(1) OPO 310 1645 FORMAT (//8X,22HPREDICTOR VARIABLES IN,6X,12A1,8X,9HPREDICTED,6X, OPO 320 1 12HSTD. DEV. OF,22X,4HSTD./2X,3HROW,3X,4HCOL.,I4,6X,4HCOL.,I4,8X,OPO 330 24HCOL.,I4,11X,6HVALUES,8X,12HPRED. VALUES,6X,9HRESIDUALS,7X,4HRES.OPO 340 3,3X,7HWEIGHTS/) OPO 350 GO TO 1660 OPO 360 1650 WRITE (IPRINT,1655) (LHEAD(I),I=1,12),IARGS(NX+4),IARGS(NX+5), OPO 370 1 IARGS(NX+6),IARGS(1) OPO 380 1655 FORMAT (//12X,22HPREDICTOR VARIABLES IN,9X,12A1,6X,9HPREDICTED,4X OPO 390 1,12HSTD. DEV. OF,19X,4HSTD./2X,3HROW,2X,3(4HCOL.,I4,4X),2X,4HCOL.,OPO 400 2I4,9X,6HVALUES,6X,12HPRED. VALUES,4X,9HRESIDUALS,6X,4HRES.,3X, OPO 410 37HWEIGHTS/) OPO 420 1660 IX = IIRGS(IX) OPO 430 IY = IIRGS(1) OPO 440 IND3 = ND3+1 OPO 450 IND2 = ND2+1 OPO 460 IND4 = ND19+1 OPO 470 LL = 0 OPO 480 NSD = 8 OPO 490 NWM = 18 OPO 500 IF (L2.EQ.1 .OR. MX.EQ.1) GO TO 1666 OPO 510 IX2 = IIRGS(NX+5) OPO 520 NWM = 2*(2/MX) OPO 530 LL = 4-NWM OPO 540 NSD = 4+NWM OPO 550 NWM = NWM+10 OPO 560 CALL RFORMT (RC(IX2),N,NSD,NW2,NDEC2,NWM,A(1),A(1),0,0) OPO 570 IF (MX.EQ.2) GO TO 1666 OPO 580 IX3 = IIRGS(NX+6) OPO 590 CALL RFORMT (RC(IX3),N,NSD,NW3,NDEC3,NWM,A(1),A(1),0,0) OPO 600 1666 CALL RFORMT (RC(IX ),N,NSD,NW1,NDEC1, NWM ,A(1),A(1),0,0) OPO 610 CALL RFORMT (RC(IY ),N, 8,NW4,NDEC4,18-LL,A(1),A(1),0,0) OPO 620 CALL RFORMT (A(IND3),N, 8,NW5,NDEC5,17-LL,A(1),A(1),0,0) OPO 630 CALL RFORMT (A(IND2),N, 8,NW6,NDEC6,17-LL,A(1),A(1),0,0) OPO 640 CALL RFORMT (A(IND4),N, 8,NW7,NDEC7,17-LL,A(1),A(1),0,0) OPO 650 IF (KIND(2).EQ.1) GO TO 1667 OPO 660 IW = IIRGS(2) OPO 670 CALL RFORMT (RC(IW),N,4,NW9,NDEC9,9,A(1),A(1),0,0) OPO 680 GO TO 1680 OPO 690 1667 CALL RFORMT (ARGS(2),1,4,NW9,NDEC9,9,A(1),A(1),0,0) OPO 700 CALL RFORMT (A(1),1,4,NW9,NDEC9,0,ARGS(2),B(98),11-NW9,1) OPO 710 WT=ARGS(2) OPO 715 1670 FORMAT (1X,I4,97A1,0PF7.2,11A1) OPO 720 1680 DO 1745 I=1,N OPO 730 CALL RFORMT (A(1),1,NSD,NW1,NDEC1,0,RC(IX ),B(1),NWM+2-NW1,1) OPO 740 IF (L2.EQ.1 .OR. MX.EQ.1) GO TO 1685 OPO 750 CALL RFORMT (A(1),1,NSD,NW2,NDEC2,0,RC(IX2),B(NWM+3),NWM+2-NW2,1) OPO 760 IX2 = IX2+1 OPO 770 IF (MX.EQ.2) GO TO 1685 OPO 780 CALL RFORMT (A(1),1,NSD,NW3,NDEC3,0,RC(IX3),B(25),12-NW3,1) OPO 790 IX3 = IX3+1 OPO 800 1685 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,RC(IY),B(4*LL+21),20-LL-NW4,1) OPO 810 CALL RFORMT (A(1),1,8,NW5,NDEC5,0,A(IND3),B(3*LL+41),19-LL-NW5,1) OPO 820 CALL RFORMT (A(1),1,8,NW6,NDEC6,0,A(IND2),B(2*LL+60),19-LL-NW6,1) OPO 830 CALL RFORMT (A(1),1,8,NW7,NDEC7,0,A(IND4),B(LL + 79),19-LL-NW7,1) OPO 840 IF (KIND(2).EQ.1) GO TO 1730 OPO 850 CALL RFORMT (A(1),1,4,NW9,NDEC9,0,RC(IW),B(98),11-NW9,1) OPO 860 WT=RC(IW) OPO 865 IW = IW+1 OPO 870 1730 IF(WT.GT.0.0) STDRES=A(IND4)/FSQRT(SSQ/WT-A(IND2)**2) OPO 875 IF(WT.LE.0.0) STDRES=0.0 OPO 880 WRITE (IPRINT,1670) I,(B(I1),I1=1,97),STDRES,(B(I1),I1=98,108) OPO 890 1740 IX = IX+1 OPO 900 IY = IY+1 OPO 910 IND3 = IND3+1 OPO 920 IND2 = IND2+1 OPO 930 1745 IND4 = IND4+1 OPO 940 RETURN OPO 950 END OPO 960 SUBROUTINE ORTPLT( ND19,ND2,N,SSQ,ND3,IB,IXA,IWS) ORP 10 C VERSION 5.00 ORTPLT 5/15/70 ORP 20 C THIS PROGRAM IS USED BY ORTHO TO GENERATE PLOTS ORP 30 C WRITTEN BY S PEAVY 10/11/69 ORP 40 DIMENSION IU(1), IB(1) ORP 50 EQUIVALENCE (IU,A) ORP 60 C ***** ORP 70 COMMON/BLOCKD/IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL, ORP 80 1NARGS,VWXYZ(8),NERROR ORP 90 COMMON/BLOCRC/NRC,RC(12600) ORP 100 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH ORP 110 COMMON/SCRAT/NS,NS2,A(13500) ORP 120 COMMON/FMAT/IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) ORP 130 DIMENSION ARGS(100) ORP 140 EQUIVALENCE (ARGS(1),RC(12501)) ORP 150 COMMON /ABCDEF/L(48) ORP 160 COMMON/CONSTS/PI,E,HALFPI,DEG,RAD,XALOG ORP 170 C ***** ORP 180 IW=IWS ORP 182 IWST=1 ORP 184 IF(KIND(2).EQ.0) GO TO 18310 ORP 186 IWST=2 ORP 187 WT=ARGS(2) ORP 188 18310 IND4 = ND19+1 ORP 190 IND2=ND2+1 ORP 200 NZW=N ORP 205 DO 18320 I=1,N ORP 210 GO TO (18312,18314),IWST ORP 211 18312 WT=RC(IW) ORP 212 IW=IW+1 ORP 213 18314 IF(WT.NE.0.0) GO TO 18316 ORP 214 IU (IND4)=27 ORP 215 NZW=NZW-1 ORP 216 GO TO 18318 ORP 218 18316 Z=A(IND4)/FSQRT(SSQ/WT-A(IND2)**2) ORP 220 IZ=Z /.3 ORP 230 IF (Z.GT.0.0.AND.AMOD(Z,.3).NE.0.0)IZ=IZ+1 ORP 240 IU(IND4)=IZ+13 ORP 250 IF(IU(IND4).LE.0) IU(IND4)=1 ORP 260 IF (IU(IND4).GT.26) IU(IND4)=26 ORP 270 18318 IND2=IND2+1 ORP 280 18320 IND4=IND4+1 ORP 290 IND3=ND3+1 ORP 300 YMAX=A(IND3) ORP 310 YMIN=A(IND3) ORP 320 DO 18340 I=2,N ORP 330 IND3=IND3+1 ORP 340 IF(YMIN.LE.A(IND3)) GO TO 18330 ORP 350 YMIN=A(IND3) ORP 360 GO TO 18340 ORP 370 18330 IF(YMAX.LE.A(IND3)) YMAX=A(IND3) ORP 380 18340 CONTINUE ORP 390 YMM=ABS (YMAX-YMIN)/50. ORP 400 YMX=FLOAT(N-1)/50. ORP 410 CALL PAGE(0) ORP 420 IPLOT=1 ORP 430 WRITE(IPRINT,18350) ORP 440 18350 FORMAT(15X,36HSTANDARDIZED RESIDUALS VS ROW NUMBER,22X, ORP 450 1 42HSTANDARDIZED RESIDUALS VS PREDICTED VALUES) ORP 460 18355 WRITE(IPRINT,18360) (L(39),I=1,88) ORP 470 18360 FORMAT(7X,2(1H+,9A1),1H+,4A1,1HX,4A1,2(1H+9A1),1H+,10X,2(1H+,9A1) ORP 480 1 ,1H+,4A1,1HX,4A1,2(1H+,9A1),1H+) ORP 490 YYPR=3.75 ORP 500 LINE=26 ORP 510 18390 DO 20050 I=1,5 ORP 520 DO 18400 IJI=1,102 ORP 530 18400 IB(IJI)=L(45) ORP 540 GO TO (18410,19000),IPLOT ORP 550 18410 IND3=ND3+1 ORP 560 IND4=ND19+1 ORP 570 DO 18430 IJI=1,N ORP 580 IF(IU(IND4).NE.LINE) GO TO 18420 ORP 590 IZ=FLOAT(IJI-1)/YMX +.5 ORP 600 IZ=IZ+1 ORP 610 IF(IZ.LE.0) IZ=1 ORP 620 IF(IZ.GT.51) IZ=51 ORP 630 IB(IZ)=L(41) ORP 640 IZ=(A(IND3)-YMIN)/YMM ORP 650 IZ=IZ+1 ORP 660 IF(IZ.LE.0) IZ=1 ORP 670 IF(IZ.GT.51) IZ=51 ORP 680 IB(IZ+51)=L(41) ORP 690 18420 IND4=IND4+1 ORP 700 18430 IND3=IND3+1 ORP 710 GO TO 20000 ORP 720 19000 IND4=ND19+1 ORP 730 IX=IXA ORP 740 DO 19010 IJI=1,N ORP 750 IF(IU(IND4).NE.LINE) GO TO 19005 ORP 760 IZ=(RC(IX)-XMIN)/XMM ORP 770 IZ=IZ+1 ORP 780 IF(IZ.LE.0) IZ=1 ORP 790 IF (IZ.GT.51) IZ=51 ORP 800 IB(IZ)=L(41) ORP 810 RATIO=(AN-GAMMA)/FDEN ORP 820 YMM=4.91*(RATIO**.14-(1.-RATIO)**.14) ORP 830 AN=AN-1.0 ORP 840 IF (AN.LT.2. .AND. NZW.LE.10) GAMMA = 1./3. ORP 850 IZ=YMM/.1 ORP 860 IZ=IZ+26 ORP 870 IF(IZ.LE.0) IZ=1 ORP 880 IF(IZ.GT.51) IZ=51 ORP 890 IB(IZ+51)=L(41) ORP 900 19005 IX=IX+1 ORP 910 19010 IND4=IND4+1 ORP 920 20000 IF(I-1) 20010,20010,20030 ORP 930 20010 WRITE (IPRINT,20020)YYPR,(IB(IJI),IJI=1,51),YYPR,(IB(IJI),IJI=52, ORP 940 1 102) ORP 950 20020 FORMAT(1X,F5.2,1H+51A1,1H+,3X,F5.2,1H+,51A1,1H+) ORP 960 GO TO 20045 ORP 970 20030 WRITE(IPRINT,20040) (IB(IJI),IJI=1,102) ORP 980 20040 FORMAT(6X,1H-,51A1,1H-,8X,1H-,51A1,1H-) ORP 990 20045 LINE=LINE-1 ORP1000 IF(LINE.EQ.0) GO TO 20060 ORP1010 20050 CONTINUE ORP1020 YYPR=YYPR-1.5 ORP1030 GO TO 18390 ORP1040 20060 WRITE(IPRINT,18360) (L(39),I=1,88) ORP1050 GO TO (20070,21100),IPLOT ORP1060 20070 YMM=YMX*25.0 +1.0 ORP1070 YMMY= (YMAX-YMIN)/2.+YMIN ORP1080 WRITE(IPRINT,20080) YMM,N,YMIN,YMMY,YMAX ORP1090 20080 FORMAT(6X,3H1.0,18X,F9.4,16X,I5,2H.0 ,1PE15.4,E26.4,10X,E10.4) ORP1100 WRITE (IPRINT,20090) ORP1110 20090 FORMAT (1H ) ORP1120 IPLOT=2 ORP1130 IX=IXA ORP1140 XMAX=RC(IX) ORP1150 XMIN=RC(IX) ORP1160 DO 21000 I=2,N ORP1170 IX=IX+1 ORP1180 IF(RC(IX).GT.XMAX) XMAX=RC(IX) ORP1190 IF(XMIN.GT.RC(IX)) XMIN=RC(IX) ORP1200 21000 CONTINUE ORP1210 XMM = ABS (XMAX-XMIN)/50. ORP1220 GAMMA=PI/8.0 ORP1230 AN=NZW ORP1245 FDEN=AN-2.*GAMMA+1.0 ORP1250 WRITE(IPRINT,21010) (LHEAD(I),I=13,24) ORP1270 21010 FORMAT(14X,26HSTANDARDIZED RESIDUALS VS ,12A1, 21X, ORP1280 1 42HPROBABILITY PLOT OF STANDARDIZED RESIDUALS) ORP1290 GO TO 18355 ORP1300 21100 YMMY=(XMAX-XMIN) /2.+XMIN ORP1310 WRITE(IPRINT,21110) XMIN,YMMY,XMAX ORP1320 21110 FORMAT(1PE13.4,14X, E12.4, 8X, E12.4,7X,4H-2.5,22X,3H0.0,22X, ORP1330 1 3H2.5) ORP1340 RETURN ORP1350 END ORP1360 SUBROUTINE ORTHO ORT 10 C VERSION 5.00 OTHRO 5/15/70 ORT 20 DOUBLE PRECISION FDSQRT,DK2,SUM,YSUM ORT 30 COMMON /ABCDEF/ L(48) ORT 40 COMMON /BLOCRC/ NRC,RC(12600) ORT 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NORT 60 1ARGS,VWXYZ(8),NERROR ORT 70 DIMENSION ARGS(100) ORT 80 EQUIVALENCE (ARGS(1),RC(12501)) ORT 90 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG ORT 100 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH ORT 110 COMMON /SCRAT/ NS,NS2,A(13500) ORT 120 COMMON /KFMT/ KFMT(100) ORT 130 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) ORT 140 DIMENSION IIRGS(100) ORT 150 EQUIVALENCE (IIRGS(1),KFMT(1)), (B(1),IB) ORT 160 DIMENSION IMTRXA(2,3) ORT 170 DIMENSION B(120), IHC(4), IHT(8) ORT 180 DATA IHC(1),IHC(2),IHC(3),IHC(4)/3H TE,3HRM ,3HCOL,3HUMN/ ORT 190 C *** ******* ******* ORT 200 C ORTHONORMALIZATION PROGRAM BY PHILIP J. WALSH JULY 1, 1967 ORT 210 C REVISED BY S. PEAVY 5/28/68 ORT 220 C REVISED BY DAVID HOGBEN AND SALLY PEAVY, SEL, NBS. 9/23/69. ORT 230 C LEAST SQUARES PROGRAM USING GRAM SCHMIDT PROCESS ORT 240 C ORT 250 C POLYFIT Y IN COL ++ WITH WEIGHTS (ALL EQAUL TO **) ORT 260 C (IN COL ++) ORT 270 C USING POLYNOMIAL OF DEGREE ,, TO X IN COL ++ ORT 280 C STORE: COEFFICIENTS IN COL ++ ORT 290 C DEVIATIONS IN COL ++ ORT 300 C STANDARD DEV OF PREDICTED VALUES IN COL++ ORT 310 C FOURIER COEFFICIENTS IN COL ++ ORT 320 C VARIANCE COVARIANCE MATRIX STARTING IN (,, ++) ORT 330 C ONLY FIRST 4 ARGUMENTS MUST BE SPECIFIED. ORT 340 C STORAGE WILL TAKE PLACE FOR ONLY THE STORAGE ARGUMENTS ORT 350 C PROVIDED ORT 360 C L2=1 POLYFIT: L2=2 SPOLYFIT ORT 370 C ORT 380 C FIT Y IN COL ++ WITH WEIGHTS(ALL EQUAL TO **) AS A ORT 390 C (IN COL ++) ORT 400 C FUNCTION OF K=++ VARIABLES IN COL ++,++,++,...,+++ ORT 410 C STORE: COEFFICIENTS IN COL ++ ORT 420 C DEVIATIONS IN COL ++ ORT 430 C STANDARD DEV OF PREDICTED VALUES IN COL ++ ORT 440 C FOURIER COEFFICIENTS, ETC. IN COL ++ ORT 450 C VARIANCE COVARIANCE MATRIX STARTING IN (++ ,,) ORT 460 C MINIMUM OF 4 ARGUMENTS IN NEEDED BEFORE COMMAND IS EXEC. ORT 470 C L2=3 FIR : L2=4 SFIT ORT 480 C ORT 490 C MORTHO X (,, ++) R=,, C=,, WITH WEIGHTS ( ALL EQUAL TO **) ORT 500 C ( IN COL ++) ORT 510 C STORE IN M (,, ++) A MATRIX IN (,, ++) ORT 520 C L2=5 MORTHO: ORT 530 C ORT 540 C ORT 550 IX1(I,J,IN)=IN+(I*(I-1))/2+J ORT 560 C PRECHECKING SECTION ORT 570 IF (L2.EQ.1.OR.L2.EQ.3) GO TO 8 ORT 582 IF (L2.EQ.2) IF (NARGS-4) 8,6,8 ORT 584 IF (NARGS.NE.IARGS(3)+3) GO TO 8 ORT 586 6 CALL ERROR (236) ORT 588 RETURN ORT 590 8 IREFIT=0 ORT 595 IF (NARGS.GT.0) GO TO 10 ORT 600 CALL ERROR (10) ORT 610 RETURN ORT 620 10 IF (NRMAX.NE.0) GO TO 20 ORT 630 CALL ERROR (9) ORT 640 RETURN ORT 650 20 NMUI=1 ORT 660 C IF L2 =5 THEN COMMAND IS MORTHO ORT 670 IF (L2.EQ.5) GO TO 1850 ORT 680 IF (NARGS.LT.4) GO TO 1830 ORT 690 C COMMAND IS POLYFIT OR FIT ORT 700 CALL ADRESS (1,IIRGS(1)) ORT 710 IF (IIRGS(1).LE.0) CALL ERROR (11) ORT 720 IF (KIND(2).EQ.1) GO TO 30 ORT 730 CALL ADRESS (2,IIRGS(2)) ORT 740 IF (IIRGS(2).LE.0) CALL ERROR (11) ORT 750 GO TO 40 ORT 760 30 SU=NRMAX ORT 770 WSUM=SU ORT 780 IF (ARGS(2).LE.0.0) CALL ERROR (24) ORT 790 NMUI=2 ORT 800 40 NST=1 ORT 810 IF(KIND(3).EQ.1) IARGS(3)=ARGS(3) ORT 815 NEND=NARGS ORT 820 J=NARGS-4 ORT 825 IF(L2.GT.2) J=J-IARGS(3)+1 ORT 830 IF(J.LE.4.AND.J.GE.0) GO TO 50 ORT 835 IF(J.NE.6) GO TO 1830 ORT 837 45 NEND=NARGS-2 ORT 840 NST=2 ORT 850 50 DO 60 I=4,NEND ORT 860 CALL ADRESS (I,IIRGS(I)) ORT 870 IF (IIRGS(I).LE.0) CALL ERROR (11) ORT 880 60 CONTINUE ORT 890 M=IARGS(3) ORT 900 IF (L2.LE.2) M=M+1 ORT 910 N=NRMAX ORT 920 FN=N ORT 930 GO TO (100,70), NST ORT 940 70 CALL ADRESS (NARGS,IST) ORT 950 IF (IST.GT.0) GO TO 80 ORT 960 CALL ERROR (11) ORT 970 RETURN ORT 980 80 MMTXR=M ORT 990 MMTXC=M ORT1000 IST=IST-1+IARGS(NARGS-1) ORT1010 IF (IARGS(NARGS)+M-1.GT.NCOL) MMTXC=NCOL-IARGS(NARGS)+1 ORT1020 IF (IARGS(NARGS-1)+M-1.GT.NROW) MMTXR=NROW-IARGS(NARGS-1)+1 ORT1030 IF (MMTXR.GT.0) GO TO 90 ORT1040 NARGS=NARGS-2 ORT1050 CALL ERROR (213) ORT1060 GO TO 100 ORT1070 90 IF (MMTXR.NE.M.OR.MMTXC.NE.M) CALL ERROR (213) ORT1080 100 GO TO (110,140), NMUI ORT1090 110 SU=0.0 ORT1100 WSUM=0.0 ORT1110 L22=IIRGS(2) ORT1120 L22A=L22 ORT1130 DO 130 I=1,N ORT1140 IF (RC(L22A)) 1840,130,120 ORT1150 120 SU=SU+1.0 ORT1160 WSUM=WSUM+RC(L22A) ORT1170 130 L22A=L22A+1 ORT1180 140 FM=M ORT1190 IF (SU-FM) 150,160,170 ORT1200 150 CALL ERROR (24) ORT1210 RETURN ORT1220 160 DENOM=1.0 ORT1230 GO TO 180 ORT1240 170 DENOM=FSQRT(SU-FM) ORT1250 180 NPM=N+M ORT1260 M1=M-1 ORT1270 M2=M+1 ORT1280 N1=N-1 ORT1290 N2=N+1 ORT1300 MD1=(M*(M2))/2 ORT1310 C ORT1320 C ORT1330 ND1=M2*NPM ORT1340 C X REQUIRES ND1 CELLS ORT1350 C GET A (ND1 + 1) FOR START OF PK ORT1360 ND2=M*NPM ORT1370 MD3=ND2+N ORT1380 ND3=ND1 ORT1390 C ADD NPM TO REACH XP ORT1400 ND4=ND3+NPM ORT1410 C ADD NPM TO REACH QK ORT1420 ND5=ND4+NPM ORT1430 C ADD (M+1) TO REACH CV ORT1440 ND6=ND5+M2 ORT1450 C ADD (M*(M+1))/2 + M TO REACH VCV ORT1460 ND66=MD1+M ORT1470 ND7=ND6+ND66 ORT1480 C ADD THE SAME AMOUNT TO REACH Q ORT1490 ND8=ND7+ND66 ORT1500 C Q IS (M+1) CELLS LONG THEN COMES Q2 ORT1510 ND9=ND8+M2 ORT1520 C Q2 ER AND EP ARE EACH M CELLS LONG ORT1530 ND10=ND9+M ORT1540 ND11=ND10+M ORT1550 ND12=ND11+M ORT1560 C THE A MATRIX IS NEXT ORT1570 ND13=ND12+MD1 ORT1580 C GRAM FACTOR STORAGE ORT1590 ND14=ND13+M2 ORT1600 C ENF ORT1610 C CV DIAGONALS ORT1620 ND16=ND14+M ORT1630 C VCV DIAGONALS ORT1640 ND17=ND16+M ORT1650 ND18=ND17+M ORT1660 ND19=ND18+NPM ORT1670 ND20=ND19+N ORT1680 IF (IREFIT.EQ.1) GO TO 190 ORT1690 IF (ND20.GT.NS) CALL ERROR (23) ORT1700 IF (NERROR.NE.0) RETURN ORT1710 190 NRBAR=1 ORT1720 I=IIRGS(1) ORT1730 L22A=L22 ORT1732 CONS3=RC(L22) ORT1733 IF(KIND(2).EQ.1) CONS3=ARGS(2) ORT1735 CONS1=RC(I) ORT1736 CONS2=RC(I) ORT1737 DO 195 I1=1,NRMAX ORT1738 IF(KIND(2).EQ.0) CONS3=RC(L22A) ORT1740 IF(CONS3) 192,192,191 ORT1741 191 CONS=RC(I) ORT1742 IF(CONS.LT.CONS1) CONS1=CONS ORT1743 IF(CONS.GT.CONS2) CONS2=CONS ORT1745 192 I=I+1 ORT1746 195 L22A=L22A+1 ORT1747 YCONS=(CONS2+CONS1)/2.0 ORT1748 GO TO (200,200,240,240,240), L2 ORT1750 C THIS IS POLYFIT ORT1760 200 L33=IIRGS(4) ORT1770 MXARGS=5 ORT1780 L33A=L33 ORT1790 K=NPM+1 ORT1800 DO 210 I=1,N ORT1810 A(I)=1.0 ORT1820 A(K)=RC(L33A) ORT1830 K=K+1 ORT1840 210 L33A=L33A+1 ORT1850 IF (M.EQ.2) GO TO 320 ORT1860 DO 230 K=2,M1 ORT1870 L33A=L33 ORT1880 K2=K*NPM+1 ORT1890 K1=K2-NPM ORT1900 DO 220 I=1,N ORT1910 A(K2)=A(K1)*RC(L33A) ORT1920 K2=K2+1 ORT1930 K1=K1+1 ORT1940 220 L33A=L33A+1 ORT1950 230 CONTINUE ORT1960 GO TO 320 ORT1970 240 I=4 ORT1980 C FIND OUT IF ALL X(I) = 1.0, IF SO SET NX=1 AND MX=M-1 ORT1990 L33=IIRGS(4) ORT2000 NX=1 ORT2010 DO 250 NW6=1,N ORT2020 IF (ABS(RC(L33)-1.0).LE.1.E-6) GO TO 250 ORT2030 NX=0 ORT2040 GO TO 260 ORT2050 250 L33=L33+1 ORT2060 260 MX=MAX0(1,M-NX) ORT2070 IF(NX.EQ.0.OR.L2.EQ.5) YCONS=0.0 ORT2075 MXARGS=M+4 ORT2080 L44=MXARGS-1 ORT2090 J=1 ORT2100 270 DO 310 I1=I,L44 ORT2150 K1=J ORT2160 L33=IIRGS(I1) ORT2170 K2=K1 ORT2180 DO 300 I2=1,N ORT2190 290 A(K2)=RC(L33) ORT2220 K2=K2+1 ORT2230 300 L33=L33+1 ORT2240 IJKLM=2 ORT2250 310 J=J+NPM ORT2260 C GENERATE IDENTITY MATRIX AUGMENTATION ORT2270 320 K1=N2 ORT2280 DO 340 K=1,M ORT2290 K2=K1 ORT2300 DO 330 I=1,M ORT2310 A(K2)=0. ORT2320 330 K2=K2+1 ORT2330 K2=K1+K-1 ORT2340 K1=K1+NPM ORT2350 340 A(K2)=1.0 ORT2360 C BEGIN THE G.S. PROCESS ORT2370 NBEI=1 ORT2380 NRHI=1 ORT2390 I18=1+ND13 ORT2400 NGAI=2 ORT2410 NSII=2 ORT2420 NDEI=1 ORT2430 NNUI=1 ORT2440 LZ1=1 ORT2450 LZ2=1 ORT2460 C K CONTROLS WHOLE LOOP ORT2470 K=1 ORT2480 350 NTHI=1 ORT2490 360 NALI=1 ORT2500 NOMI=1 ORT2510 NJ=ND3+N+1 ORT2520 DO 370 J=1,M ORT2530 A(NJ)=0. ORT2540 370 NJ=NJ+1 ORT2550 C BOX 6. ORT2560 380 KD1=(K-1)*NPM ORT2570 I1=ND3+1 ORT2580 I2=KD1+1 ORT2590 L22A=L22 ORT2600 DO 420 I=1,N ORT2610 GO TO (390,400), NMUI ORT2620 C PK(I) ORT2630 390 A(I1)=A(I2)*RC(L22A) ORT2640 L22A=L22A+1 ORT2650 GO TO 410 ORT2660 400 A(I1)=A(I2)*ARGS(2) ORT2670 410 I1=I1+1 ORT2680 420 I2=I2+1 ORT2690 GO TO (430,460), NOMI ORT2700 430 IA1=1 ORT2710 IA2=ND5+1 ORT2720 DO 450 I=1,K ORT2730 I2=IA1 ORT2740 SUM=0.0 ORT2750 J2=ND3+1 ORT2760 DO 440 J=1,NPM ORT2770 SUM=SUM+A(J2)*A(I2) ORT2780 I2=I2+1 ORT2790 440 J2=J2+1 ORT2800 C QK(I) ORT2810 A(IA2)=SUM ORT2820 IA1=IA1+NPM ORT2830 450 IA2=IA2+1 ORT2840 GO TO 490 ORT2850 460 DK2=0. ORT2860 I1=(K-1)*NPM+1 ORT2870 IND3=ND3+1 ORT2880 DO 470 I=1,NPM ORT2890 DK2=DK2+A(IND3)*A(I1) ORT2900 I1=I1+1 ORT2910 470 IND3=IND3+1 ORT2920 DK=FDSQRT(DK2) ORT2930 C GRAM FACTORS ORT2940 A(I18)=DK ORT2950 I18=I18+1 ORT2960 K1=(K-1)*NPM+1 ORT2970 DO 480 I=1,NPM ORT2980 A(K1)=A(K1)/DK ORT2990 480 K1=K1+1 ORT3000 NOMI=1 ORT3010 GO TO 380 ORT3020 C BOX8 ORT3030 490 GO TO (500,560), NDEI ORT3040 500 LZ1=-LZ1 ORT3050 IF (LZ1) 550,510,510 ORT3060 C BOX8A ORT3070 510 K1=K-1 ORT3080 IRUTH=ND5+1 ORT3090 DO 520 I=1,K1 ORT3100 A(IRUTH)=-A(IRUTH) ORT3110 520 IRUTH=IRUTH+1 ORT3120 IRUTH=K+ND5 ORT3130 A(IRUTH)=1.0 ORT3140 J2=ND4+1 ORT3150 DO 540 I=1,NPM ORT3160 SUM=0.0 ORT3170 J1=I ORT3180 J3=ND5+1 ORT3190 DO 530 J=1,K ORT3200 SUM=SUM+A(J1)*A(J3) ORT3210 J1=J1+NPM ORT3220 530 J3=J3+1 ORT3230 C XP(I) ORT3240 A(J2)=SUM ORT3250 540 J2=J2+1 ORT3260 GO TO 640 ORT3270 C BOX8B GET QK(I18) ORT3280 550 ISAL=I18+M2 ORT3290 IRUTH=ND5+K ORT3300 A(ISAL)=FSQRT(A(IRUTH)) ORT3310 GO TO 510 ORT3320 C NDE1 ORT3330 560 LZ2=-LZ2 ORT3340 IF (LZ2) 570,510,510 ORT3350 C GET E AMD OTHER VECTORS ORT3360 570 DO 580 I=1,M ORT3370 IND5=ND5+I ORT3380 IND9=ND9+I ORT3390 IND8=ND8+I ORT3400 A(IND8)=A(IND5) ORT3410 580 A(IND9)=A(IND5)*A(IND5) ORT3420 A(IND8+1)=A(IND5+1) ORT3430 A(ND10+1)=A(IND8+1)-A(ND9+1) ORT3440 IND10=ND10+1 ORT3450 IND9=ND9+1 ORT3460 DO 590 J=2,M ORT3470 IND10=IND10+1 ORT3480 IND9=IND9+1 ORT3490 590 A(IND10)=A(IND10-1)-A(IND9) ORT3500 FI=1.0 ORT3510 IND10=ND10 ORT3520 IND11=ND11 ORT3530 DO 635 I=1,M ORT3540 IND10=IND10+1 ORT3550 IND11=IND11+1 ORT3560 IF (FN-FI) 630,630,600 ORT3570 600 IF (A(IND10)) 610,620,620 ORT3580 610 A(IND11)=-FSQRT(ABS(A(IND10))/(FN-FI)) ORT3590 GO TO 635 ORT3600 620 A(IND11)=FSQRT(A(IND10)/(FN-FI)) ORT3610 GO TO 635 ORT3620 630 A(IND10)=-1.0 ORT3630 635 FI=FI+1.0 ORT3640 GO TO 510 ORT3650 C BOX9 ORT3660 640 GO TO (650,670,800), NTHI ORT3670 650 K1=(K-1)*NPM+1 ORT3680 IND4=ND4+1 ORT3690 DO 660 I=1,NPM ORT3700 A(K1)=A(IND4) ORT3710 K1=K1+1 ORT3720 660 IND4=IND4+1 ORT3730 GO TO 760 ORT3740 670 IND18=ND18+1 ORT3750 IND4=ND4+1 ORT3760 DO 680 I=1,N ORT3770 A(IND18)=A(IND4) ORT3780 IND18=IND18+1 ORT3790 680 IND4=IND4+1 ORT3800 NI=N+1 ORT3810 DO 690 I=1,M ORT3820 KK1=ND18+NI ORT3830 IND4=ND4+NI ORT3840 A(KK1)=-A(IND4) ORT3850 690 NI=NI+1 ORT3860 IND4=ND4 ORT3870 IND19=ND19 ORT3880 DO 700 I=1,N ORT3890 IND4=IND4+1 ORT3900 IND19=IND19+1 ORT3910 700 A(IND19)=A(IND4) ORT3920 IF (L2.EQ.5.OR.IREFIT.EQ.1) GO TO 750 ORT3930 IF (NARGS-MXARGS) 750,730,710 ORT3940 710 L66=IIRGS(MXARGS+1)-1 ORT3950 L66A=L66 ORT3960 IND4=ND4 ORT3970 DO 720 I=1,N ORT3980 L66A=L66A+1 ORT3990 IND4=IND4+1 ORT4000 720 RC(L66A)=A(IND4) ORT4010 730 L55=IIRGS(MXARGS) ORT4020 L55A=L55 ORT4030 NI=N+ND4+1 ORT4040 RC(L55A)=-A(NI)+YCONS ORT4050 IF (M.EQ.1) GO TO 750 ORT4060 DO 740 I=2,M ORT4070 NI=NI+1 ORT4080 L55A=L55A+1 ORT4090 740 RC(L55A)=-A(NI) ORT4100 750 NTHI=3 ORT4110 GO TO 650 ORT4120 C BOX10 ORT4130 760 GO TO (770,780), NALI ORT4140 770 NOMI=2 ORT4150 NALI=2 ORT4160 GO TO 380 ORT4170 780 IF (K-M) 790,830,830 ORT4180 790 K=K+1 ORT4190 GO TO 350 ORT4200 800 GO TO (810,820), NNUI ORT4210 810 NNUI=2 ORT4220 GO TO 920 ORT4230 820 SS=DK/DENOM ORT4240 SSQ=SS*SS ORT4250 GO TO 920 ORT4260 830 GO TO (840,800), NBEI ORT4270 C ***** ***** ****** ***** ******* ***** ORT4280 C GET THE A MATRIX ORT4290 840 K1=1 ORT4300 DO 860 I=1,M ORT4310 I1=I*N+(I-1)*M ORT4320 DO 850 J=1,I ORT4330 I2=J+I1 ORT4340 K2=K1+ND12 ORT4350 A(K2)=A(I2) ORT4360 850 K1=K1+1 ORT4370 860 CONTINUE ORT4380 C ORT4390 NDEI=2 ORT4400 NBEI=2 ORT4410 NTHI=2 ORT4420 K=K+1 ORT4430 GO TO (800,870), NGAI ORT4440 C GET CV MATRIC ORT4450 870 CONTINUE ORT4460 DO 890 IL=1,M ORT4470 LOC=IX1(IL,0,ND6)+1 ORT4480 DO 890 J=1,IL ORT4490 SUM=0. ORT4500 DO 880 KK=IL,M ORT4510 LOC1=IX1(KK,IL,ND12) ORT4520 LOC2=IX1(KK,J,ND12) ORT4530 880 SUM=SUM+A(LOC1)*A(LOC2) ORT4540 A(LOC)=SUM ORT4550 890 LOC=LOC+1 ORT4560 J1=3+ND6 ORT4570 J=ND16+2 ORT4580 A(ND16+1)=FSQRT(A(ND6+1)) ORT4590 IF (M.EQ.1) GO TO 910 ORT4600 DO 900 I=2,M ORT4610 C THE ARGUMENT IN THE FOLLOWING SQRT OCCASIONALLY IS NEGATIVORT4620 A(J)=FSQRT(A(J1)) ORT4630 J=J+1 ORT4640 900 J1=J1+I+1 ORT4650 910 NGAI=1 ORT4660 GO TO 800 ORT4670 920 GO TO (930,990), NRHI ORT4680 930 IF (NRBAR) 940,1030,940 ORT4690 940 NRBAR=NRBAR-1 ORT4700 NTHI=2 ORT4710 NRHI=2 ORT4720 L11=IIRGS(1)-1 ORT4730 L11A=L11+1 ORT4740 I1=ND2+1 ORT4750 DO 970 I=1,N ORT4760 IF (L2.NE.5) GO TO 960 ORT4770 GO TO (960,950), NMUI ORT4780 950 A(I1)=ARGS(2) ORT4790 GO TO 970 ORT4800 960 A(I1)=RC(L11A)-YCONS ORT4810 L11A=L11A+1 ORT4820 970 I1=I1+1 ORT4830 I1=MD3+1 ORT4840 DO 980 I=1,M ORT4850 A(I1)=0. ORT4860 980 I1=I1+1 ORT4870 GO TO 360 ORT4880 990 GO TO (930,1000), NSII ORT4890 C GET VCV AND DEV AND COEF ORT4900 1000 IND7=ND7+1 ORT4910 IND6=ND6+1 ORT4920 DO 1010 I=1,MD1 ORT4930 A(IND7)=SSQ*A(IND6) ORT4940 IND7=IND7+1 ORT4950 1010 IND6=IND6+1 ORT4960 IND16=ND16+1 ORT4970 IND17=ND17+1 ORT4980 DO 1020 I=1,M ORT4990 A(IND17)=SS*A(IND16) ORT5000 IND16=IND16+1 ORT5010 1020 IND17=IND17+1 ORT5020 GO TO 930 ORT5030 C THE CALCULATIONS ARE COMPLETED. NOW OUTPUT THE RESULTS ORT5040 1030 A(ND8+1)=A(ND8+1)+YCONS*FSQRT(WSUM) ORT5050 A(ND9+1)=A(ND8+1)**2 ORT5060 IND18=ND18+N+1 ORT5070 A(IND18)=A(IND18)+YCONS ORT5080 IF (IREFIT.EQ.1) GO TO 1640 ORT5090 IF (L2.EQ.5) GO TO 1960 ORT5100 IF (NARGS.LT.MXARGS) GO TO 1190 ORT5110 L55A=L55+M ORT5120 ISF=1 ORT5130 L55B=L55A+M-1 ORT5140 IF (L55B.LE.NROW+L55-1) GO TO 1040 ORT5150 IF (M.GE.NROW) GO TO 1190 ORT5160 ISF=2 ORT5170 L55B=L55+NROW-1 ORT5180 1040 IND17=ND17+1 ORT5190 DO 1050 I=L55A,L55B ORT5200 RC(I)=A(IND17) ORT5210 1050 IND17=IND17+1 ORT5220 GO TO (1060,1190), ISF ORT5230 1060 IMS=NROW-2*M ORT5240 IF (IMS.GT.6) IMS=6 ORT5250 GO TO (1180,1170,1160,1150,1140,1070), IMS ORT5260 1070 L11A=IIRGS(1) ORT5270 L22A=L22 ORT5280 YBAR=0.0 ORT5290 DO 1100 I=1,N ORT5300 GO TO (1080,1090), NMUI ORT5310 1080 YBAR=YBAR+RC(L22A)*RC(L11A) ORT5320 L22A=L22A+1 ORT5330 GO TO 1100 ORT5340 1090 YBAR=YBAR+RC(L11A) ORT5350 1100 L11A=L11A+1 ORT5360 YBAR=YBAR/WSUM ORT5370 L11A=IIRGS(1) ORT5380 L22A=L22 ORT5390 YYBAR=0. ORT5400 DO 1130 I=1,N ORT5410 GO TO (1110,1120), NMUI ORT5420 1110 YYBAR=RC(L22A)*(RC(L11A)-YBAR)**2+YYBAR ORT5430 L22A=L22A+1 ORT5440 GO TO 1130 ORT5450 1120 YYBAR=ARGS(2)*(RC(L11A)-YBAR)**2+YYBAR ORT5460 1130 L11A=L11A+1 ORT5470 R2=1.-SSQ*(SU-FM)/YYBAR ORT5480 IF (R2.LT.0.) R2=0.0 ORT5490 IF (R2.GT.1.0) R2=1.0 ORT5500 RC(L55B+6)=R2 ORT5510 1140 RC(L55B+5)=SSQ ORT5520 1150 RC(L55B+4)=SS ORT5530 1160 RC(L55B+3)=SU-FM ORT5540 1170 RC(L55B+2)=FM ORT5550 1180 RC(L55B+1)=SU ORT5560 C COMPUTE PREDICTED VALUES S.D. OF PREDICTED ORT5570 1190 IND2=ND2+1 ORT5580 IND3=ND3+1 ORT5590 IND4=ND19+1 ORT5600 IPIC=1 ORT5610 IY=IIRGS(1) ORT5620 YSUM=0.0 ORT5630 L22A=L22 ORT5640 DO 1230 I=1,N ORT5650 IP=IPIC ORT5660 SP=0.0 ORT5670 DO 1200 I1=1,M ORT5680 SP=SP+A(IP)**2 ORT5690 1200 IP=IP+NPM ORT5700 A(IND2)=FSQRT(SP)*SS ORT5710 IPIC=IPIC+1 ORT5720 IND2=IND2+1 ORT5730 A(IND3)=RC(IY)-A(IND4) ORT5740 IND3=IND3+1 ORT5750 IND4=IND4+1 ORT5760 GO TO (1210,1220), NMUI ORT5770 1210 YSUM=YSUM+RC(IY)**2*RC(L22A) ORT5780 L22A=L22A+1 ORT5790 GO TO 1230 ORT5800 1220 YSUM=YSUM+RC(IY)**2*ARGS(2) ORT5810 1230 IY=IY+1 ORT5820 C CHECK TO SEE IF RESULTS ARE TO BE PUT IN WORK SHEET ORT5830 IF (NARGS.LE.MXARGS+1) GO TO 1460 ORT5840 IF (NARGS-(MXARGS+3)) 1440,1390,1240 ORT5850 C STORE VARIANCE COVARIANCE MATRIX IN WORK SHEET ORT5860 1240 LSWT=0 ORT5870 IND7=ND7+1 ORT5880 1250 ISTR=IST ORT5890 ISTC=IST ORT5900 MSTOP=MIN0(MMTXC,MMTXR) ORT5910 DO 1270 I=1,MSTOP ORT5920 ISTRR=ISTR ORT5930 ISTCC=ISTC ORT5940 DO 1260 J=1,I ORT5950 RC(ISTRR)=A(IND7) ORT5960 RC(ISTCC)=A(IND7) ORT5970 IND7=IND7+1 ORT5980 ISTRR=ISTRR+NROW ORT5990 1260 ISTCC=ISTCC+1 ORT6000 ISTR=ISTR+1 ORT6010 1270 ISTC=ISTC+NROW ORT6020 IF (MMTXC.EQ.MMTXR) GO TO 1330 ORT6030 C VARIANCE COVARIANCE MATRIX IS STORED AS A RECTANGULAR MATRIX ORT6040 MSTP=MAX0(MMTXC,MMTXR)-MSTOP ORT6050 IF (MMTXC-MMTXR) 1280,1280,1290 ORT6060 1280 ICONA=NROW ORT6070 ICONB=1 ORT6080 ISTART=ISTR ORT6090 GO TO 1300 ORT6100 1290 ICONA=1 ORT6110 ICONB=NROW ORT6120 ISTART=ISTC ORT6130 1300 DO 1320 I=1,MSTP ORT6140 ISTRC=ISTART ORT6150 DO 1310 J=1,MSTOP ORT6160 RC(ISTRC)=A(IND7) ORT6170 IND7=IND7+1 ORT6180 1310 ISTRC=ISTRC+ICONA ORT6190 IND7=IND7+I ORT6200 1320 ISTART=ISTART+ICONB ORT6210 C STORE GRAM FACTORS, VECTOR NORMS AND GRAM DETERMINANTS ORT6220 1330 MSTOP=NROW-1-IARGS(NARGS-1)-M ORT6230 IF(MSTOP.LT.(-1)) GO TO 1380 ORT6240 IND13=ND13+1 ORT6250 IND14=ND14+1 ORT6260 GMDT=1.0 ORT6270 ISTR=IST+M ORT6280 DO 1370 I=1,MMTXC ORT6290 IF (MSTOP) 1360,1350,1340 ORT6300 1340 GMDT=GMDT*(A(IND13)/A(IND14))**2 ORT6310 RC(ISTR+2)=GMDT ORT6320 1350 RC(ISTR)=A(IND13) ORT6330 IND13=IND13+1 ORT6340 1360 RC(ISTR+1)=A(IND14) ORT6350 IND14=IND14+1 ORT6360 1370 ISTR=ISTR+NROW ORT6370 C STORE FOURIER COEFFICIENTS ORT6380 1380 IF (LSWT.EQ.1) RETURN ORT6390 1390 LST=IIRGS(MXARGS+3) ORT6400 IND9=ND9 ORT6410 DO 1400 I=1,M ORT6420 IND9=IND9+1 ORT6430 RC(LST)=A(IND9) ORT6440 1400 LST=LST+1 ORT6450 IF (NROW-(M+1)) 1440,1420,1410 ORT6460 1410 RC(LST+1)=YSUM ORT6470 1420 RC(LST)=(SU-FM)*SSQ ORT6480 LST=LST+2 ORT6490 IF (M+2.GE.NROW) GO TO 1440 ORT6500 LSTA=LST+M-1 ORT6510 IF (2*M+2.GT.NROW) LSTA=IIRGS(MXARGS+3)+NROW-1 ORT6520 IND8=ND8 ORT6530 DO 1430 I=LST,LSTA ORT6540 IND8=IND8+1 ORT6550 1430 RC(I)=A(IND8) ORT6560 C STORE S.D. OF PREDICTED VALUES ORT6570 1440 LSTOR=IIRGS(MXARGS+2) ORT6580 IPIC=1 ORT6590 IND2=ND2+1 ORT6600 DO 1450 I=1,N ORT6610 RC(LSTOR)=A(IND2) ORT6620 IND2=IND2+1 ORT6630 1450 LSTOR=LSTOR+1 ORT6640 C START PRINTING ORT6650 1460 GO TO (1480,1470,1480,1470,1470), L2 ORT6660 1470 RETURN ORT6670 1480 ITITLE=1 ORT6680 IF (L2.EQ.3) ITITLE=2 ORT6690 IPG=1 ORT6700 NSU=SU+.5E-5 ORT6710 CALL PREPAK (5,NW1,NW1,IARGS(1),LHEAD) ORT6720 IF (NW1.EQ.0) GO TO 1500 ORT6730 DO 1490 I=1,4 ORT6740 LHEAD(I)=L(45) ORT6750 1490 LHEAD(I+8)=L(45) ORT6760 LHEAD(5)=L(14) ORT6770 LHEAD(6)=L(11) ORT6780 LHEAD(7)=L(30) ORT6790 LHEAD(8)=L(11) ORT6800 1500 CALL PREPAK (5,NW1,NW1,IARGS(4),LHEAD(13)) ORT6810 IF (NW1.EQ.0) GO TO 1510 ORT6820 LHEAD(13)=L(45) ORT6830 LHEAD(14)=L(32) ORT6840 LHEAD(15)=L(11) ORT6850 LHEAD(16)=L(28) ORT6860 LHEAD(17)=L(19) ORT6870 LHEAD(18)=L(11) ORT6880 LHEAD(19)=L(12) ORT6890 LHEAD(20)=L(22) ORT6900 LHEAD(21)=L(15) ORT6910 LHEAD(22)=L(45) ORT6920 LHEAD(23)=L(34) ORT6930 LHEAD(24)=L(45) ORT6940 1510 CALL PAGE (4) ORT6950 WRITE (IPRINT,1990) (LHEAD(I),I=1,12),IARGS(1) ORT6960 GO TO (1520,1820), ITITLE ORT6970 C PRINT POLYFIT TITLE ORT6980 1520 WRITE (IPRINT,2000) IARGS(3),(LHEAD(I),I=13,24),IARGS(4) ORT6990 1530 GO TO (1540,1550), NMUI ORT7000 1540 NZW=NRMAX-NSU ORT7010 WRITE (IPRINT,2010) NSU,NZW,IARGS(2) ORT7020 GO TO 1560 ORT7030 1550 CALL RFORMT (ARGS(2),1,8,NW1,NDEC1,10,A(1),A(1),0,0) ORT7040 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ARGS(2),B(1),0,0) ORT7050 WRITE (IPRINT,2020) NSU,(B(I),I=1,10) ORT7060 1560 GO TO (1570,1580,1610,1650), IPG ORT7070 1570 IXA=4 ORT7080 IF (L2.EQ.3) IXA=IXA+(M-MX) ORT7090 IX=IXA ORT7100 CALL OPONE (N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX) ORT7110 IPG=2 ORT7120 1580 IF (NSU.GE.3) GO TO 1590 ORT7130 WRITE (IPRINT,2030) ORT7140 GO TO 1600 ORT7150 1590 CALL ORTPLT (ND19,ND2,N,SSQ,ND3,IB,IIRGS(IXA),IIRGS(2)) ORT7160 1600 IPG=3 ORT7170 GO TO 1510 ORT7180 1610 CALL OCOVAR (M,ND7,MD1,IHC,B,IHT) ORT7190 C PRINT ANALYSIS OF VARIANCE ORT7200 CALL OANOVA (YSUM,SU,ND9,FM,M,N,ND7,SSQ,IHC,NSU,B) ORT7210 GO TO 1660 ORT7220 C REFIT FOR M=M-1 ORT7240 1620 IREFIT=1 ORT7250 M=M-1 ORT7260 FM=M ORT7270 M1=M-1 ORT7280 M2=M+1 ORT7290 SSOLD=SS ORT7300 IND17=ND17+1 ORT7310 IND18S=ND18+N ORT7320 IND19=ND19+1 ORT7330 IND19S=ND19 ORT7340 DO 1630 J=1,M2 ORT7350 A(IND19)=A(IND17) ORT7360 IND19=IND19+1 ORT7370 1630 IND17=IND17+1 ORT7380 IF(M.EQ.0) GO TO 1640 ORT7390 GO TO 170 ORT7400 C BEGIN REFIT TO PREDICTED VALUES ORT7410 1640 M1=M ORT7420 C REFIT FOR M=M-1 COMPLETE-OUTPUT PAGE 3 ORT7430 IPG=4 ORT7440 M = M + 1 ORT7455 GO TO 1510 ORT7460 1650 CALL OCOEFF (M1,N,ND18,ND17,IND19S,IND18S,IHC,B,IND7S,NSU,SS,SSOLDORT7470 1,YSUM) ORT7480 RETURN ORT7490 1660 IW=IIRGS(2) ORT7500 IND2=ND2+1 ORT7510 IND3=ND3+1 ORT7520 IDPG=2*M+13 ORT7530 IFI=1 ORT7540 DO 1700 I=1,N ORT7550 GO TO (1670,1680), NMUI ORT7560 1670 A(IND2)=A(IND3)*RC(IW) ORT7570 IW=IW+1 ORT7580 GO TO 1690 ORT7590 1680 A(IND2)=A(IND3)*ARGS(2) ORT7600 1690 IND3=IND3+1 ORT7610 1700 IND2=IND2+1 ORT7620 IND5=ND5+1 ORT7630 DO 1720 J=1,M ORT7640 IF=IFI ORT7650 ASUM=0.0 ORT7660 IND2=ND2+1 ORT7670 DO 1710 I=1,N ORT7680 ASUM=A(IF)*A(IND2)+ASUM ORT7690 IND2=IND2+1 ORT7700 1710 IF=IF+1 ORT7710 A(IND5)=ASUM ORT7720 IFI=IFI+NPM ORT7730 1720 IND5=IND5+1 ORT7740 ADEV=0.0 ORT7750 IW=IIRGS(2) ORT7760 IFI=1 ORT7770 IND2=ND3+1 ORT7780 DO 1770 I=1,N ORT7790 IND5=ND5+1 ORT7800 IF=IFI ORT7810 ASUM=0.0 ORT7820 DO 1730 J=1,M ORT7830 ASUM=ASUM+A(IF)*A(IND5) ORT7840 IF=IF+NPM ORT7850 1730 IND5=IND5+1 ORT7860 DEV=A(IND2)-ASUM ORT7870 GO TO (1740,1750), NMUI ORT7880 1740 DEV=DEV**2*RC(IW) ORT7890 IW=IW+1 ORT7900 GO TO 1760 ORT7910 1750 DEV=DEV**2*ARGS(2) ORT7920 1760 ADEV=ADEV+DEV ORT7930 IND2=IND2+1 ORT7940 1770 IFI=IFI+1 ORT7950 IND18=ND18+1+N ORT7960 IM=ND12 ORT7970 IND7S=ND18+N-M ORT7980 IND7=IND7S+1 ORT7990 DO 1810 I=1,M ORT8000 IM=IM+I ORT8010 COEF=0.0 ORT8020 IS=IM ORT8030 IND5=ND5+I ORT8040 DO 1780 J=I,M ORT8050 COEF=COEF+A(IS)*A(IND5) ORT8060 IS=IS+J ORT8070 1780 IND5=IND5+1 ORT8080 DIF=A(IND18)-COEF ORT8090 IF (ABS(DIF).GT.0.0) GO TO 1790 ORT8100 C 8.0 EQUAL NUMBER OF DIGITS IN COMPUTER ORT8110 DIG=8.0 ORT8120 GO TO 1800 ORT8130 1790 DIG=-FLOG10(ABS(DIF))+FLOG10(ABS(COEF)) ORT8140 DIG=AMIN1(8.0,DIG) ORT8150 DIG=AMAX1(-8.0,DIG) ORT8160 1800 A(IND7)=DIG ORT8170 IND7=IND7+1 ORT8180 1810 IND18=IND18+1 ORT8190 C DELETE GRAM FACTORS, VECTOR NORMS, GRAM DETERMINAT ORT8200 GO TO 1620 ORT8210 C TITLE FOR PRINT ORT8220 1820 II=IARGS(3)+3 ORT8230 IBA=II ORT8233 IBC=L(44) ORT8235 IF(II.GT.11)II=11 ORT8237 IF(M.GT.1) GO TO 1823 ORT8240 WRITE (IPRINT,2050) M,IARGS(4) ORT8241 GO TO 1530 ORT8242 1823 IF(IBA.EQ.II) IBC=L(45) ORT8243 WRITE (IPRINT,2050) M,IARGS(4),(L(44),IARGS(I),I=5,II),IBC ORT8244 DO 1827 J=1,4 ORT8245 IF(M.LE.24*(J-1)+8) GO TO 1530 ORT8246 II=24*J+11 ORT8247 III = II-23 ORT8248 II=MIN0(II,IARGS(3)+3) ORT8249 IF(II.NE.III) GO TO 1825 ORT8250 WRITE (IPRINT,2060) IARGS(II) ORT8252 GO TO 1530 ORT8254 1825 III=III+1 ORT8256 IF(II.EQ.IBA) IBC=L(45) ORT8257 1827 WRITE (IPRINT,2060) IARGS(III-1),(L(44),IARGS(I),I=III,II),IBC ORT8258 GO TO 1530 ORT8260 1830 CALL ERROR (10) ORT8270 RETURN ORT8280 1840 CALL ERROR (25) ORT8290 RETURN ORT8300 C MORTHO CHECK ORT8310 1850 IF (NARGS.EQ.7.OR.NARGS.EQ.9) GO TO 1860 ORT8320 CALL ERROR (10) ORT8330 RETURN ORT8340 1860 IF (IARGS(3).GE.IARGS(4)) GO TO 1870 ORT8350 CALL ERROR (26) ORT8360 RETURN ORT8370 1870 CALL ADRESS (2,IXM) ORT8380 IF (IXM.LE.0) CALL ERROR (11) ORT8390 IF (IARGS(1)+IARGS(3)-1.GT.NROW) CALL ERROR (17) ORT8400 IF (IARGS(2)+IARGS(4)-1.GT.NCOL) CALL ERROR (17) ORT8410 IXM=IXM-1+IARGS(1) ORT8420 IF (NERROR.GT.0) RETURN ORT8430 J=7 ORT8440 JJ=1 ORT8450 1880 CALL ADRESS (J,IMTRXA(JJ,1)) ORT8460 IF (IMTRXA(JJ,1).GT.0) GO TO 1900 ORT8470 1890 CALL ERROR (11) ORT8480 RETURN ORT8490 1900 IMTRXA(JJ,2)=IARGS(3) ORT8500 IF (JJ.EQ.2) IMTRXA(JJ,2)=IARGS(4) ORT8510 IMTRXA(JJ,3)=IARGS(4) ORT8520 IF (IARGS(J-1).GT.NROW) GO TO 1890 ORT8530 IMTRXA(JJ,1)=IMTRXA(JJ,1)-1+IARGS(J-1) ORT8540 IF (IARGS(J)+IARGS(4)-1.GT.NCOL) IMTRXA(JJ,3)=NCOL-IARGS(J)+1 ORT8550 IF (IARGS(J-1)+IARGS(3)-1.GT.NROW) IMTRXA(JJ,2)=NROW-IARGS(J-1)+1 ORT8560 IF (JJ.EQ.2.OR.NARGS.EQ.7) GO TO 1910 ORT8570 J=9 ORT8580 JJ=2 ORT8590 GO TO 1880 ORT8600 1910 IF (NERROR.NE.0) RETURN ORT8610 IF (IMTRXA(1,2).NE.IARGS(3).OR.IMTRXA(1,3).NE.IARGS(4)) CALL ERRORORT8620 1 (213) ORT8630 IF (NARGS.EQ.7) GO TO 1920 ORT8640 IF (IMTRXA(2,2).NE.IARGS(4).OR.IMTRXA(2,3).NE.IARGS(4)) CALL ERRORORT8650 1 (213) ORT8660 1920 IF (KIND(5).EQ.1) GO TO 1930 ORT8670 CALL ADRESS (5,IIRGS(2)) ORT8680 IIRGS(1)=IIRGS(2) ORT8690 IF (IIRGS(2).GT.0) GO TO 1940 ORT8700 CALL ERROR (11) ORT8710 RETURN ORT8720 1930 SU=IARGS(3) ORT8730 IF (ARGS(5).LE.0.0) CALL ERROR (25) ORT8740 NMUI=2 ORT8750 KIND(2)=1 ORT8760 ARGS(2)=ARGS(5) ORT8770 1940 M=IARGS(4) ORT8780 DO 1950 I=1,M ORT8790 1950 IIRGS(I+3)=IXM+(I-1)*NROW ORT8800 N=IARGS(3) ORT8810 FN=N ORT8820 GO TO 100 ORT8830 C START STORING RESULTS FOR MORTHO ORT8840 1960 IST=IMTRXA(1,1) ORT8850 K=1 ORT8860 MMTXC=IMTRXA(1,3) ORT8870 MMTXR=IMTRXA(1,2) ORT8880 DO 1980 I=1,MMTXC ORT8890 KK=K ORT8900 ISTRR=IST ORT8910 DO 1970 J=1,MMTXR ORT8920 RC(ISTRR)=A(KK) ORT8930 KK=KK+1 ORT8940 1970 ISTRR=ISTRR+1 ORT8950 K=K+NPM ORT8960 1980 IST=IST+NROW ORT8970 IF (NARGS.EQ.7) RETURN ORT8980 LSWT=1 ORT8990 IND7=ND12+1 ORT9000 IST=IMTRXA(2,1) ORT9010 MMTXR=IMTRXA(2,2) ORT9020 MMTXC=IMTRXA(2,3) ORT9030 GO TO 1250 ORT9040 C ORT9050 1990 FORMAT (/35X,22HLEAST SQUARES FIT FOR ,12A1,11H IN COLUMN ,I4) ORT9060 2000 FORMAT (25X,26HAS A POLYNOMIAL OF DEGREE ,I2,4H IN ,12A1,11H IN COORT9070 1LUMN ,I4) ORT9080 2010 FORMAT (20X,6HUSING ,I4,22H NON-ZERO WEIGHTS AND ,I4,24H ZERO WEIGORT9090 1HTS IN COLUMN ,I4) ORT9100 2020 FORMAT (35X,6HUSING ,I4,19H NON-ZERO WEIGHTS =,10A1) ORT9110 2030 FORMAT (60H0 PLOTS ARE NOT PRINTED BECAUSE NO. OF POINTS IS LESS TORT9120 1HAN 3) ORT9130 2050 FORMAT (23X,24HAS A LINEAR FUNCTION OF ,I2,31H PREDICTOR VARIABLESORT9140 1 IN COLUMNS,I4,8(A1,I4)) ORT9150 2060 FORMAT (I4,24(A1,I4)) ORT9160 END ORT9170 SUBROUTINE ORTHRV (A,NROW,N,NCOL,IND,X,NASIZE,XP) ORV 10 C VERSION 5.00 ORTHRV 5/15/70 ORV 20 C SUBROUTINE ORTHRV(A,NROW,N,NCOL,IND,X,NASIZE,XP) ORV 30 C SUBROUTINE TO CHECK TO SEE IF MATRIX IS ORTHOGONAL ORV 40 DIMENSION A(NROW,1), X(1), IND(1) ORV 50 DOUBLE PRECISION XP(1) ORV 60 C IF NUMBER OR ROWS IS GREATER THAN NUMBER OF COLUMNS COMPUTE A'A ORV 70 C OTHERWISE AA' ORV 80 IF (N.GT.NCOL) GO TO 10 ORV 90 L2P=1 ORV 100 MP=N ORV 110 GO TO 20 ORV 120 10 L2P=2 ORV 130 MP=NCOL ORV 140 20 CALL MXTXP (A,NROW,N,NCOL,X,L2P,NASIZE,XP) ORV 150 IC=1 ORV 160 IND(1)=0 ORV 170 IND(2)=0 ORV 180 DO 80 I=1,MP ORV 190 DO 80 J=1,MP ORV 200 IF (I.EQ.J) GO TO 40 ORV 210 IF (X(IC)) 30,80,30 ORV 220 30 IF (ABS(X(IC))-1.E-7) 60,60,90 ORV 230 40 IF (X(IC)-1.0) 50,80,50 ORV 240 50 IF (ABS(X(IC)-1.0)-1.E-7) 60,60,70 ORV 250 60 IND(2)=1 ORV 260 GO TO 80 ORV 270 70 IND(1)=2 ORV 280 80 IC=IC+1 ORV 290 GO TO 100 ORV 300 90 IND(1)=2 ORV 310 IND(2)=2 ORV 320 GO TO 150 ORV 330 100 IF (IND(1).EQ.0.AND.IND(2).EQ.1) IND(1)=1 ORV 340 IF (N.EQ.NCOL) GO TO 150 ORV 350 C SET UP INDICATORS FOR RECTANGULAR MATRICES ORV 360 GO TO (110,130), L2P ORV 370 110 IF (IND(1).EQ.1) GO TO 120 ORV 380 IND(1)=3 ORV 390 IND(2)=3 ORV 400 GO TO 150 ORV 410 120 IND(1)=-3 ORV 420 IND(2)=-3 ORV 430 GO TO 150 ORV 440 130 IF (IND(1).EQ.1) GO TO 140 ORV 450 IND(1)=4 ORV 460 IND(2)=4 ORV 470 GO TO 150 ORV 480 C * ORV 490 C IND(1)=0 EXACT ORTHOGONAL ORV 500 C IND(1)=1 RELATIVE (1.E-7) ORTHOGONAL ORV 510 C IND(1)=2 NON-ORTHOGONAL ORV 520 C INDICATORS FOR RECTANGULAR MATRICES ORV 530 C IND(1)=-3 RELATIVE ORTHOGONAL ROWWISE ORV 540 C IND(1)=3 EXACT ORTHOGONAL ROWWISE ORV 550 C IND(1)=-4 RELATIVE ORTHOGONAL COLUMNWISE ORV 560 C IND(1)=4 EXACT ORTHOGONAL COLUMNWISE ORV 570 C IND(2)=-1 DIAGONAL TERMS ARE 1.0 SE ORV 580 C IND(2)=0 EXACT ORTHOGONAL NORMALIZED ORV 590 C IND(2)=1 RELATIVE ORTHOGONAL NORMALIZED ORV 600 C IND(2)=2 NON-ORTHOGONAL ORV 610 C IND(2)=-3 RELATIVE ROWWISE (NORMALIZED) ORV 620 C IND(2)=3 EXACT ROWWISE (NORMALIZED) ORV 630 C IND(2)=-4 RELATIVE COLUMNWISE (NORMALIZED) ORV 640 C IND(2)=4 EXACT COLUMNWISE (NORMALIZED) ORV 650 C * ORV 660 C * ORV 670 140 IND(1)=-4 ORV 680 IND(2)=-4 ORV 690 150 RETURN ORV 700 END ORV 710 SUBROUTINE OUTPUT OUT 10 C VERSION 5.00 OUTPUT 5/15/70 OUT 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND OUT 30 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) OUT 40 COMMON /BLOCRC/ NRC,RC(12600) OUT 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NOUT 60 1ARGS,VWXYZ(8),NERROR OUT 70 DIMENSION ARGS(100) OUT 80 EQUIVALENCE (ARGS(1),RC(12501)) OUT 90 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST OUT 100 C OUT 110 C WRITE RECORD ON SCRATCH UNIT OUT 120 C OUT 130 IF (NERROR.EQ.0.AND.LLIST.EQ.0) GO TO 10 OUT 140 IF (MODE.EQ.3) GO TO 20 OUT 150 WRITE (ISCRAT,30) NEWCD OUT 160 10 RETURN OUT 170 20 I=NSTMT/10 OUT 180 WRITE (ISCRAT,40) I,NEWCD OUT 190 GO TO 10 OUT 200 C OUT 210 30 FORMAT (4X,80A1) OUT 220 40 FORMAT (1H+,I3,80A1) OUT 230 END OUT 240 SUBROUTINE PACK (NWORD,MWORD,NO,IP) PAC 10 C VERSION 5.00 PACK 5/15/70 PAC 20 C WRITTEN BY S PEAVY 9/17/69 PAC 30 C NWORD CONTAINS CHARACTERS TO BE PACKED OR UNPACKED PAC 40 C MWORD THE PACKED CHARACTERS IN CODED FORM (SEE BELOW) OR THE PAC 50 C UNPACKED CHARACTERS PAC 60 C NO NO OF CHARACTERS TO BE PACKED OR UNPACKED PAC 70 C IP IP=0 PACK PAC 80 C IP IP=1 UNPACK PAC 90 C PAC 100 C THE CHARACTERS ARE PACKED IN A CODED FORM. EACH CHARACTER HAS BEENPAC 110 C ASSIGNED A VALUE IN OMCONV. THIS VALUE IS 1 LESS THAN THE PAC 120 C SUBSCRIPT OF L (IN LABELED COMMON ABCDEF) FOR THAT PARTICULAR PAC 130 C CHARACTER. THESE VALUES ARE STORED IN KARD. THE VALUES OF THE PAC 140 C CHARACTERS ARE PACKED AS FOLLOWS PAC 150 C MWORD(I)=(KARD(K)+1)*2**16+(KARD(K-1)+1)*2**8+KARD(K-2)+1PAC 160 C PAC 170 COMMON /ABCDEF/ L(48) PAC 180 DIMENSION NWORD(1), MWORD(1) PAC 190 KB=1 PAC 200 KA=1 PAC 210 IF (IP.EQ.1) GO TO 30 PAC 220 C PACK PAC 230 10 MWORD(KA)=0 PAC 240 DO 20 I=1,3 PAC 250 MWORD(KA)=MWORD(KA)*256+NWORD(KB)+1 PAC 260 KB=KB+1 PAC 270 IF(KB.GT.NO) GO TO 22 PAC 280 20 CONTINUE PAC 290 KA=KA+1 PAC 300 GO TO 10 PAC 310 22 ICE=MOD(NO,3) PAC 311 IF(ICE.EQ.0) RETURN PAC 312 ICE=3-ICE PAC 313 24 MWORD(KA)=MWORD(KA)*256+45 PAC 314 ICE=ICE-1 PAC 315 IF (ICE.EQ.0) RETURN PAC 316 GO TO 24 PAC 317 C UNPACK PAC 320 30 ICA=NWORD(KB) PAC 330 ICD=65536 PAC 340 DO 40 I=1,3 PAC 350 ICB=ICA/ICD PAC 360 IF (ICB.EQ.0) GO TO 40 PAC 370 MWORD(KA)=L(ICB) PAC 380 KA=KA+1 PAC 390 IF (KA.GT.NO) RETURN PAC 400 ICA=ICA-ICB*ICD PAC 410 40 ICD=ICD/256 PAC 420 KB=KB+1 PAC 430 GO TO 30 PAC 440 END PAC 450 SUBROUTINE PAGE (J) PAG 10 C VERSION 5.00 PAGE 5/15/70 PAG 20 C PAG 30 C BRING UP A NEW PAGE AND PRINT OMNITAB CARD AND PAGE NUMBER PAG 40 C THEN, IF J = 0, DONE PAG 50 C J = 1, PRINT TITLE1 PAG 60 C J = 2, PRINT TITLE1, 2 PAG 70 C ETC. FOR J = 3, 4 PAG 80 C THIS ROUTINE ASSUMES THAT THE EXECUTIVE SYSTEM LEAVES PAG 90 C THE PRINTER FORM AT THE TOP OF THE FIRST BLANK PAGE PAG 100 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH PAG 110 NPAGE=NPAGE+1 PAG 150 WRITE (IPRINT,20) NOCARD,NPAGE PAG 160 IF (J.LE.0.OR.J.GT.4) GO TO 10 PAG 180 WRITE (IPRINT,30) ((ITLE(I,II),I=1,60),II=1,J) PAG 190 10 RETURN PAG 200 C PAG 210 20 FORMAT (1H1,19X,80A1,10X,4HPAGE,I4) PAG 220 30 FORMAT (1X,120A1/1X,120A1) PAG 230 END PAG 240 SUBROUTINE PDMOTE PDM 10 C VERSION 5.00 PDMOTE 5/15/70 PDM 20 COMMON /BLOCRC/ NRC,RC(12600) PDM 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NPDM 40 1ARGS,VWXYZ(8),NERROR PDM 50 DIMENSION ARGS(100) PDM 60 EQUIVALENCE (ARGS(1),RC(12501)) PDM 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG PDM 80 L2=L2-10 PDM 90 C PDM 100 C L2 : 0 FOR PROMOTE, 1 FOR DEMOTE ( L2 ORIGINALLY 10, 10 ) PDM 110 C PDM 120 IF (MOD(NARGS,2).NE.0) GO TO 30 PDM 130 I=10 PDM 140 10 CALL ERROR (I) PDM 150 20 RETURN PDM 160 30 IF(KIND(1).EQ.1) GO TO 35 PDM 163 NR = IARGS (1) PDM 170 CALL CHKCOL (I) PDM 180 IF (I.EQ.0) GO TO 40 PDM 190 35 I = 20 PDM 200 GO TO 10 PDM 210 C PDM 220 C IF NUMBER OF ROWS TO BE MOVED IS NEGATIVE, FLIP INSTRUCTIONS. PDM 230 C I.E. PROMOTE -6 IS THE SAME AS DEMOTE 6 PDM 240 40 IF (NR.GE.0) GO TO 50 PDM 250 L2=1-L2 PDM 260 NR=-NR PDM 270 50 NARGS=NARGS-1 PDM 280 C PDM 290 C CHECK DISTANCE OF MOVE PDM 300 C PDM 310 IF (L2.EQ.0) GO TO 70 PDM 320 IF (NR+NRMAX.LE.NROW) GO TO 100 PDM 330 CALL ERROR (231) PDM 345 NRMAX=NROW-NR PDM 350 IF (NRMAX) 20,20,100 PDM 351 70 NDIFF = NRMAX-NR PDM 355 IF (NDIFF) 81,82,82 PDM 360 81 CALL ERROR (230) PDM 365 NDIFF = 0 PDM 370 NR = NRMAX PDM 375 82 IF (NARGS.GT.0) GO TO 100 PDM 380 J = IARGS (1)-1 PDM 385 DO 95 I1 = 1,NCOL PDM 390 K1 = J+1 PDM 395 IF (NDIFF.EQ.0) GO TO 86 PDM 400 K2 = K1 + NR PDM 410 DO 85 I2 = 1,NDIFF PDM 420 RC(K1) = RC(K2) PDM 425 K1 = K1+1 PDM 430 85 K2 = K2+1 PDM 435 86 DO 90 I3 = 1,NR PDM 440 RC(K1) = 0.0 PDM 445 90 K1 = K1 +1 PDM 450 95 J = J + NROW PDM 460 GO TO 20 PDM 470 100 LIMIT=NARGS PDM 480 IF (LIMIT.EQ.0) LIMIT=2*NCOL PDM 490 IF (NERROR.NE.0) GO TO 20 PDM 500 IF (NRMAX.NE.0) GO TO 110 PDM 510 GO TO 10 PDM 520 C PDM 530 C START PROMOTING OR DEMOTING PDM 540 C PDM 550 110 DO 180 I=1,LIMIT,2 PDM 560 IF (NARGS.NE.0) GO TO 120 PDM 570 K1=IARGS(1) PDM 580 K2=K1 PDM 590 IARGS(1)=IARGS(1)+NROW PDM 600 GO TO 130 PDM 610 120 K1=IARGS(I+1) PDM 620 K2=IARGS(I+2) PDM 630 130 IF (L2.EQ.0) GO TO 150 PDM 640 C PDM 650 C DEMOTE COL AT K1 TO COL AT K2 PDM 660 C PDM 670 K1=K1+NRMAX PDM 680 K2=K2+NRMAX+NR PDM 690 DO 140 J=1,NRMAX PDM 700 K1=K1-1 PDM 710 K2=K2-1 PDM 720 140 RC(K2)=RC(K1) PDM 730 GO TO 180 PDM 740 C PDM 750 C PROMOTE COL AT K1 TO COL AT K2 PDM 760 C PDM 770 150 JJ=NRMAX-NR PDM 780 IF (JJ.EQ.0) GO TO 165 PDM 785 K1=K1+NR PDM 790 DO 160 J=1,JJ PDM 800 RC(K2)=RC(K1) PDM 810 K1=K1+1 PDM 820 160 K2=K2+1 PDM 830 C PDM 840 C IF PROMOTE ARRAY, FILL REST OF COLUMN WITH ZEROES. PDM 850 C PDM 860 IF (NARGS.NE.0) GO TO 180 PDM 870 165 JJ=JJ+1 PDM 880 DO 170 J=JJ,NRMAX PDM 890 RC(K2)=0. PDM 900 170 K2=K2+1 PDM 910 180 CONTINUE PDM 920 IF (L2.NE.0) NRMAX=NRMAX+NR PDM 930 GO TO 20 PDM 940 END PDM 950 C BLOCK DATA PHYSIC PHC 10 C VERSION 5.00 PHYSIC 5/15/70 PHC 20 C BLOCK DATA PHYSICAL CONSTANTS PHC 30 C (THEIR VALUES AND NUMBER REPRESENTATION) PHC 40 BLOCK DATA PHC 50 COMMON/PCONST/JPC,P(40),N(40) PHC 60 C PCONST DEFINES PHYSICAL CONSTANT VALUES PHC 70 C SI UNITS CGS UNITS PHC 80 C SEE BELOW FOR FURTHER COMMENTS PHC 90 C PI P( 1)=3.1415926535 P( 2)=3.1415926535 PHC 100 C E P( 3)=2.716281828459 P( 4)=2.716281828459 PHC 110 C C P( 5)=2.997925E8 P( 6)=2.997925E10 PHC 120 C Q P( 7)=1.60210E-19 P( 8)=1.60210E-20 PHC 130 C N P( 9)=6.02252E23 P(10)=6.02252E23 PHC 140 C ME P(11)=9.1091E-31 P(12)=9.1091E-28 PHC 150 C MP P(13)=1.67252E-27 P(14)=1.67252E-24 PHC 160 C F P(15)=9.64870E4 P(16)=9648.70 PHC 170 C H P(17)=6.6256E-34 P(18)=6.6256E-27 PHC 180 C ALPHA P(19)=7.29720E-3 P(20)=7.29720E-3 PHC 190 C QME P(21)=1.758796E11 P(22)=17587960. PHC 200 C RINF P(23)=10973731. P(24)=109737.31 PHC 210 C GAMMA P(25)=2.67519E8 P(26)=26751.9 PHC 220 C MUB P(27)=9.2732E-24 P(28)=9.2732E-21 PHC 230 C R P(29)=8.3143 P(30)=8.3143E7 PHC 240 C K P(31)=1.38054E-23 P(32)=1.38054E-16 PHC 250 C CONE P(33)=3.7415E-16 P(34)=3.7415E-5 PHC 260 C CTWO P(35)=1.43879E-2 P(36)=1.43879 PHC 270 C SIGMA P(37)=5.6697E-8 P(38)=5.6697E-5 PHC 280 C G P(39)=6.670E-11 P(40)=6.670E-8 PHC 290 DATA P(1),P(2),P(3),P(4),P(5),P(6),P(7),P(8),P(9),P(10)/ PHC 300 12*3.1415926535,2*2.718281828459,2.997925E8,2.997925E10, PHC 310 2 1.60210E-19,1.60210E-20,2*6.02252E23/ PHC 320 DATA P(11),P(12),P(13),P(14),P(15),P(16),P(17),P(18),P(19),P(20)/ PHC 330 1 9.1091E-31,9.1091E-28,1.67252E-27,1.67252E-24,9.64870E4,9648.70, PHC 340 2 6.6256E-34,6.6256E-27,2*7.29720E-3/ PHC 350 DATA P(21),P(22),P(23),P(24),P(25),P(26),P(27),P(28),P(29),P(30)/ PHC 360 1 1.758796E11,17587960.,10973731.,109737.31,2.67519E8,26751.9, PHC 370 2 9.2732E-24,9.2732E-21,8.3143,8.3143E7/ PHC 380 DATA P(31),P(32),P(33),P(34),P(35),P(36),P(37),P(38),P(39),P(40)/ PHC 390 1 1.38054E-23,1.38054E-16,3.7415E-16,3.7415E-5,1.43879E-2,1.43879, PHC 400 2 5.6697E-8,5.6697E-5,6.670E-11,6.670E-8/ PHC 410 C PHC 420 DATA N(1),N(2),N(3),N(4),N(5),N(6),N(7),N(8),N(9),N(10)/ PHC 430 1 11907,3645,2187,12393,10206,9612,9909,4374,5832,1069/ PHC 440 DATA N(11),N(12),N(13),N(14),N(15),N(16),N(17),N(18),N(19),N(20)/ PHC 450 1 12749,13379,5143,10046,13122,8019,2606,2750,14101,5103/ PHC 460 C PHYSICAL CONSTANTS INTEGER REPRESENTATION PHC 470 C N (1)= 11907= PI (PI) PHC 480 C N (2)= 3645= E (BASE OF NATURAL LOGS) PHC 490 C N (3)= 2187= C (SPEED OF LIGHT IN VACUUM) PHC 500 C N (4)= 12393= Q (ELEMENTARY CHARGE) PHC 510 C N (5)= 10206= N (AVOGADRO CONSTANT) PHC 520 C N (6)= 9612= ME (ELECTRON REST MASS) PHC 530 C N (7)= 9909= MP (PROTON REST MASS) PHC 540 C N (8)= 4374= F (FARADAY CONSTANT) PHC 550 C N (9)= 5832= H (PLANCK CONSTANT) PHC 560 C N(10)= 1069= ALPHA (FINE STRUCTURE CONSTANT) PHC 570 C N(11)= 12479= QME (CHARGE TO MASS RATIO FOR ELECTRON) PHC 580 C N(12)= 13379= RINF (RYDBERG CONSTANT) PHC 590 C N(13)= 5142= GAMMA (GYROMAGMETIC RATIO OF PROTON-CORRECTED FOR H2O) PHC 600 C N(14)= 10046= MUB (BOHR MAGNETON) PHC 610 C N(15)= 13122= R (GAS COSNTANT) PHC 620 C N(16)= 8019= K (BOLTZMANN CONSTANT) PHC 630 C N(17)= 2606= CONE (FIRST RADIATION CONSTANT) PHC 640 C N(18)= 2750= CTWO (SECOND RADIATION CONSTANT) PHC 650 C N(19)= 14101= SIGMA (STEPHAN-BOLTZMANN CONSTANT PHC 660 C N(20)= 5103= G (GRAVITATIONAL CONSTANT) PHC 670 END PHC 680 SUBROUTINE PHYCON (NAME) PHY 10 C VERSION 5.00 PHYCON 5/15/70 PHY 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND PHY 30 COMMON/PCONST/JPC,P(40),N(40) PHY 40 C REMOVE PHY 50 C PHY 60 C PHYSICAL CONSTANT LIST PHY 70 C PHY 80 C ENTRIES ARE IN PAIRS, FIRST MKS VALUE, THEN CGS (ELECTROMAGNETIC) PHY 90 C PHY 100 C PHY 110 C PI PI PHY 120 C E BASE OF NATURAL LOGS PHY 130 C C SPEED OF LIGHT IN VACUUM PHY 140 C Q ELEMENTARY CHARGE PHY 150 C N AVOGADRO CONSTANT PHY 160 C ME ELECTRON REST MASS PHY 170 C MP PROTON REST MASS PHY 180 C F FARADAY CONSTANT PHY 190 C H PLANCK CONSTANT PHY 200 C ALPHA FIND STRUCTURE CONSTANT PHY 210 C QME CHARGE TO MASS RATIO FOR ELECTRON PHY 220 C RINF RYDBERG CONSTANT PHY 230 C GAMMA GYROMAGNETIC RATIO OF PROTON (CORRECTED FOR H2O) PHY 240 C MUB BOHR MAGNETON PHY 250 C R GAS CONSTANT PHY 260 C K BOLTZMANN CONSTANT PHY 270 C CONE FIRST RADIATION CONSTANT PHY 280 C CTWO SECOND RADIATION CONSTANT PHY 290 C SIGMA STEPHAN-BOLTZMANN CONSTANT PHY 300 C G GRAVITATIONAL CONSTANT PHY 310 C PHY 320 C PHY 330 C IF NAME .LE. 0, NAME = INDEX FROM MKS,CGS 0 = CGS, -1 = MKS PHY 340 C PHY 350 J=JPC PHY 355 IF (NAME.GT.0) GO TO 10 PHY 360 JPC=NAME PHY 370 RETURN PHY 380 10 DO 20 I=1,20 PHY 390 IF (NAME.EQ.N(I)) GO TO 30 PHY 400 20 CONTINUE PHY 410 ARG=0. PHY 420 RETURN PHY 430 30 I=I+I+J PHY 440 ARG=P(I) PHY 450 RETURN PHY 460 END PHY 470 SUBROUTINE PLOT PLO 10 C VERSION 5.00 PLOT 5/15/70 PLO 20 C S PEAVY 1/18/68 PLO 30 C THIS ROUTINE PLOTS MAX. OF 5 CURVES. IF MORE THEN ONE POINT FALLS PLO 40 C ON THE SAME POSITION A TALLY IS KEPT AND THE NUMBER IS PRINTED. PLO 50 C THE USER MAY PROVIDE THE BOUNDS ON THE X,Y COORDINATES. PLO 60 C IF BOUNDS ARE PROVIDED,THEY MUST APPEAR IN PAIRS AS READ NOS. IF APLO 70 C PAIR OF REAL NOS ARE EQUAL THE PROGRAM ASSUMES THERE ARE NO BOUNDSPLO 80 C COMMANDS FOR USING THIS PLOT ARE AS FOLLOWS PLO 90 C FOR THE AXIS THAT PAIR REPRESENTS AND THE BOUNDS WILL BE CALCULAT-PLO 100 C ED. PLO 110 C COMMANDS FOR USING PLOT ARE AS FOLLOWS PLO 120 C I PLOT Y +++,+++,... X +++ PLO 130 C II PLOT Y +++,+++,....,(YMIN,YMAX) X +++ (XMIN,XMAX) PLO 140 C III PLOT Y +++,+++,....,(YMIN,YMAX) X ++1 PLO 150 C IV PLOT Y +++,+++,.... V +++ (XMIN,XMAX) PLO 160 C V PLOT Y +++,+++,.... X (XMIN,XMAX) (YMIN,YMAX) PLO 170 C PLO 180 C ERRORS PLO 190 C I WHEN TYPE II COMMAND IS USED THERE MUST BE TWO PAIRS OF REAL PLO 200 C NOS. OTHERWISE THE FOLLOWING MESSAGE IS PRINTED PLO 210 C ' Y BOUNDS ARE NOT SET UP CORRECTLY' PLO 220 C I IF BOUNDS ARE PROVIDED, THEN THERE MUST BE FOUR REAL NOS. PLO 230 C II IF A SINGLE REAL NO. APPEARS AHEAD OF COLUMN NOS., THE FOLLOW-PLO 240 C ING MESSAGE WILL BE PRINTED AND NO PLOTTING WILL TAKE PLACE PLO 250 C ' Y BOUNDS ARE NOT SET UP CORRECTLY' PLO 260 C III IF A PLOT COMMAND ENDS WITH ONE REAL NO, THE FOLLOWING MESSAGEPLO 270 C WILL BE PRINTED AND PLOTING WILL BE TERMINATED PLO 280 C ' X BOUNDS ARE NOT SET UP CORRECTLY' PLO 290 C IV IF MORE THEN 5 PLOTS ARE REQUESTED PER GRAPH, NO GRAPH WILL BEPLO 300 C PRODUCED AND FOLLOWING MESSAGE WILL BE PRINTED. PLO 310 C ' MORE THEN 5 PLOTS WERE REQUISTED PER GRAPH' PLO 320 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG PLO 330 COMMON /BLOCRC/ NRC,RC(12600) PLO 340 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NPLO 350 1ARGS,VWXYZ(8),NERROR PLO 360 DIMENSION ARGS(100) PLO 370 EQUIVALENCE (ARGS(1),RC(12501)) PLO 380 COMMON /SCRAT/ NS,NS2,A(13500) PLO 390 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCT,IPRINT,NPAGE,IPUNCH PLO 400 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) PLO 410 DIMENSION TIT(60), TITX(60) PLO 420 EQUIVALENCE (TIT,ITLE(1,6)), (TITX,ITLE(1,5)) PLO 430 DIMENSION X(1), KCCL(6), PRINT(101), XP(6), BOOL(5), IDGT(9) PLO 440 EQUIVALENCE (RC(1),X(1)), (PRINT,A) PLO 450 INTEGER PRINT,BLANK PLO 460 EQUIVALENCE (X0,XMIN), (X1,XMAX), (Y0,YMIN), (Y1,YMAX) PLO 470 DIMENSION IH(12,8), IPR(101) PLO 480 EQUIVALENCE (LHEAD,IH), (IPR,A(200)) PLO 490 INTEGER BOOL PLO 500 DATA BOOL(1),BOOL(2),BOOL(3),BOOL(4),BOOL(5)/1H.,1H*,1H+,1H,,1H-/,PLO 510 1BLANK/1H / PLO 520 DATA IDGT(1),IDGT(2),IDGT(3),IDGT(4),IDGT(5),IDGT(6),IDGT(7),IDGT(PLO 530 18),IDGT(9)/1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HX/ PLO 540 C INITIAL SWITCHES PLO 550 DATA IXPR/1HX/ PLO 560 IF (NRMAX.GT.0) GO TO 10 PLO 570 CALL ERROR (9) PLO 580 RETURN PLO 590 10 ISWT=1 PLO 600 ISWT1=0 PLO 610 XUP=1.E+35 PLO 620 XDOWN=-1.E+35 PLO 630 YUP=1.E+35 PLO 640 YDOWN=-1.E+35 PLO 650 NCN=0 PLO 660 IPT=100 PLO 670 IPTX=101 PLO 680 IF (L2.NE.6) GO TO 20 PLO 690 IPT=60 PLO 700 IPTX=61 PLO 710 20 IF (NARGS.EQ.2) GO TO 50 PLO 720 IF (KIND(NARGS).EQ.0) GO TO 40 PLO 730 IF (KIND(NARGS)-KIND(NARGS-1).NE.0) GO TO 680 PLO 740 C X OR Y BOUNDS ARE PROVIDED PLO 750 IF (KIND(NARGS-2).EQ.0) GO TO 30 PLO 760 IF (KIND(NARGS-3).EQ.0) GO TO 680 PLO 770 ISWT=5 PLO 780 YUP=ARGS(NARGS) PLO 790 YDOWN=ARGS(NARGS-1) PLO 800 XUP=ARGS(NARGS-2) PLO 810 XDOWN=ARGS(NARGS-3) PLO 820 NARGS=NARGS-4 PLO 830 GO TO 50 PLO 840 C X BOUNDS ARE PROVIDED PLO 850 30 ISWT=3 PLO 860 XUP=ARGS(NARGS) PLO 870 XDOWN=ARGS(NARGS-1) PLO 880 NARGS=NARGS-2 PLO 890 IF (NARGS.EQ.2) GO TO 50 PLO 900 C CHECK TO SEE IF THERE ARE Y BOUNDS PLO 910 40 IF (KIND(NARGS-1)-KIND(NARGS-2).NE.0) GO TO 670 PLO 920 IF (KIND(NARGS-1).EQ.0) GO TO 50 PLO 930 C Y LIMITS ARE PROVIDED PLO 940 ISWT=ISWT+1 PLO 950 YUP=ARGS(NARGS-1) PLO 960 YDOWN=ARGS(NARGS-2) PLO 970 IARGS(NARGS-2)=IARGS(NARGS) PLO 980 KIND(NARGS-2)=0 PLO 990 NARGS=NARGS-2 PLO1000 50 DO 60 I=1,NARGS PLO1010 60 KCCL(I)=IARGS(I) PLO1020 M=NARGS-1 PLO1030 IF (NARGS.GT.6) GO TO 710 PLO1040 CALL CHKCOL (J) PLO1050 IF (J.GT.0) GO TO 690 PLO1060 C NO ERROR FOUND IN COLUMN NOS. PLO1070 IF (NERROR.GE.1) RETURN PLO1080 C SEARCH FOR MAX AND MIN ON AXIS, IF BOUNDS ARE NOT PROVIDED, PLO1090 C OTHERWISE TALLY NO OF POINT THAT FALL OUTSIDE OF BOUNDS . PLO1100 IF (XUP.GE.XDOWN) GO TO 70 PLO1110 XAP=XDOWN PLO1120 XAN=XUP PLO1130 GO TO 80 PLO1140 70 XAP=XUP PLO1150 XAN=XDOWN PLO1160 80 IF (YUP.GE.YDOWN) GO TO 90 PLO1170 YAP=YDOWN PLO1180 YAN=YUP PLO1190 GO TO 100 PLO1200 90 YAP=YUP PLO1210 YAN=YDOWN PLO1220 100 K1=IARGS(NARGS) PLO1230 K2=K1-1+NRMAX PLO1240 IF (ISWT-2) 110,720,150 PLO1250 110 X1=X(K1) PLO1260 X0=X1 PLO1270 DO 130 I=K1,K2 PLO1280 IF (X1.GE.X(I)) GO TO 120 PLO1290 X1=X(I) PLO1300 GO TO 130 PLO1310 120 IF (X0.LE.X(I)) GO TO 130 PLO1320 X0=X(I) PLO1330 130 CONTINUE PLO1340 140 XAP=X1 PLO1350 XAN=X0 PLO1360 150 GO TO (170,270,160,270,270), ISWT PLO1370 160 KEY=2 PLO1380 GO TO 180 PLO1390 170 KEY=1 PLO1400 180 DO 260 J=1,M PLO1410 K1=IARGS(NARGS) PLO1420 K3=IARGS(J) PLO1430 K4=K3-1+NRMAX PLO1440 IF (J.GT.1) GO TO 190 PLO1450 Y1=X(K3) PLO1460 Y0=Y1 PLO1470 KY=1 PLO1480 190 GO TO (200,220), KEY PLO1490 200 DO 210 I=K3,K4 PLO1500 IF (Y1.LT.X(I)) Y1=X(I) PLO1510 IF (Y0.GT.X(I)) Y0=X(I) PLO1520 210 CONTINUE PLO1530 GO TO 260 PLO1540 220 DO 250 I=K3,K4 PLO1550 IF (X(K1).GE.XAN.AND.X(K1).LE.XAP) GO TO (230,240), KY PLO1560 GO TO 250 PLO1570 230 Y1=X(I) PLO1580 Y0=X(I) PLO1590 KY=2 PLO1600 GO TO 250 PLO1610 240 IF (Y1.LT.X(I)) Y1=X(I) PLO1620 IF (Y0.GT.X(I)) Y0=X(I) PLO1630 250 K1=K1+1 PLO1640 260 CONTINUE PLO1650 YAP=Y1 PLO1660 YAN=Y0 PLO1670 IF (ISWT.EQ.1) GO TO 800 PLO1680 GO TO 280 PLO1690 270 Y1=YUP PLO1700 Y0=YDOWN PLO1710 ISWT1=1 PLO1720 IF (ISWT.EQ.2) GO TO 770 PLO1730 280 X1=XUP PLO1740 X0=XDOWN PLO1750 GO TO 770 PLO1760 C DETERMINE X AND Y INCREMENTS FOR PLOT PLO1770 290 YDELTA=(YMAX-YMIN)/50. PLO1780 K1=IARGS(NARGS) PLO1790 XDELTA=(XMAX-XMIN)/FLOAT(IPT) PLO1800 YL=YMAX-YDELTA/2. PLO1810 YT=YMAX PLO1820 IF (ISWT.LE.1) GO TO 820 PLO1830 IF (L2.EQ.6) GO TO 300 PLO1840 WRITE (IPRINT,1050) NTOT,NCN PLO1850 GO TO 820 PLO1860 300 WRITE (IPRINT,940) NTOT,NCN PLO1870 GO TO 820 PLO1880 310 KYTL=1 PLO1890 IF (YMAX.LT.YMIN) KYTL=2 PLO1900 KXTL=1 PLO1910 IF (XMAX.LT.XMIN) KXTL=2 PLO1920 ITB=1 PLO1930 C THE I LOOP CONTROLS THE 5 DIVISIONS OF THE Y ORDINATE PLO1940 DO 620 I=1,6 PLO1950 L=1 PLO1960 C THE J LOOP IS FOR EACH LINE OF PRINT WITHIN THE DIVISIONS PLO1970 DO 620 J=1,10 PLO1980 C BLANK OUT PRINT BUFFER LINE. PLO1990 DO 320 K=1,IPTX PLO2000 320 PRINT(K)=BLANK PLO2010 C THE TKK INDEX IS FOR EACH CURVE. KK LESS THAN 6. PLO2020 DO 500 KK=1,M PLO2030 K3=IARGS(KK) PLO2040 K4=K3-1+NRMAX PLO2050 K5=K1 PLO2060 C THIS DETERMINES IF Y(K) VALUE IS ON THE PRESENT PRINT LINE PLO2070 DO 490 K=K3,K4 PLO2080 GO TO (330,350), KYTL PLO2090 330 IF (X(K)-YT) 340,340,490 PLO2100 340 IF (X(K)-YL) 490,490,370 PLO2110 350 IF (X(K)-YL) 360,360,490 PLO2120 360 IF (X(K)-YT) 490,490,370 PLO2130 C YES. Y(K) BELONGS ON THIS PRINT LINE PLO2140 C THEREFORE DETERMIND WHERE ALL THE X(K5) FALL ON THE X-AXIS PLO2150 370 XL=XMIN PLO2160 XT=XMIN+XDELTA/2. PLO2170 DO 480 KA=1,IPTX PLO2180 GO TO (400,380), KXTL PLO2190 380 IF (X(K5)-XT) 470,470,390 PLO2200 390 IF (X(K4)-XL) 420,420,470 PLO2210 400 IF (X(K5)-XL) 470,410,410 PLO2220 410 IF (X(K5)-XT) 420,470,470 PLO2230 420 IF (PRINT(KA)-BLANK) 440,430,440 PLO2240 430 PRINT(KA)=BOOL(KK) PLO2250 GO TO 490 PLO2260 C IF MORE THEN ONE POINT FALLS ON THE PRINT POSITION, TALLY THE NO. PLO2270 C OF POINTS. PLO2280 440 DO 450 KKK=1,9 PLO2290 IF (PRINT(KA)-IDGT(KKK)) 450,460,450 PLO2300 450 CONTINUE PLO2310 PRINT(KA)=IDGT(1) PLO2320 GO TO 490 PLO2330 460 IF (PRINT(KA).NE.IDGT(9)) PRINT(KA)=IDGT(KKK+1) PLO2340 GO TO 490 PLO2350 470 XL=XT PLO2360 480 XT=XT+XDELTA PLO2370 490 K5=K5+1 PLO2380 500 CONTINUE PLO2390 YP=YT*YL PLO2400 YT=YL PLO2410 YL=YL-YDELTA PLO2420 GO TO (510,550), L PLO2430 510 IF (I-5) 520,520,630 PLO2440 520 L=2 PLO2450 YS=YT+YDELTA/2. PLO2460 C THIS PATH IS EXECUTED ONCE IN EVERY DIVISION OF THE Y-AXIS. EVERY PLO2470 C TENTH LINE, STARTING WITH ZERO LINE PLO2480 IF (L2.EQ.6) GO TO 570 PLO2490 IF (YP) 530,530,540 PLO2500 530 WRITE (IPRINT,960) TIT(ITB),YS,PRINT PLO2510 GO TO 620 PLO2520 540 WRITE (IPRINT,950) TIT(ITB),YS,PRINT PLO2530 GO TO 620 PLO2540 550 IF (L2.EQ.6) GO TO 590 PLO2550 IF (YP) 560,560,610 PLO2560 C PRINTS LINE PLO2570 560 WRITE (IPRINT,970) TIT(ITB),PRINT PLO2580 GO TO 620 PLO2590 570 IF(YP.GT.0.0) GO TO 580 PLO2600 WRITE (IPRINT,980) TIT(ITB),YS,(PRINT(K),K=1,IPTX) PLO2610 GO TO 620 PLO2620 580 WRITE (IPRINT,990) TIT(ITB),YS,(PRINT(K),K=1,IPTX) PLO2630 GO TO 620 PLO2640 590 IF (YP.GT.0.0) GO TO 600 PLO2650 WRITE (IPRINT,1000) TIT(ITB),(PRINT(K),K=1,IPTX) PLO2660 GO TO 620 PLO2670 600 WRITE (IPRINT,1010) TIT(ITB),(PRINT(K),K=1,IPTX) PLO2680 GO TO 620 PLO2690 610 WRITE (IPRINT,1020) TIT(ITB),PRINT PLO2700 620 ITB=ITB+1 PLO2710 630 IF (L2.EQ.6) GO TO 910 PLO2720 IF (YP) 640,640,650 PLO2730 640 WRITE (IPRINT,960) TIT(51),YMIN,PRINT PLO2740 GO TO 660 PLO2750 650 WRITE (IPRINT,950) TIT(51),YMIN,PRINT PLO2760 C LAST LINE OF PRINT OUT PLUS X VALUES ALONG X-AXIS. PLO2770 660 WRITE (IPRINT,1060) IPR PLO2780 WRITE (IPRINT,1030) XP PLO2790 WRITE (IPRINT,1070) TITX PLO2800 RETURN PLO2810 C THIS PRINTS OUT THAT 'Y BOUNDS ARE NOT SET UP CORRECTLY'. PLO2820 670 CONTINUE PLO2830 C THIS PRINTS OUT THAT 'X BOUNDS ARE NOT SET UP CORRECTLY'. PLO2840 680 CONTINUE PLO2850 C THIS PRINT 'COL. NOS. APPEAR AS ARGUMENTS'. PLO2860 690 CALL ERROR (20) PLO2870 700 NERROR=NERROR-1 PLO2880 RETURN PLO2890 C THIS PRINTS THAT 'MORE THEN 5 PLOTS WERE REQUIESTED PER GRAPH'. PLO2900 710 CALL ERROR (10) PLO2910 GO TO 700 PLO2920 720 KEY=1 PLO2930 DO 760 IK=1,M PLO2940 IKK=IARGS(IK) PLO2950 DO 750 I=K1,K2 PLO2960 IF (X(IKK).GE.YAN.AND.X(IKK).LE.YAP) GO TO (730,740), KEY PLO2970 GO TO 750 PLO2980 730 X1=X(I) PLO2990 X0=X1 PLO3000 KEY=2 PLO3010 GO TO 750 PLO3020 740 IF (X1.LT.X(I)) X1=X(I) PLO3030 IF (X0.GT.X(I)) X0=X(I) PLO3040 750 IKK=IKK+1 PLO3050 760 CONTINUE PLO3060 IF (KEY.EQ.2) GO TO 140 PLO3070 X0=XDOWN PLO3080 X1=XUP PLO3090 GO TO 140 PLO3100 770 DO 790 J=1,M PLO3110 K1=IARGS(NARGS) PLO3120 K3=IARGS(J) PLO3130 K4=K3-1+NRMAX PLO3140 DO 790 I=K3,K4 PLO3150 IF (X(I).GT.YAP.OR.X(I).LT.YAN) GO TO 780 PLO3160 IF (X(K1).LE.XAP.AND.X(K1).GE.XAN) GO TO 790 PLO3170 780 NCN=NCN+1 PLO3180 790 K1=K1+1 PLO3190 NTOT=M*NRMAX-NCN PLO3200 C DETERMINE TYPE OF HEADING TO BE PRINTED PLO3210 800 CALL HEADS (KCCL,NARGS,0,1) PLO3220 K=4 PLO3230 IF (L2.EQ.6) K=1 PLO3240 CALL PAGE (K) PLO3250 IF (L2.EQ.6) GO TO 810 PLO3260 WRITE (IPRINT,1040) (IH(I,NARGS),I=1,12),((IH(I,J),I=1,12),BOOL(J)PLO3270 1,J=1,M) PLO3280 GO TO 290 PLO3290 810 WRITE (IPRINT,1080) (IH(I,NARGS),I=1,12),((IH(I,J),I=1,12),BOOL(J)PLO3300 1,J=1,M) PLO3310 GO TO 290 PLO3320 820 XP(1)=XMIN PLO3330 XP(6)=XMAX PLO3340 XR=20.*XDELTA PLO3350 DO 830 I=2,5 PLO3360 830 XP(I)=XP(I-1)+XR PLO3370 DO 840 J=1,100 PLO3380 840 IPR(J)=BOOL(5) PLO3390 DO 850 I=1,101,10 PLO3400 850 IPR(I)=BOOL(3) PLO3410 IF (XMIN*XMAX.GE.0.0) GO TO 900 PLO3420 J=0 PLO3430 DO 860 I=2,5 PLO3440 IF (XP(I-1)*XP(I)) 870,890,860 PLO3450 860 CONTINUE PLO3460 N=IPTX PLO3470 GO TO 890 PLO3480 870 XXP=XP(I-1)+XDELTA PLO3490 DO 880 J=1,20 PLO3500 IF (XP(I-1)*XXP.LE.0.0) GO TO 890 PLO3510 880 XXP=XXP+XDELTA PLO3520 J=20 PLO3530 890 N=(I-2)*20+J PLO3540 IPR(N)=IXPR PLO3550 900 WRITE (IPRINT,1060) (IPR(K),K=1,IPTX) PLO3560 GO TO 310 PLO3570 910 IF(YP.GT.0.0) GO TO 920 PLO3580 WRITE (IPRINT,980) TIT(51),YMIN,(PRINT(K),K=1,IPTX) PLO3590 GO TO 930 PLO3600 920 WRITE (IPRINT,990) TIT(51),YMIN,(PRINT(K),K=1,IPTX) PLO3610 930 WRITE (IPRINT,1060) (IPR(K),K=1,IPTX) PLO3620 WRITE (IPRINT,1030) (XP(K),K=1,4) PLO3630 WRITE (IPRINT,1090) TITX PLO3640 RETURN PLO3650 C PLO3660 940 FORMAT (21H NO. OF PTS. PLOTTED ,I5,33H NO. NOT PLOTTED (OUT OF BOPLO3670 1UNDS) ,I5) PLO3680 950 FORMAT (1X,A1,1PE11.4,1H+,101A1,1H+) PLO3690 960 FORMAT (1X,A1,1PE11.4,1HX,101A1,1HX) PLO3700 970 FORMAT (1X,A1,11X,1HX,101A1,1HX) PLO3710 980 FORMAT (1X,A1,1PE11.4,1HX,61A1,1HX) PLO3720 990 FORMAT (1X,A1,1PE11.4,1H+,61A1,1H+) PLO3730 1000 FORMAT (1X,A1,11X,1HX,61A1,1HX) PLO3740 1010 FORMAT (1X,A1,11X,1H-,61A1,1H-) PLO3750 1020 FORMAT (1X,A1,11X,1H-,101A1,1H-) PLO3760 1030 FORMAT (6(7X,1PE13.4)) PLO3770 1040 FORMAT (6H ABS- ,12A1,6H,ORD- ,5(12A1,2H (,A1,3H), )) PLO3780 1050 FORMAT (29H TOTAL NO. OF PTS. PLOTTED IS,I5,60H AND NO. NOT PLOTTEPLO3790 1D BECAUSE THEY FALL OUTSIDE OF BOUNDS IS,I5) PLO3800 1060 FORMAT (14X,101A1) PLO3810 1070 FORMAT (34X,60A1) PLO3820 1080 FORMAT (6H ABS- ,12A1/6H ORD- ,5(12A1,2H (,A1,3H), )) PLO3830 1090 FORMAT (14X,60A1) PLO3840 END PLO3850 SUBROUTINE PREPAK (N,IND,IA,LOC,LH) PRE 10 C VERSION 5.00 PREPAK 5/15/70 PRE 20 C S. PEAVY 8/ 5/69 PRE 30 C THIS SUBROUTINE DOES THE FOLLOWING: PRE 40 C N=1 PACK FORMAT IN IFMT PRE 50 C N=2 PACK HEAD IN IHEAD. IF MORE THAN 50 HEADINGS ARE STORED. PRE 60 C STACK OF HEADINGS IS PUSHED DOWN AND BOTTOM ONES PRE 70 C DISCARDED PRE 80 C N=3 CLEAR VARIABLES IFMT AND IHEAD PRE 90 C N=4 PICK UP PROPER FORMAT NO. IN IA AND STORE IN LH PRE 100 C N=5 UNPACKS THE HEADING OF LOC. INTO LH IA A1 LEFT JUSTIFIED PRE 110 C IND INDICATOR. IF IND =0 CALL TO PREPAK WAS O.K. PRE 120 C IF IND =1 A FLAG THAT RESULTS WERE NOT OBTAINED PRE 130 C PRE 140 C IA COL NUMBER FOR THE HEADING TO BE PACKED OR FORMAT DESIRED PRE 150 C PRE 160 C LOC LOC CONTAINS THE COLUMN NUMBER WHOSE HEADING THE SUBROUTINE PRE 170 C IS TRYING TO FIND. PRE 180 C PRE 190 C LH IS WHERE THE HEADING WILL BE STORED AS A1 LEFT JUSTIFIED PRE 200 C AFTER IT IS UNPACKED, IF THE TITLE IS FOUND. PRE 210 C OR PRE 220 C WHERE FORMAT WILL BE STORED IF N=4 PRE 230 COMMON /ABCDEF/ L(48) PRE 240 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND PRE 250 COMMON /PKSWT/ IHCNT,IHTP PRE 260 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST PRE 270 COMMON /SCRAT/ NS,NS2,A(13500) PRE 280 DIMENSION IAA(80) PRE 290 EQUIVALENCE (A,IAA) PRE 300 DIMENSION LH(1) PRE 310 C ******************************************************************PRE 320 C PRE 330 C THE VARIABLE IFMT CONTAINS THE INFORMATION FOR 6 FORMATS PRE 340 C (I E. FORMAT A THUR F). THE MAXIMUM LENGTH FOR EACH FORMAT IS PRE 350 C 72 CHARACTERS INCLUDING LEFT AND RIGHT PARENTASIS. IF FORMATS ARE PRE 360 C PACKED DIFFERENTLY THEN STATED BELOW. THE DIMENSION SIZE OF PRE 370 C THE FIRST (12) CONSTANT MUST BE CHANGED TO BE EQUAL OR GREATER PRE 380 C THEN 72/(NO. OR CHARACTERS PRE WORD)+M. SEE NOTE BELOW FOR M VALUEPRE 390 C CAUTION: FORMATS MUST BE PACKED IF NH CONVERSION IS PERMITTED PRE 400 C PRE 410 C THE VARIABLE IHEAD (5,LA) CONTAINS THE HEADINGS FOR LA COLUMNS. PRE 420 C MAXIMUN NO. OF CHARACTERS PER HEADING IS 12. PRE 430 C PRE 440 DIMENSION IFMT(12,6), IHEAD(5,50) PRE 450 C PRE 460 C IF THE VARIABLES IFMT(II,6),IHEAD,5,LA ARE REDIMENSIONED SO THAT PRE 470 C II DOES NOT = 12 PRE 480 C AND LA DOES NOT = 50 PRE 490 C THEN THE FOLLOWING DATA STATEMENT MUST BE CHANGED PRE 500 C PRE 510 DATA II/12/,LA/50/ PRE 520 C PRE 530 C FORMAT 90 MUST BE CHANGED IF MORE OR FEWER CHARACTERS CAN BE PRE 540 C PACKED INTO A WORD. 90 FORMAT (IIAK) WHERE II IS DEFINED ABOVE ANDPRE 550 C K = 12/(CHARACTER PER WORD)+M. PRE 560 C WHERE M=0 IF 12/(NO. OF CHAR/WORD) HAS NO REMAINDER PRE 570 C AND M=1 IF 12/(NO. OF CHAR/WORD) HAS A REMAINDER PRE 580 C ******************************************************************PRE 590 IF (N.GT.5) GO TO 60 PRE 600 IND=0 PRE 610 GO TO (10,70,150,180,200), N PRE 620 C THIS PART OF PROGRAM PACKS AND STORES FORMAT PRE 630 10 K=KARD(M) PRE 640 15 M=M+1 PRE 650 IF (KARD(M).NE.41) IF (KARD(M)-46) 15,60,15 PRE 655 KK=1 PRE 660 KA=0 PRE 670 MA=M+1 PRE 680 KR=KRDEND+3 PRE 690 DO 20 I=MA,KR PRE 700 IF (KARD(I).EQ.41) KK=KK+1 PRE 710 IF (KARD(I).NE.42) GO TO 20 PRE 720 KA=KA+1 PRE 730 IF (KA.EQ.KK) GO TO 30 PRE 740 20 CONTINUE PRE 750 GO TO 60 PRE 760 30 MB=M-2 PRE 770 IM=I-M+1 PRE 780 DO 40 JA=1,80 PRE 790 40 IAA(JA)=L(45) PRE 800 DO 50 JA=1,IM PRE 810 IAA(JA)=NEWCD(MB) PRE 820 50 MB=MB+1 PRE 830 WRITE (ISCRAT,240) (IAA(JA),JA=1,80) PRE 840 BACKSPACE ISCRAT PRE 850 READ (ISCRAT,230) (IFMT(JA,K-9),JA=1,II) PRE 860 BACKSPACE ISCRAT PRE 870 RETURN PRE 880 60 IND=IND+1 PRE 890 RETURN PRE 900 C THIS PACKS HEADS PRE 910 70 IF (IHCNT.GE.IHTP) GO TO 140 PRE 920 IF (IHCNT.EQ.0) GO TO 110 PRE 930 C IHEAD(1,I)=COL NUMBER FOR THAT HEADING PRE 940 DO 80 I=1,IHCNT PRE 950 IF (IA.EQ.IHEAD(1,I)) GO TO 130 PRE 960 80 CONTINUE PRE 970 KB=IHCNT PRE 980 90 DO 100 I=1,KB PRE 990 KA=KB-I+2 PRE1000 DO 100 K=1,5 PRE1010 100 IHEAD(K,KA)=IHEAD(K,KA-1) PRE1020 110 IHCNT=IHCNT+1 PRE1030 120 IHEAD(1,1)=IA PRE1040 ICHAR=12 PRE1042 DO 122 I=2,5 PRE1044 C THE FOLLOWING CONSTANT IS (45*256+45)*256+45 PRE1046 122 IHEAD (I,1)=2960685 PRE1050 IF(M+12.GT.KRDEND+3) ICHAR=KRDEND+2-M PRE1052 CALL PACK(KARD(M+1),IHEAD(2,1),ICHAR,0) PRE1054 RETURN PRE1060 130 IF (I.EQ.1) GO TO 120 PRE1070 KB=I-1 PRE1080 GO TO 90 PRE1090 140 KB=IHTP-1 PRE1100 CALL ERROR (229) PRE1105 GO TO 90 PRE1110 C N=3 CLEAR IFMT, IHEAD PRE1120 150 DO 160 I=1,5 PRE1130 DO 160 IA=1,II PRE1140 160 IFMT(IA,I)=0 PRE1150 DO 170 I=1,LA PRE1160 DO 170 IA=1,5 PRE1170 170 IHEAD(IA,I)=0 PRE1180 RETURN PRE1190 C FIND PROPER FORMAT PRE1200 180 IF (IA.LT.2.OR.IA.GT.7) GO TO 60 PRE1210 IF (IFMT(1,IA-1).EQ.0) GO TO 60 PRE1220 DO 190 I=1,II PRE1230 190 LH(I)=IFMT(I,IA-1) PRE1240 RETURN PRE1250 C SEARCH FOR HEADING AND UNPACK PRE1260 C IF HEADING IS FOUND IND=0, OTHERWISE 1. PRE1270 200 DO 210 I=1,IHCNT PRE1280 IF (LOC.EQ.IHEAD(1,I)) GO TO 220 PRE1290 210 CONTINUE PRE1300 C NO HEADING FOUND PRE1310 GO TO 60 PRE1320 220 CALL PACK (IHEAD(2,I),LH,12,1) PRE1330 RETURN PRE1340 C PRE1350 230 FORMAT (12A6) PRE1360 240 FORMAT (80A1) PRE1370 END PRE1380 SUBROUTINE PRINTX PRI 10 C VERSION 5.00 PRINTX 5/15/70 PRI 20 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG PRI 30 COMMON /BLOCRC/ NRC,RC(12600) PRI 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NPRI 50 1ARGS,VWXYZ(8),NERROR PRI 60 DIMENSION ARGS(100) PRI 70 EQUIVALENCE (ARGS(1),RC(12501)) PRI 80 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH PRI 90 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) PRI 100 COMMON /KFMT/ KFMT(100) PRI 110 C PRI 120 C THIS SUBROUTINE IS CALLED TO EXECUTE THE FOLLOWING PRI 130 C PRINT // COLS ++,++,++,++,ETC (PRINT WITH FORMAT//) PRI 140 C PRINT COLS ++,++,++,++ USE RPRINT IF ALL ARGS ARE INTEGER PRI 150 C UNLESS IOSWT IS ON PRI 160 C PRINT (USING ARGS AS IN RPRINT) ALWAYS USE RPRINT PRI 170 C PRI 180 C L1=2 PRINT PRI 183 C L1=8 NPRINT PRI 187 IF (NARGS.NE.0) GO TO 45 PRI 190 10 CALL ERROR(205) PRI 200 20 RETURN PRI 210 30 CALL ERROR (222) PRI 220 40 IF (NPAGE.EQ.0 .AND.L1.EQ.8) CALL PAGE(0) PRI 225 CALL RPRINT PRI 230 RETURN PRI 240 45 IF (L2.EQ.1) IF (IOSWT) 40,40,230 PRI 249 CALL PREPAK (4,IND,L2,IND,KFMT) PRI 250 IF (IND.NE.0) GO TO 30 PRI 260 IP=1 PRI 270 50 CALL CHKCOL (I) PRI 280 IF (I.NE.0) GO TO 10 PRI 290 IF (NERROR.NE.0) RETURN PRI 300 IB=0 PRI 305 IA=1 PRI 310 ICP=0 PRI 320 GO TO (60,70), IP PRI 330 60 IB=NARGS PRI 340 GO TO 100 PRI 350 70 IBB=NARGS PRI 360 80 IF (IBB.GT.8) GO TO 90 PRI 370 IB=IBB+IB PRI 380 IC=IBB PRI 390 IBB=0 PRI 400 GO TO 100 PRI 410 90 IBB=IBB-8 PRI 420 IB=8+IB PRI 430 IC=8 PRI 440 100 LL=NRMAX PRI 450 110 IF (LL.GT.51) GO TO 120 PRI 460 J=LL PRI 470 LL=0 PRI 480 GO TO 130 PRI 490 120 LL=LL-50 PRI 500 J=50 PRI 510 130 IF (L1.EQ.8) IF (NPAGE) 155,260,155 PRI 520 CALL PAGE (4) PRI 530 GO TO (150,140), IP PRI 540 140 CALL HEADS (KFMT(IA),IC,ICP,0) PRI 550 150 WRITE (IPRINT,250) PRI 560 155 DO 200 M=1,J PRI 570 DO 160 I=IA,IB PRI 580 K=IARGS(I) PRI 590 IARGS(I)=IARGS(I)+1 PRI 600 160 ARGS(I)=RC(K) PRI 610 GO TO (170,180), IP PRI 620 170 WRITE (IPRINT,KFMT) (ARGS(I),I=1,NARGS) PRI 630 GO TO 200 PRI 640 180 WRITE (IPRINT,IFMTX) (ARGS(I),I=IA,IB) PRI 650 190 IF (MOD(M,10).EQ.0) WRITE (IPRINT,250) PRI 660 200 CONTINUE PRI 670 ICP=1 PRI 680 IF (LL) 210,210,110 PRI 690 210 GO TO (20,220), IP PRI 700 220 IF (IBB.EQ.0) GO TO 20 PRI 710 IF (L1.EQ.8) WRITE(IPRINT,250) PRI 713 IA=IB+1 PRI 715 ICP=0 PRI 720 GO TO 80 PRI 730 C USE STANDARD OR SPECIFIED FORMAT PRI 820 230 IP=2 PRI 830 DO 240 I=1,NARGS PRI 840 240 KFMT(I)=IARGS(I) PRI 850 GO TO 50 PRI 860 C PRI 870 250 FORMAT (1X) PRI 880 260 CALL PAGE (0) PRI 890 GO TO 155 PRI 900 END PRI 910 SUBROUTINE PROB (VNU1,VNU2,F,Q) PRB 10 C VERSION 5.00 PROB 5/15/70 PRB 20 DOUBLE PRECISION FDSIN,FDCOS,FDEXP,FDLOG PRB 30 DOUBLE PRECISION C,A,X,W,ONE,B,TA,TB,G PRB 40 DATA C/.6366197723675814D0/,EP/1.E-5/,ONE/1.D0/,TWO/2.0/,ONEP/1./,PRB 50 1P5/.5/ PRB 60 NU1=VNU1+EP PRB 70 NU2=VNU2+EP PRB 80 V1=NU1 PRB 90 V2=NU2 PRB 100 IF (ABS(V1-VNU1).GT.EP) GO TO 200 PRB 110 IF (ABS(V2-VNU2).GT.EP) GO TO 200 PRB 120 IF (F) 5,6,10 PRB 130 5 F=0.0 PRB 140 C ERROR , SET F=0 SINCE F LESS THEN 0, PRB 150 CALL ERROR (206) PRB 160 6 Q=1.0 PRB 162 RETURN PRB 164 10 IF (NU1.LT.0.OR.NU2.LT.0) GO TO 190 PRB 170 20 MNU1=MOD(NU1,2) PRB 180 MNU2=MOD(NU2,2) PRB 190 IF (MNU2.NE.0) GO TO 70 PRB 200 I1=NU2/2-1 PRB 210 X=V2/(V2+V1*F) PRB 220 V4=V1/TWO PRB 230 I4=NU1 PRB 240 30 A=ONE PRB 250 IF (I1.EQ.0) GO TO 50 PRB 260 W=A PRB 270 DO 40 I=1,I1 PRB 280 T=I PRB 290 W=((V4+T-ONEP)/T)*X*W PRB 300 40 A=A+W PRB 310 50 Q=A*FDEXP(V4*FDLOG(ONE-X)) PRB 320 IF (I4.EQ.NU1) Q=ONEP-Q PRB 330 60 IF (Q.LT.0.) Q=0 PRB 340 IF (Q.GT.ONEP) Q=ONEP PRB 350 RETURN PRB 360 70 IF (MNU1.NE.0) GO TO 80 PRB 370 I1=NU1/2-1 PRB 380 X=ONEP-V2/(V2+V1*F) PRB 390 V4=V2/TWO PRB 400 I4=NU2 PRB 410 GO TO 30 PRB 420 80 IF (NU2.NE.1) GO TO 130 PRB 430 IF (NU1.NE.1) GO TO 90 PRB 440 Q=C*ATAN(ONEP/FSQRT(F)) PRB 450 GO TO 60 PRB 460 90 X=ATAN(FSQRT(V2/(V1*F))) PRB 470 I1=(NU1-3)/2 PRB 480 IS=1 PRB 490 100 TB=FDSIN(X) PRB 500 A=FDCOS(X) PRB 510 IF (I1.EQ.0) GO TO 120 PRB 520 TA=A**2 PRB 530 W=A PRB 540 DO 110 I=1,I1 PRB 550 V3=I PRB 560 W=V3/(V3+P5)*TA*W PRB 570 110 A=A+W PRB 580 120 A=C*(X+TB*A) PRB 590 Q=A PRB 600 GO TO (60,140), IS PRB 610 130 X=ATAN(FSQRT(V1*F/V2)) PRB 620 I1=(NU2-3)/2 PRB 630 IS=2 PRB 640 GO TO 100 PRB 650 140 IF (NU1.NE.1) GO TO 150 PRB 660 Q=ONE-A PRB 670 GO TO 60 PRB 680 150 I1=(NU1-3)/2 PRB 690 B=ONE PRB 700 IF (I1.EQ.0) GO TO 170 PRB 710 W=B PRB 720 DO 160 I=1,I1 PRB 730 V3=I PRB 740 W=(V2+TWO*V3-ONEP)/(TWO*V3+ONEP)*TB**2*W PRB 750 160 B=B+W PRB 760 170 G=C PRB 770 I1=(NU2-1)/2 PRB 780 DO 180 I=1,I1 PRB 790 V3=I PRB 800 180 G=(TWO*V3)/(TWO*V3-ONEP)*G PRB 810 W=1.0D0 PRB 820 X=FDCOS(X) PRB 830 IF (MOD(NU2,2).GT.0) W=DSIGN(W,X) PRB 840 Q=ONE-A+G*TB*W*FDEXP(FLOAT(NU2)*FDLOG(DABS(X)))*B PRB 850 GO TO 60 PRB 860 C PRINT ' EITHER NU1 OR NU2 IS LESS THEN 1 ' PRB 870 190 CALL ERROR (207) PRB 880 RETURN PRB 890 C PRINT ' EITHER NU1 OR NU2 IS NOT A INTEGER PROGRAM USES LARGEST PRB 900 C INTEGER CONTAINED ' PRB 910 200 CALL ERROR (208) PRB 920 GO TO 20 PRB 930 END PRB 940 SUBROUTINE PROCHK (A,NROW,N,NCOL,IVEC,X,NSIZE) PRK 10 C VERSION 5.00 PROCHK 5/15/70 PRK 20 C SUBROUTINE PROCHK R VARNER 5/ 7/68 PRK 30 C R VARNER SUBROUTINE TO CHECK FOR DIAGNONAL ,NORMAL,SYMMETRIC, PRK 40 C SKEW-SYMMETRIC AND ORTHOGONAL MATRIX PRK 50 DIMENSION A(NROW,1), IVEC(1) PRK 60 DOUBLE PRECISION XP PRK 70 C SET ALL INDICATORS TO NO CONDITION PRK 80 DO 10 I=1,5 PRK 90 10 IVEC(I)=2 PRK 100 C TEST TO SEE IF WE HAVE A DIAGONAL MATRIX PRK 110 C IF YES IVEC(1)=0 IF NO IVEC(1)=2 PRK 120 DO 30 I=1,N PRK 130 DO 30 J=1,N PRK 140 IF (I-J) 20,30,20 PRK 150 20 IF (A(I,J)) 40,30,40 PRK 160 30 CONTINUE PRK 170 IVEC(1)=0 PRK 180 IVEC(2)=0 PRK 190 IVEC(3)=0 PRK 200 GO TO 50 PRK 210 40 IVEC(1)=2 PRK 220 C CHECK FOR SUMMETRY PRK 230 CALL SYMV (A,NROW,N,IVEC(2)) PRK 240 C CHECK FOR SKEW SYMMETRY PRK 250 CALL SKSYMV (A,NROW,N,IRV) PRK 260 IF (IRV.GE.3) IVEC(2)=IRV PRK 270 IF (IVEC(2).EQ.2) GO TO 50 PRK 280 IVEC(3)=0 PRK 290 C CHECK FOR ORTHOGONAL MATRIX PRK 300 C IF A IS ORTHOGONAL IVEC(4)=0 OTHERWISE IVEC(4)=2 PRK 310 50 CALL ORTHRV (A,NROW,N,NCOL,IVEC(4),X,NSIZE,X) PRK 320 RETURN PRK 330 END PRK 340 SUBROUTINE PROROW PRO 10 C VERSION 5.00 PROROW 5/15/70 PRO 20 C PROGRAMMED BY CARLA MESSINA MAY,1967 PRO 30 C L2 - 1, ROWSUM L2 = 2, PRODUCT PRO 40 COMMON /BLOCRC/ NRC,RC(12600) PRO 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NPRO 60 1ARGS,VWXYZ(8),NERROR PRO 70 DIMENSION ARGS(100) PRO 80 EQUIVALENCE (ARGS(1),RC(12501)) PRO 90 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG PRO 100 COMMON /SCRAT/ NS,NS2,A(13500) PRO 110 IF (NARGS-3) 10,40,40 PRO 120 10 IF (NARGS.EQ.1.AND.KIND(1).EQ.0) GO TO 230 PRO 130 K=10 PRO 140 20 CALL ERROR (K) PRO 150 30 RETURN PRO 160 40 CALL CHKCOL (J) PRO 170 IF (J) 50,60,50 PRO 180 50 K=3 PRO 190 GO TO 20 PRO 200 60 IF (NRMAX) 70,70,80 PRO 210 70 K=9 PRO 220 GO TO 20 PRO 230 80 IF (NERROR.NE.0) RETURN PRO 240 DO 100 I=1,NRMAX PRO 250 A(I)=0.0 PRO 260 GO TO (100,90), L2 PRO 270 90 A(I)=1.0 PRO 280 100 CONTINUE PRO 290 IF (NARGS-4) 110,190,190 PRO 300 110 IF (IARGS(1)-IARGS(2)) 120,120,50 PRO 310 120 K=IARGS(1) PRO 320 DO 150 I=1,NRMAX PRO 330 J=K+I-1 PRO 340 GO TO (130,140), L2 PRO 350 130 A(I)=A(I)+RC(J) PRO 360 GO TO 150 PRO 370 140 A(I)=A(I)*RC(J) PRO 380 150 CONTINUE PRO 390 IF (IARGS(1)+NROW-IARGS(2)) 160,160,170 PRO 400 160 IARGS(1)=IARGS(1)+NROW PRO 410 GO TO 120 PRO 420 170 K=IARGS(NARGS) PRO 430 DO 180 I=1,NRMAX PRO 440 J=K+I-1 PRO 450 180 RC(J)=A(I) PRO 460 GO TO 30 PRO 470 190 II=NARGS-1 PRO 480 DO 220 L=1,II PRO 490 K=IARGS(L) PRO 500 DO 220 I=1,NRMAX PRO 510 J=K+I-1 PRO 520 GO TO (200,210), L2 PRO 530 200 A(I)=A(I)+RC(J) PRO 540 GO TO 220 PRO 550 210 A(I)=A(I)*RC(J) PRO 560 220 CONTINUE PRO 570 GO TO 170 PRO 580 230 CALL ADRESS (1,J) PRO 590 IF (J.LE.0) CALL ERROR (3) PRO 600 DO 250 I=1,NRMAX PRO 610 IR=I PRO 620 SUM=0. PRO 630 DO 240 K=1,NCOL PRO 640 SUM=SUM+RC(IR) PRO 650 240 IR=IR+NROW PRO 660 RC(J)=SUM PRO 670 250 J=J+1 PRO 680 RETURN PRO 690 END PRO 700 SUBROUTINE PUNCH PUN 10 C VERSION 5.00 PUNCH 5/15/70 PUN 20 C PUN 30 C THE COMAND PUNCH MAY BE USED IN THE FOLLOWING WAYS PUN 40 C PUNCH COL ++,++,++,++ (4 COLUMN LIMIT) PUN 50 C PUNCH // COL ++,++,++,++,ECT (ACCORDING TO FORMAT //) PUN 60 C THIS SUBROUTINE IS USED TO EXECUTE WRITE TAPE PUN 70 C WRITE TAPE T FROM COL ++,++,++,++ (4 COLUMN LIMIT) PUN 80 C WTITE TAPE T // FROM COL ++,++,ETC (USR FOLMAT//) PUN 90 C PUN 100 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG PUN 110 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NPUN 120 1ARGS,VWXYZ(8),NERROR PUN 130 COMMON /BLOCRC/ NRC,RC(12600) PUN 140 DIMENSION ARGS(100) PUN 150 EQUIVALENCE (ARGS(1),RC(12501)) PUN 160 COMMON /KFMT/ KFMT(100) PUN 170 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) PUN 180 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,LITP PUN 190 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH PUN 200 C PUN 210 C L1=3 PUNCH L1=47 WRITE TAPE PUN 220 C PUN 230 IX=1 PUN 240 IF (L1.EQ.47) IX=2 PUN 250 IF (NARGS.NE.0) GO TO 20 PUN 260 10 CALL ERROR (205) PUN 270 RETURN PUN 280 C PUN 290 C IF L2=1 ONLY 4 COLUMNS CAN BE PRINTED PUN 300 C PUN 310 20 IF(L2.NE.1) GO TO 25 PUN 320 NARGS=MIN0(NARGS,4) PUN 330 GO TO 30 PUN 340 25 CALL PREPAK (4,IND,L2,IND,KFMT) PUN 345 IF (IND.NE.0) GO TO 90 PUN 350 30 CALL CHKCOL (I) PUN 360 IF (I.NE.0) GO TO 10 PUN 370 IF (NERROR.NE.0) GO TO (110,100), IX PUN 380 DO 60 I=1,NRMAX PUN 390 DO 40 J=1,NARGS PUN 400 K=IARGS(J) PUN 410 IARGS(J)=K+1 PUN 420 40 ARGS(J)=RC(K) PUN 430 IF (L2.NE.1) GO TO 50 PUN 440 WRITE (IPUNCH,IFMTX) (ARGS(K),K=1,NARGS) PUN 450 GO TO 60 PUN 460 50 WRITE (IPUNCH,KFMT) (ARGS(K),K=1,NARGS) PUN 470 60 CONTINUE PUN 480 IF (L1.NE.47) RETURN PUN 490 DO 70 J=1,NARGS PUN 500 70 ARGS(J)=0.0 PUN 510 IF (L2.NE.1) GO TO 80 PUN 520 WRITE (IPUNCH,IFMTX) (ARGS(K),K=1,NARGS) PUN 530 GO TO 100 PUN 540 80 WRITE (IPUNCH,KFMT) (ARGS(K),K=1,NARGS) PUN 550 GO TO 100 PUN 560 90 CALL ERROR (222) PUN 570 L2=1 PUN 580 GO TO 30 PUN 590 100 IPUNCH=IPUNCP PUN 600 110 RETURN PUN 610 END PUN 620 SUBROUTINE PVTRI (A,NROW,N,INDU,INDB) PVT 10 C VERSION 5.00 PVTRI 5/15/70 PVT 20 C PVT 30 C TO DETERMINE IF A IS AN UPPER OR LOWER TRIANGULAR MATRIX PVT 40 C S PEAVY FOR UNIVAC 1108 2/ 7/68 PVT 50 C PVT 60 C A MATRIX TO BE CHECKED PVT 70 C NROW- DIMENSION SIZE OF A PVT 80 C N- PRESENT SIZE OF A PVT 90 C INDU IDICATOR INDU=0,UPPER TRIANGLE=0, INDU=1, UPPER TRIANGLE NO PVT 100 C INDB=0,BOTTOM TRIAL =0, INDB=1, BOTTOM NOT ZE PVT 110 C PVT 120 DIMENSION A(NROW,NROW) PVT 130 INDU=1 PVT 140 INDB=1 PVT 150 NN=N-1 PVT 160 DO 50 I=1,NN PVT 170 II=I+1 PVT 180 DO 50 J=II,N PVT 190 GO TO (10,20), INDU PVT 200 10 IF (A(I,J).NE.0.) INDU=2 PVT 210 20 GO TO (30,40), INDB PVT 220 30 IF (A(J,I).NE.0.) INDB=2 PVT 230 40 IF (INDU.EQ.2.AND.INDB.EQ.2) GO TO 60 PVT 240 50 CONTINUE PVT 250 60 INDU=INDU-1 PVT 260 INDB=INDB-1 PVT 270 RETURN PVT 280 END PVT 290 SUBROUTINE RANKO (N,X,H,R,T) RKO 10 C VERSION 45.0 RANKO 3/ 6/70 RKO 20 DIMENSION X(1), H(1), R(1) RKO 30 C ***** RKO 40 C PUTS RANK OF N X'S IN VECTOR R. VECTOR H IS USED FOR STORAGE. RKO 50 C X,H AND R MUST BE DIMENSIONED N OR GREATER. RKO 60 C STORES CORRECTION FOR TIES IN T = (1/12)*SUM(T-1)*T*(T+1). RKO 70 C T=0 MEANS NO TIES. RKO 80 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/9/69. RKO 90 C MOVE X TO R AND PUT I IN H RKO 120 10 DO 20 I=1,N RKO 130 H(I)=I RKO 140 20 R(I)=X(I) RKO 150 C SORT X IN R, CARRY ALONG I IN H TO OBTAIN HIERARCHY IN H. RKO 160 C SORT USES 'PUSH-DOWN' METHOD. SEE ORGANICK, PAGE 84. RKO 170 K1=N-1 RKO 180 DO 30 I=1,K1 RKO 190 K2=N-I RKO 200 DO 30 J=1,K2 RKO 210 IF (R(J).LE.R(J+1)) GO TO 30 RKO 220 W=R(J) RKO 230 R(J)=R(J+1) RKO 240 R(J+1)=W RKO 250 W=H(J) RKO 260 H(J)=H(J+1) RKO 270 H(J+1)=W RKO 280 30 CONTINUE RKO 290 C REPLACE R(I) BY I*. RKO 300 C LET K BE SUCH THAT R(I)=R(I-J+1),J=1,K. THEN I* = I-(K-1)/2. RKO 310 K=1 RKO 320 T=0 RKO 330 DO 70 I=2,N RKO 340 IF (R(I)-R(I-1)) 50,40,50 RKO 350 40 K=K+1 RKO 360 GO TO 70 RKO 370 50 DO 60 J=1,K RKO 380 IJ=I-J RKO 390 60 R(IJ)=FLOAT(I-1)-FLOAT(K-1)/2. RKO 400 IF (K.GT.1) T=T+(FLOAT(K-1)*FLOAT(K)*FLOAT(K+1))/12.0 RKO 410 K=1 RKO 420 70 CONTINUE RKO 430 T = T + (FLOAT(K-1)*FLOAT(K)*FLOAT(K+1))/12.0 RKO 440 DO 80 I=1,K RKO 450 K2=N+1-I RKO 460 80 R(K2)=FLOAT(N)-FLOAT(K-1)/2.0 RKO 470 C SORT H CARRY ALONG R TO OBTAIN RANKS IN R RKO 480 DO 90 I=1,K1 RKO 490 K2=N-I RKO 500 DO 90 J=1,K2 RKO 510 IF (H(J).LE.H(J+1)) GO TO 90 RKO 520 W=H(J) RKO 530 H(J)=H(J+1) RKO 540 H(J+1)=W RKO 550 W=R(J) RKO 560 R(J)=R(J+1) RKO 570 R(J+1)=W RKO 580 90 CONTINUE RKO 590 RETURN RKO 600 END RKO 610 SUBROUTINE RANKS RAS 10 C VERSION 5.00 RANKS 5/15/70 RAS 20 C ***** RAS 30 C VERSION 3.05 COMMON RAS 40 COMMON /BLOCRC/ NRC,RC(12600) RAS 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NRAS 60 1ARGS,VWXYZ(8),NERROR RAS 70 DIMENSION ARGS(100) RAS 80 EQUIVALENCE (ARGS(1),RC(12501)) RAS 90 COMMON /SCRAT/ NS,NS2,A(13500) RAS 100 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG RAS 110 C ***** RAS 120 C RANKS OF VALUES IN COLUMN ++ PUT IN COLUMN ++. TIES ARE ALLOWED. RAS 130 C ADJUSTMENT T=(1/12)*SUM(T-1)*T*(T+1) FOR FURTHER CALCULATIONS IS RAS 140 C PUT IN ROW(NRMAX+1) IF NRMAX LT NROW. RAS 150 C ***** RAS 160 10 IF (NARGS.EQ.2) GO TO 20 RAS 170 CALL ERROR (10) RAS 180 RETURN RAS 190 20 CALL ADRESS(1,J1) RAS 200 CALL ADRESS(2,J2) RAS 210 IF (J1.GT.0.AND.J2.GT.0) GO TO 30 RAS 220 CALL ERROR (3) RAS 230 RETURN RAS 240 30 IF (NRMAX.GT.0) GO TO 40 RAS 250 CALL ERROR (9) RAS 260 RETURN RAS 270 40 IF (NERROR.NE.0) RETURN RAS 280 CALL RANKX (NRMAX,RC(J1),A(2),RC(J2),A(1)) RAS 290 IF (NRMAX.GE.NROW) RETURN RAS 300 JANR=J2+NRMAX RAS 305 RC(JANR)=A(1) RAS 310 RETURN RAS 320 END RAS 330 SUBROUTINE RANKX (N,X,H,R,T) RAX 10 C VERSION 5.00 RANKX 5/15/70 RAX 20 DIMENSION X(1), H(1), R(1) RAX 30 C ***** RAX 40 C PUTS RANK OF N X'S IN VECTOR R. VECTOR H IS USED FOR STORAGE. RAX 50 C X,H AND R MUST BE DIMENSIONED N OR GREATER. RAX 60 C STORES CORRECTION FOR TIES IN T = (1/12)*SUM(T-1)*T*(T+1). RAX 70 C T=0 MEANS NO TIES. RAX 80 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/9/69 RAX 90 C COMPUTATION OF T CORRECTED 8/26/69 RAX 95 C ***** RAX 100 C MOVE X TO R AND PTU I IN H RAX 110 10 DO 20 I=1,N RAX 120 H(I)=I RAX 130 20 R(I)=X(I) RAX 140 C SORT X IN R, CARRY ALONG I IN H TO OBTAIN HIERARCHY IN H. RAX 150 C SORT USES 'PUSH-DOWN' METHOD. SEE ORGANICK, PAGE 84. RAX 160 K1=N-1 RAX 170 DO 30 I=1,K1 RAX 180 K2=N-I RAX 190 DO 30 J=1,K2 RAX 200 IF (R(J).LE.R(J+1)) GO TO 30 RAX 210 W=R(J) RAX 220 R(J)=R(J+1) RAX 230 R(J+1)=W RAX 240 W=H(J) RAX 250 H(J)=H(J+1) RAX 260 H(J+1)=W RAX 270 30 CONTINUE RAX 280 C REPLACE R(I) BY I*. RAX 290 C LET K BE SUCH THAT R(I)=R(I-J+1),J=1,K. THEN I* = I-(K-1)/2. RAX 300 K=1 RAX 310 T=0 RAX 320 DO 70 I=2,N RAX 330 IF (R(I)-R(I-1)) 50,40,50 RAX 340 40 K=K+1 RAX 350 GO TO 70 RAX 360 50 DO 60 J=1,K RAX 370 IJ=I-J RAX 375 60 R(IJ)=FLOAT(I-1)-FLOAT(K-1)/2. RAX 380 IF (K.GT.1) T=T+(FLOAT(K-1)*FLOAT(K)*FLOAT(K+1))/12.0 RAX 390 K=1 RAX 400 70 CONTINUE RAX 410 T = T + (FLOAT(K-1)*FLOAT(K)*FLOAT(K+1))/12.0 RAX 415 DO 80 I=1,K RAX 420 K2=N+1-I RAX 430 80 R(K2)=FLOAT(N)-FLOAT(K-1)/2.0 RAX 440 C SORT H CARRY ALONG R TO OBTAIN RANKS IN R RAX 450 DO 90 I=1,K1 RAX 460 K2=N-I RAX 470 DO 90 J=1,K2 RAX 480 IF (H(J).LE.H(J+1)) GO TO 90 RAX 490 W=H(J) RAX 500 H(J)=H(J+1) RAX 510 H(J+1)=W RAX 520 W=R(J) RAX 530 R(J)=R(J+1) RAX 540 R(J+1)=W RAX 550 90 CONTINUE RAX 560 RETURN RAX 570 END RAX 580 SUBROUTINE RCSUM (A,NROW,N,K,R) RCS 10 C VERSION 5.00 RCSUM 5/15/70 RCS 20 C WRITTEN BY S PEAVY 11/22/67 RCS 30 C RCS 40 C WHERE: RCS 50 C A IS LOCATION OF MATRIX TO BE SUMMED ROW AND COLUMN WISE RCS 60 C NROW SIZE OF A IN DIMENSION STATEMENT A(NROW,NROW) RCS 70 C N NO OF ROWS IN A RCS 80 C K NO OF COLS IN A RCS 90 C R RESULTS. RCS 100 C R(1).. R(K) COL SUMS RCS 110 C R(K+1).. R(K+N) ROW SUMS RCS 120 C R(K+N+2) GRAND SUM RCS 130 C R(K+N+1) S A(I,J) FOR ALL I,J. RCS 140 C R(K+N+3) S A(I,J)**2 FOR ALL I,J. RCS 150 C R(K+N+4) SUM OF ABSOLUTE VALUES OF ALL A(I,J) RCS 160 C RCS 170 DIMENSION A(NROW,NROW), R(N) RCS 180 L=1 RCS 190 ASUM=0. RCS 200 DO 20 J=1,K RCS 210 SUM=0. RCS 220 DO 10 I=1,N RCS 230 ASUM=ASUM+ABS(A(I,J)) RCS 240 10 SUM=SUM+A(I,J) RCS 250 R(L)=SUM RCS 260 20 L=L+1 RCS 270 S=0.0 RCS 280 SS=0.0 RCS 290 DO 40 I=1,N RCS 300 SUM=0.0 RCS 310 DO 30 J=1,K RCS 320 SUM=SUM+A(I,J) RCS 330 30 SS=SS+A(I,J)**2 RCS 340 S=S+SUM RCS 350 R(L)=SUM RCS 360 40 L=L+1 RCS 370 R(L)=S RCS 380 R(L+2)=SS RCS 390 R(L+1)=S RCS 400 R(L+3)=ASUM RCS 410 RETURN RCS 420 END RCS 430 SUBROUTINE READQ REQ 10 C VERSION 5.00 READQ 5/15/70 REQ 20 COMMON /BLOCRC/ NRC,RC(12600) REQ 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NREQ 40 1ARGS,VWXYZ(8),NERROR REQ 50 DIMENSION ARGS(100) REQ 60 EQUIVALENCE (ARGS(1),RC(12501)) REQ 70 COMMON /QRS/ NDROW,IFLAG,J,NNARG REQ 80 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND REQ 90 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST REQ 100 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP REQ 110 COMMON/KFMT/KFMT(100) REQ 115 IF (IFLAG.NE.0) GO TO 80 REQ 120 IF (J.LT.NROW) GO TO 10 REQ 130 IFLAG=1 REQ 140 CALL ERROR (201) REQ 150 GO TO 40 REQ 160 C NNARG CONTAINS NARGS OF READ COMMAND REQ 170 C KFMT(1)THRU KFMT(NNARG) CONTAINS ADDRESSES OF COLUMN TOPS REQ 180 C THESE CORRECTIONS ARE NEEDED FOR TAPE OPERATIONS REQ 190 10 IF (L1TP.NE.45) GO TO 50 REQ 200 DO 30 I=1,NNARG REQ 210 K=KFMT(I)+J REQ 220 IF (KIND(I).EQ.0) GO TO 20 REQ 230 IF (ARGS(I).NE.0.) GO TO 50 REQ 240 GO TO 30 REQ 250 20 IF (IARGS(I).NE.0) GO TO 50 REQ 260 30 CONTINUE REQ 270 40 INUNIT=INUNIP REQ 280 MODE=1 REQ 290 GO TO 80 REQ 300 50 IF (NARGS.GE.NNARG) GO TO 55 REQ 305 NNS=NARGS+1 REQ 307 DO 52 I=NNS,NNARG REQ 310 KIND(I)=0 REQ 315 52 IARGS(I)=0 REQ 320 55 DO 70 I=1,NNARG REQ 325 C ******************************************************************REQ 330 K=KFMT(I)+J REQ 340 IF (KIND(I).EQ.0) GO TO 60 REQ 350 RC(K)=ARGS(I) REQ 360 GO TO 70 REQ 370 60 RC(K)=IARGS(I) REQ 380 70 CONTINUE REQ 390 C J IS CARD COUNT. IT COUNTS FROM ZERO. REQ 400 J=J+1 REQ 410 NRMAX=MAX0(NRMAX,J) REQ 420 C THESE CORRECTIONS ARE NEEDED FOR TAPE OPERATIONS REQ 430 IF (L1TP.NE.46) GO TO 80 REQ 440 NTPCT=NTPCT-1 REQ 450 IF (NTPCT.EQ.0) GO TO 40 REQ 460 C ******************************************************************REQ 470 80 RETURN REQ 480 END REQ 490 SUBROUTINE READX REX 10 C VERSION 5.00 READX 5/15/70 REX 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND REX 30 COMMON /BLOCRC/ NRC,RC(12600) REX 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NREX 50 1ARGS,VWXYZ(8),NERROR REX 60 DIMENSION ARGS(100) REX 70 EQUIVALENCE (ARGS(1),RC(12501)) REX 80 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG REX 90 COMMON /QRS/ NDROW,IFLAG,J,NNARG REX 100 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST REX 110 C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS REX 120 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP REX 130 C ******************************************************************REX 140 COMMON/KFMT/KFMT(100) REX 150 IF (L2.NE.1) GO TO 90 REX 160 ISRFLG=0 REX 170 IF (NARGS.GT.0) GO TO 20 REX 180 10 CALL ERROR (10) REX 190 GO TO 70 REX 200 20 MODE=2 REX 210 CALL CHKCOL (I) REX 220 IF(I.EQ.0) GO TO 40 REX 230 30 CALL ERROR (3) REX 240 GO TO 70 REX 250 40 IF (NERROR.NE.0) GO TO 70 REX 260 DO 50 I=1,NARGS REX 270 KFMT(I)=IARGS(I) REX 280 IARGS(I)=0 REX 290 50 ARGS(I)=0. REX 300 IFLAG=0 REX 310 J=0 REX 320 NNARG=NARGS REX 330 GO TO 80 REX 340 60 MODE=2 REX 350 70 IFLAG=1 REX 360 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS REX 370 IF (L1TP.EQ.46.OR.L1TP.EQ.45) GO TO 200 REX 380 C ******************************************************************REX 390 80 RETURN REX 400 C REX 410 C FORMATTED READ REX 420 C READ X N C C C C REX 430 C REX 440 C N = NUMBER OF CARDS TO READ. IF N = 0, READ UNTIL A REX 450 C BLANK CARD IS FOUND REX 460 C X IS THE FORMAT IDENTIFIER, A,B,C,D,E,F REX 470 C REX 480 90 IF(NARGS.LE.1) GO TO 10 REX 490 C SETUP FORMAT REX 500 CALL PREPAK(4,IND,L2,I,KFMT) REX 510 IF (IND.NE.0) CALL ERROR (27) REX 520 IF (NERROR.NE.0) GO TO 60 REX 530 C CHECK AND CONVERT ARGUMENTS REX 540 DO 100 I=2,NARGS REX 550 CALL ADRESS (I,IARGS(I)) REX 564 IF(IARGS(I).LE.0) GO TO 185 REX 567 100 CONTINUE REX 570 IF(IARGS(1)) 30,110,120 REX 580 110 N=NRC REX 590 GO TO 130 REX 600 120 N=IARGS(1) REX 610 130 DO 170 I=1,N REX 620 READ (INUNIT,KFMT) (ARGS(J),J=2,NARGS) REX 630 C CHECK IF LOOKING FOR BLANK CARD REX 640 IF (IARGS(1).NE.0) GO TO 150 REX 650 DO 140 J=2,NARGS REX 660 IF (ARGS(J).NE.0.) GO TO 150 REX 670 140 CONTINUE REX 680 C BLANK CARD FOUND, TERMINATE READ. REX 690 GO TO 180 REX 700 C IF THERE IS TOO MUCH DATA, DO NOT ENTER EXCESS REX 710 150 IF (I.GT.NROW) GO TO 170 REX 720 DO 160 J=2,NARGS REX 730 K=IARGS(J) REX 740 IARGS(J)=K+1 REX 750 160 RC(K)=ARGS(J) REX 760 170 CONTINUE REX 770 I=N+1 REX 780 180 I=I-1 REX 790 NRMAX=MAX0(NRMAX,MIN0(I,NROW)) REX 800 WRITE (ISCRAT,210) I REX 810 IF (I.GT.NROW) CALL ERROR (201) REX 820 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS REX 830 C THE CARD WAS GO TO 80 REX 840 GO TO 190 REX 850 C ******************************************************************REX 860 185 CALL ERROR (11) REX 870 C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS REX 880 C THE CARD WAS GO TO 80 REX 890 190 IF(L1TP.NE.45.AND.L1TP.NE.46) RETURN REX 900 200 INUNIT=INUNIP REX 910 MODE=1 REX 920 RETURN REX 930 C ******************************************************************REX 940 210 FORMAT (5X,I4,33H DATA CARD(S) READ BUT NOT LISTED, 42X) REX 950 END REX 960 SUBROUTINE REPINC (IJSWT) REP 10 C VERSION 5.00 REPINC 5/15/70 REP 20 C WRITTEN BY R VARNER 4/ 9/68 REP 30 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG REP 40 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) REP 50 COMMON /BLOCKX/ INDEX(6,8),LEVEL REP 60 COMMON /BLOCRC/ NRC,RC(12600) REP 70 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NREP 80 1ARGS,VWXYZ(8),NERROR REP 90 DIMENSION ARGS(100) REP 100 EQUIVALENCE (ARGS(1),RC(12501)) REP 110 C REP 120 C IJSWT=1 COMMAND IS REPEAT INITIALIZE THINGS REP 130 C IJSWT=2 IN REPEAT MODE REP 140 C IJSWT=3 COMMAND IS INCREMENT OR RESTORE REP 150 C REP 160 C L2=6 INCREMENT REP 170 C L2=8 RESTORE REP 180 C REP 190 GO TO (350,490,10), IJSWT REP 200 10 IF (L2.EQ.6) GO TO 20 REP 210 T=0.0 REP 220 GO TO 30 REP 230 20 T=1.0 REP 240 30 IF (NARGS.GE.2) GO TO 50 REP 250 40 K=10 REP 260 GO TO 320 REP 270 C REP 280 C GET STATEMENT NUMBER. CAN BE FLOATING OR INTEGER. REP 290 C REP 300 50 IF (KIND(1).EQ.0) GO TO 60 REP 310 J=10.*ARGS(1)+.5 REP 320 GO TO 70 REP 330 60 J=10*IARGS(1) REP 340 70 IF (J.GT.NSTMTH) GO TO 80 REP 350 J=LOCATE(J) REP 360 C REP 370 C J HAS LOCATION OF COMMAND TO BE MODIFIED REP 380 C REP 390 IF (J.GT.0) GO TO 90 REP 400 80 K=13 REP 410 GO TO 320 REP 420 C REP 430 C JJ IS FIRST LOCATION OF THE NEXT STORED COMMAND. REP 440 C REP 450 90 JJ=J+IFIX(COM(J+1)) REP 460 C REP 470 C CHECK THAT COMMAND HAS THE PROPER NUMBER OF ARGUMENTS REP 480 C REP 490 IF (NARGS-1.NE.MOD(IFIX(COM(J+2)),64)) GO TO 40 REP 500 J=J+3 REP 510 C REP 520 C SKIP OVER HEADER REP 530 C REP 540 C REP 550 C CHECK IF THIS COMMAND IS STORED. IF SO, PULL OUT INTO ARGTAB REP 560 C (ALL BUT FIRST ARG WHICH IS STATEMENT NUMBER) REP 570 C REP 580 IF (LEVEL.EQ.0) GO TO 110 REP 590 K=2*NARGS REP 600 DO 100 I=2,K REP 610 ARGTAB(I)=COM(I2+4) REP 620 100 I2=I2+1 REP 630 C REP 640 C I2 IS LOCATION OF THIS COMMAND REP 650 C REP 660 110 I=2+KIND(1) REP 670 C REP 680 C PERFORM INCREMENT OR RESTORE. PICK UP ARGUMENT FROM REP 690 C COMMAND TO BE MODIFIED AND EXAMINE IT. REP 700 C REP 710 120 IF (COM(J)) 250,130,200 REP 720 C REP 730 C FLOATING POINT CONST. REP 740 C REP 750 130 IF (ARGTAB(I)) 140,160,310 REP 760 C REP 770 C INCR. FL. PT. CONST. BY 'STATEMENT' REP 780 140 IF(ARGTAB(I).EQ.(-1.)) GO TO 310 REP 790 CALL XPND (ARGTAB(I),K,Y,KND) REP 800 IF (K.LT.0) GO TO 220 REP 810 IF (KND.EQ.0) GO TO 310 REP 820 COM(J+1)=T*COM(J+1)+Y REP 830 J=J+2 REP 840 150 I=I+K+1 REP 850 GO TO 190 REP 860 160 COM(J+1)=T*COM(J+1)+ARGTAB(I+1) REP 870 170 J=J+2 REP 880 180 I=I+2 REP 890 190 IF (J-JJ) 120,330,330 REP 900 C REP 910 C COLUMN NUMBER REP 920 C REP 930 200 IF (ARGTAB(I)) 210,310,230 REP 940 C REP 950 C INTEGER CONST MODIFIED BY :STATEMENT: REP 960 C REP 970 210 IF(ARGTAB(I).EQ.(-1.)) GO TO 310 REP 980 CALL XPND (ARGTAB(I),K,Y,KND) REP 990 IF (K.GE.0) IF (KND) 310,225,310 REP 995 220 K=-K REP1000 GO TO 320 REP1010 225 COM(J)=T*COM(J)+Y REP1020 J=J+1 REP1030 GO TO 150 REP1040 230 COM(J)=T*(COM(J)-8192.)+ARGTAB(I) REP1050 IF (COM(J)) 300,300,240 REP1060 240 J=J+1 REP1070 I=I+1 REP1080 GO TO 190 REP1090 C REP1100 C VARIABLE *REFERENCE* REP1110 C NRMAX,V,W,X,Y,Z CAN ONLY BE INCREMENTED, BY 0 OR 0. REP1120 C WHETHER 0 OR 0. INCREMENTS :X: OR 'X' IS IMMATERIAL. REP1130 C REP1140 250 IF(COM(J).LT.(-16.)) GO TO 260 REP1150 IF(COM(J).EQ.(-1.)) GO TO 340 REP1160 J=J+1 REP1170 GO TO 180 REP1180 C REP1190 C *ROW,COL* REFERENCE. REP1200 C REP1210 260 IF (ARGTAB(I)+16.0) 270,310,310 REP1220 270 COM(J)=T*(COM(J)+8208.)+ARGTAB(I) REP1230 IF(COM(J).GT.(-16.)) GO TO 310 REP1240 IF (COM(J+1)*ARGTAB(I+1)) 310,310,280 REP1250 280 Y=T*(ABS(COM(J+1))-8192.)+ABS(ARGTAB(I+1)) REP1260 IF (Y) 310,310,290 REP1270 290 COM(J+1)=SIGN(Y,COM(J+1)) REP1280 GO TO 170 REP1290 300 K=18 REP1300 GO TO 320 REP1310 310 K=20 REP1320 320 CALL ERROR (K) REP1330 330 RETURN REP1340 C REP1350 C *** (=THRU) IGNORE. INCREM. OR RESTORE MAY OR NOT REP1360 C HAVE CORRESPONDING *** REP1370 C REP1380 340 IF(ARGTAB(I).EQ.(-1.)) I=I+1 REP1390 J=J+1 REP1400 GO TO 190 REP1410 C REP1420 C REP1430 C NESTED PERFORMS UP TO EIGHT LEVELS ARE ALLOWED. REP1440 C CURRENT LEVEL IS STORED IN LEVEL REP1450 C REP1460 C INDEX(1,LEVEL) CONTAINS LOCATION OF COMMAND AT ARG1 (FIRST) REP1470 C INDEX(2,LEVEL) CONTAINS RUNNING INDEX FROM ARG1 TO ARG2 REP1480 C INDEX(3,LEVEL) CONTAINS LOCATION OF COMMAND AT ARG2(LAST) REP1490 C INDEX(4,LEVEL) CONTAINS THIRD ARG (REPEAT COUNT) REP1500 C INDEX(5,LEVEL) CONTAINS CURRENT LEVEL COUNTER (1 TO ARG3) REP1510 C INDEX(6,LEVEL) CONTAINS STATEMENT NUMBER OF STATEMENT CURRENTLY REP1520 C BEING EXECUTED. REP1530 C REP1540 350 IF (NARGS-3) 360,400,390 REP1550 360 IF (NARGS-1) 390,370,380 REP1560 C REP1570 C SECOND ARG MISSING,MAKE SAME AS FIRST ARG REP1580 C REP1590 370 IARGS(2)=IARGS(1) REP1600 KIND(2)=KIND(1) REP1610 C REP1620 C THIRD ARG MISSING, SET TO INTEGER 1 REP1630 C REP1640 380 IARGS(3)=1 REP1650 KIND(3)=0 REP1660 GO TO 410 REP1670 390 CALL ERROR (10) REP1680 GO TO 500 REP1690 400 IF (KIND(3).EQ.0.AND.IARGS(3).GT.0) GO TO 410 REP1700 CALL ERROR (3) REP1710 GO TO 500 REP1720 410 DO 450 I=1,2 REP1730 IF (KIND(I).EQ.0) GO TO 420 REP1740 IARGS(I)=10.*ARGS(I)+.5 REP1750 GO TO 430 REP1760 420 IARGS(I)=10*IARGS(I) REP1770 430 IF (IARGS(I).GT.NSTMTH) GO TO 440 REP1780 IARGS(I)=LOCATE(IARGS(I)) REP1790 IF (IARGS(I).GT.0) GO TO 450 REP1800 440 CALL ERROR (13) REP1810 GO TO 500 REP1820 450 CONTINUE REP1830 IF (LEVEL.LT.8) GO TO 460 REP1840 CALL ERROR (19) REP1850 GO TO 500 REP1860 460 IF (IARGS(2).LT.IARGS(1)) CALL ERROR (3) REP1870 IF (NERROR.NE.0) GO TO 500 REP1880 LEVEL=LEVEL+1 REP1890 INDEX(1,LEVEL)=IARGS(1) REP1900 INDEX(3,LEVEL)=IARGS(2) REP1910 INDEX(4,LEVEL)=IARGS(3) REP1920 INDEX(5,LEVEL)=0 REP1930 C REP1940 C OUTER LOOP REP1950 C REP1960 470 INDEX(5,LEVEL)=INDEX(5,LEVEL)+1 REP1970 IF (INDEX(5,LEVEL).LE.INDEX(4,LEVEL)) GO TO 480 REP1980 C REP1990 C FINISHED OUTER LOOP, REDUCE LEVEL BY 1 REP2000 C REP2010 LEVEL=LEVEL-1 REP2020 IF (LEVEL.GT.0) GO TO 490 REP2030 RETURN REP2040 480 INDEX(2,LEVEL)=INDEX(1,LEVEL) REP2050 490 I2=INDEX(2,LEVEL) REP2060 IF (I2.GT.INDEX(3,LEVEL)) GO TO 470 REP2070 INDEX(6,LEVEL)=COM(I2) REP2080 K=COM(I2+1) REP2090 INDEX(2,LEVEL)=INDEX(2,LEVEL)+K REP2100 L2=COM(I2+2) REP2110 L1=L2/64 REP2120 NARGS=L2-64*L1 REP2130 L2=L1/64 REP2140 L1=L1-64*L2 REP2150 CALL EXPAND (K-2,COM(I2+3)) REP2160 RETURN REP2170 500 IJSWT=-IJSWT REP2180 RETURN REP2190 END REP2200 REP2210 SUBROUTINE RESET RES 10 C VERSION 5.00 RESET 5/15/70 RES 20 COMMON /BLOCRC/ NRC,RC(12600) RES 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NRES 40 1ARGS,VWXYZ(8),NERROR RES 50 DIMENSION ARGS(100) RES 60 EQUIVALENCE (ARGS(1),RC(12501)) RES 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG RES 80 IF(NARGS.EQ.1) IF(L2-2) 25,20,40 RES 85 K=10 RES 90 10 CALL ERROR (K) RES 100 20 RETURN RES 110 C RESET NRMAX RES 120 25 IF (KIND(1).NE.0) IARGS(1)=ARGS(1) RES 130 IF (IARGS(1).GE.0.AND.IARGS(1).LE.NROW) GO TO 30 RES 140 K=3 RES 150 GO TO 10 RES 160 30 NRMAX=IARGS(1) RES 170 GO TO 20 RES 180 C RESET V,W,X,Y,Z RES 190 40 IF (KIND(1).EQ.0) ARGS(1)=IARGS(1) RES 200 VWXYZ(L2-2)=ARGS(1) RES 210 GO TO 20 RES 220 END RES 230 SUBROUTINE RFORMT (X,N,NS,NW,ND,NX,XVAL,ARRAY,NB,NC) RFO 10 C VERSION 5.00 RFORMT 5/15/70 RFO 20 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/18/69. RFO 30 C ***** RFO 40 C REWRITE AND COMBINING OF FXFARG(2/1/69) AND FXFORM(2/7/69). RFO 50 C FLOATING FORMAT 1PE NW.NS-1 IS GIVEN IF N LT 0 AND NX LT 0. RFO 60 C FIXED FORMAT F NW.ND IS GIVEN IF N GE 0 AND NX LT 0. SET NS=8. RFO 70 C PERIOD NOT PRINTED IF NDECS=0 RFO 80 C FXFARG SET *** XVAL=X (OR ANY REAL VARIABLE) RFO 90 C ARRAY=A (OR ANY DIMENSIONED VECTOR) RFO 100 C NBLANK=0 (OR ANY OTHER INTEGER) RFO 110 C INPUT *** X, N, NSIGDS, NWMAX. RFO 120 C OUTPUT *** NWIDTH, NDECS. RFO 130 C FXFORM SET *** X=X(OR ANY REAL VARIABLE) RFO 140 C N=1 (OR ANY INTEGER) RFO 150 C NWMAX=0 RFO 160 C INPUT *** XVAL, NSIGDS, NWIDTH, NDECS, NBLANK. RFO 170 C OUTPUT *** ARRAY RFO 180 C ***** RFO 190 C NUMBER IS CENTERED IF NC=1 AND NOT CENTERED IF NC=0(RIGHT JUST'D) RFO 195 C THIS REVISION WRITTEN 10/09/69 RFO 197 COMMON /ABCDEF/ L(48) RFO 200 DIMENSION X(1), ARRAY(1), C(10) RFO 210 EQUIVALENCE (C(1),L(1)), (BLANK,L(45)), (PERIOD,L(38)), (CPLUS,L(4RFO 220 10)), (CMINUS,L(39)), (CASTER,L(41)) RFO 230 DOUBLE PRECISION Z RFO 240 10 NSIGDS=MIN0(8,NS) RFO 250 NSIGDS=MAX0(1,NSIGDS) RFO 260 IF (NX) 50,60,20 RFO 270 C ***** RFO 280 C FXARG SUBROUTINE RFO 290 C INPUT FOR THE SUBROUTINE FXFORM. NWMAX IS THE MAXIMUM ALLOWABLE RFO 300 C VALUE OF NWIDTH. X MUST BE DIMENSIONED AND N IS ITS LENGTH. RFO 310 C NWMAX MUST BE GREATER THAN NSIGDS PLUS FOUR RFO 320 C NWIDTH = MIN(MMAX-MMIN+NSIGDS+2,NWMAX) RFO 330 C NDECS=NSIGDS-MMIN-1, NDECS=MIN0(MAX0(NDECS,NSIGDS+2,NWMAX-3), IF RFO 340 C NWIDTH EXCEEDS NWMAX. RFO 350 C IF NSIGDS GT 8, IT IS SET = TO 8, IF LT 1 SET = TO 1. RFO 360 C REFERENCE ** SEL NOTE N-68-3, SEPTEMBER, 1968. RFO 370 C WRITTEN BY DAVID HOGBEN, SEL, NBS, 2/ 1/69. RFO 380 C ***** RFO 390 20 NWMAX=MAX0(NSIGDS+5,NX) RFO 400 Y=ABS(X(1)) RFO 410 IF (Y.LE.0.) Y=1.0 RFO 420 Y1=Y RFO 430 Y2=Y RFO 440 IF (N.LT.1) N=1 RFO 445 DO 30 I=1,N RFO 450 Y=ABS(X(I)) RFO 460 IF (Y.LE.0.) Y=1.0 RFO 470 IF (Y.LT.Y1) Y1=Y RFO 480 IF (Y.GT.Y2) Y2=Y RFO 490 30 CONTINUE RFO 495 MMIN=FLOG10(Y1) RFO 500 IF (Y1.LT.1.) MMIN=MMIN-1 RFO 510 MMAX=FLOG10(Y2) RFO 520 IF (Y2.LT.1.) MMAX=MMAX-1 RFO 530 Z=Y1 RFO 540 LL=Z*10.D0**(NSIGDS-MMIN)+5.0D0 RFO 550 IF (LL.GE.10**(NSIGDS+1)) MMIN=MMIN+1 RFO 560 IF (LL.LT.10**NSIGDS) MMIN=MMIN-1 RFO 570 Z=Y2 RFO 580 LL=Z*10.D0**(NSIGDS-MMAX)+5.0D0 RFO 590 IF (LL.GE.10**(NSIGDS+1)) MMAX=MMAX+1 RFO 600 IF (LL.LT.10**NSIGDS) MMAX=MMAX-1 RFO 610 NDECS=NSIGDS-MMIN-1 RFO 620 NDECS=MAX0(0,NDECS) RFO 630 NWIDTH=MMAX+3+NDECS RFO 640 IF (MMAX.LT.0) NWIDTH=NDECS+2 RFO 650 IF (NWIDTH.LE.NWMAX) GO TO 40 RFO 660 NDECS=MAX0(NDECS,NSIGDS+2) RFO 670 NDECS=MIN0(NDECS,NWMAX-3) RFO 680 NWIDTH=NWMAX RFO 690 40 IF (NDECS.LT.0) NDECS=0 RFO 700 ND=NDECS RFO 710 NW=NWIDTH RFO 720 RETURN RFO 730 C ***** RFO 740 C FXFORM SUBROUTINE RFO 750 C SUBROUTINE FXFORM ALLOWS PRINTING OF REAL NUMBERS X IN FIXED RFO 760 C FORMAT WITH DECIMAL POINT IN CONSTANT POSITION. NWIDTH = WIDTH OFRFO 770 C FIELD, NDECS = NUMBER OF PLACES TO RIGHT OF DECIMAL POINT, X IS RFO 780 C THE NUMBER, ARRAY IS THE VECTOR WHERE X IS RETURNED TO BE PRINTED RFO 790 C ACCORDING TO A FORMAT, NSIGDS = NUMBER OF DIGITS GIVEN WITH BLANKSRFO 800 C ON THE RIGHT, NBLANK IS THE NUMBER OF BLANKS TO BE PUT ON THE RFO 810 C LEFT OF THE FIELD. IF X IS TOO LARGE OR TOO SMALL IT IS RETURNED RFO 820 C AS A FLOATING POINT NUMBER. ARRAY MUST BE DIMENSIIONED. RFO 830 C A PERIOD IS NOT GIVEN IF X IS GREATER THAN OR EQUAL TO 10**NSIGDS RFO 840 C ZERO IS WRITTEN 0. RFO 850 C IF NDECS=NWIDTH, BLANKS ARE RETURNED RFO 860 C SUBROUTINE MAY BE USED IN CONJUCTION WITH SUBROUTINE FXARGS. RFO 870 C IF NSIGDS GT 8, IT IS SET = TO 8, IF LT 1 SET = TO 1. RFO 880 C NWIDTH IS ADJUSTED IF NECESSARY SO THAT IT IS GE NDECS+2, RFO 890 C GE NSIGDS+2 IF FIXED AND GE NSIGDS+5 IF FLOATING RFO 900 C REFERENCE *** SEL NOTE N-68-3, SEPTEMBER, 1968. RFO 910 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 2/ 7/69. RFO 920 C ***** RFO 930 50 NWIDTH=NW RFO 940 GO TO 70 RFO 950 60 NWIDTH=MAX0(NW,NSIGDS+2) RFO 960 70 NDECS=MAX0(0,ND) RFO 970 IF (NWIDTH.LT.NDECS) NWIDTH=NDECS+2 RFO 980 NB=MAX0(0,NB) RFO 990 IF(NC.NE.0) NC=1 RFO 985 NBLANK=NB-(NB/2)*NC RFO 990 MF=0 RFO 995 Y=ABS(XVAL) RFO1000 80 NDIFF=NWIDTH-NDECS RFO1010 NWMAX=NWIDTH+NBLANK RFO1020 NPONE=NDIFF+NBLANK RFO1030 IEND=NWIDTH+NB RFO1045 DO 90 I=1,IEND RFO1050 90 ARRAY(I)=BLANK RFO1060 IF (NDECS.EQ.NWIDTH) RETURN RFO1070 IF (Y.GT.0.) GO TO 110 RFO1080 C XVAL=0. IS SPECIAL CASE UNLESS FIXED OR FLOATING RFO1090 IF (NX.GE.0) GO TO 100 RFO1100 C FIXED RFO1110 M=0 RFO1120 GO TO 130 RFO1130 100 IF (NDECS.NE.0) ARRAY(NPONE)=PERIOD RFO1140 ARRAY(NPONE-1)=C(1) RFO1150 RETURN RFO1160 110 M=FLOG10(Y) RFO1170 IF (Y.LT.1.) M=M-1 RFO1180 Z=Y RFO1190 Z = Z*10.D0**(NSIGDS-M) RFO1193 X1 = Z RFO1196 LL1 = X1 RFO1200 X2 = Z - DBLE(X1) RFO1205 LL2 = X2 RFO1210 LL = LL1 + LL2 + 5 RFO1215 IF (LL.LT.10**(NSIGDS+1)) GO TO 120 RFO1220 M=M+1 RFO1230 LL=LL/10 RFO1240 GO TO 130 RFO1250 120 IF (LL.GE.10**NSIGDS) GO TO 130 RFO1260 M=M-1 RFO1270 LL=10*LL RFO1280 130 IF (NX.EQ.0) GO TO 170 RFO1290 IF (N.LT.0) GO TO 180 RFO1300 C FIXED RFO1310 IF (M.LT.NDIFF-2) GO TO 150 RFO1320 IF (M.EQ.NDIFF-2.AND.XVAL.GE.0.) GO TO 150 RFO1330 NSIGDS=MAX0(0,NWIDTH-5) RFO1340 IF (NSIGDS.GT.0) GO TO 180 RFO1350 C PUT IN ASTERISKS RFO1360 DO 140 I=1,NWIDTH RFO1370 IRVSP=I+NBLANK RFO1375 140 ARRAY(IRVSP)=CASTER RFO1380 RETURN RFO1390 150 NSIGDS=MIN0(8,NDECS+M+1) RFO1400 NSIGDS=MAX0(0,NSIGDS) RFO1410 LL=(LL-5)/(10**(8-NSIGDS))+5 RFO1420 IF (NSIGDS.GT.0) GO TO 170 RFO1430 IF (XVAL.LT.0.0) ARRAY(NPONE-1)=CMINUS RFO1440 DO 160 I=NPONE,NWMAX RFO1450 160 ARRAY(I)=C(1) RFO1460 ARRAY(NPONE)=PERIOD RFO1470 IF(NDECS+1.EQ.(-M).AND.LL.GT.10) ARRAY(NWMAX)=C(2) RFO1480 RETURN RFO1490 170 MREAL=0 RFO1500 IF (M.GE.NSIGDS-1-NDECS.AND.M.LT.NDIFF-2) GO TO 190 RFO1510 IF (M.EQ.NDIFF-2.AND.XVAL.GT.0.) GO TO 190 RFO1520 C FLOATING RFO1530 180 MREAL=M RFO1540 M=0 RFO1550 MF=1 RFO1560 Y=Y*10.**(-MREAL) RFO1570 190 IF (M.LT.NSIGDS.AND.NDECS.NE.0) ARRAY(NPONE)=PERIOD RFO1580 NINT=NPONE-1-M RFO1590 IF (M.LT.0) NINT=NINT+1 RFO1600 NEND=NINT+NSIGDS-1 RFO1610 IF (M.GE.0.AND.M.LT.NSIGDS-1) NEND=NEND+1 RFO1620 DO 200 J=NINT,NEND RFO1630 I=NEND+NINT-J RFO1640 IF (I.EQ.NPONE) GO TO 200 RFO1650 LL=LL/10 RFO1660 NN=MOD(LL,10) RFO1670 ARRAY(I)=C(NN+1) RFO1680 200 CONTINUE RFO1690 IF (MF.EQ.0) GO TO 220 RFO1700 C PUT IN EXPONENT FOR FLOATING POINT NUMBER RFO1710 IF (NWIDTH.GE.NSIGDS+5) GO TO 210 RFO1720 NWIDTH=NSIGDS+5 RFO1730 GO TO 80 RFO1740 210 IF (MREAL.LT.0) ARRAY(NEND+1)=CMINUS RFO1750 IF (MREAL.GE.0) ARRAY(NEND+1)=CPLUS RFO1760 MREALA=IABS(MREAL) RFO1770 M1=MREALA/10 RFO1780 M2=MOD(MREALA,10) RFO1790 ARRAY(NEND+2)=C(M1+1) RFO1800 ARRAY(NEND+3)=C(M2+1) RFO1810 220 IF (XVAL.LT.0..AND.M.GE.0) ARRAY(NINT-1)=CMINUS RFO1820 IF (XVAL.LT.0..AND.M.LT.0) ARRAY(NPONE-1)=CMINUS RFO1830 IF(M.GE.(-1)) GO TO 240 RFO1840 I1=NPONE+1 RFO1850 I2=NINT-1 RFO1860 DO 230 I=I1,I2 RFO1870 230 ARRAY(I)=C(1) RFO1880 RETURN RFO1890 C PUT IN NON-SIGNIFICANT ZEROS RFO1900 240 IF (M.LT.NSIGDS.OR.MF.NE.0) RETURN RFO1910 I1=NINT+NSIGDS RFO1920 I2=NPONE-1 RFO1930 DO 250 I=I1,I2 RFO1940 250 ARRAY(I)=C(1) RFO1950 RETURN RFO1960 END RFO1970 SUBROUTINE RNDOWN RND 10 C VERSION 5.00 RNDOWN 5/15/70 RND 20 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST RND 30 COMMON /BLOCKX/ INDEX(6,8),LEVEL RND 40 C RND 50 C IF AN ERROR IS MADE IN A STORED STATEMENT, THIS ROUTINE PRINTS RND 60 C OUT EXACTLY WHEN AND WHERE IT OCCURRED. RND 70 C RND 80 A=FLOAT(INDEX(6,LEVEL))/10. RND 90 WRITE (ISCRAT,50) A RND 100 N=LEVEL-1 RND 110 10 IF (N) 40,30,20 RND 120 20 A=FLOAT(INDEX(6,N))/10. RND 130 WRITE (ISCRAT,60) INDEX(5,N+1),INDEX(4,N+1),A RND 140 N=N-1 RND 150 GO TO 10 RND 160 30 WRITE (ISCRAT,70) INDEX(5,1),INDEX(4,1) RND 170 40 RETURN RND 180 C RND 190 50 FORMAT (31H IN COMMAND AT STATEMENT NUMBER,F6.1,47X) RND 200 60 FORMAT (10H CYCLE NO.,I4,3H OF,I4,24H OF PERFORM AT STATEMENT,F6.1RND 210 1,23X) RND 220 70 FORMAT (10H CYCLE NO.,I4,3H OF,I4,31H OF EXTERNAL PERFORM STATEMENRND 230 1T.,32X) RND 240 END RND 250 SUBROUTINE RNJBK (RNO,NSTART,NFINSH) RNJ 10 C VERSION 5.00 RNJBK 5/15/70 RNJ 20 DATA M,FLM/8192,8192./ RNJ 30 C 8192=2**13 RNJ 40 C JB KRUSKAL (1969) ACM, 12, 93-94 RNJ 50 C ***** RNJ 60 C RETURNS RANDOM NUMBER (0,1) IN RNJBK. RNJ 70 C SET NSTART=1 TO START AT BEGINNING, OTHERWISE PREVIOUS NFINSH. RNJ 80 C RETURNS NFINSH FOR LAST NUMBER GENERATED. RNJ 90 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 3/24/69 RNJ 100 C ***** RNJ 110 K=NSTART RNJ 120 DO 10 I=1,3 RNJ 130 10 K=MOD(5*K,M) RNJ 140 RNO=FLOAT(K)/FLM RNJ 150 NFINSH=K RNJ 160 RETURN RNJ 170 END RNJ 180 SUBROUTINE RPRINT RPR 10 C VERSION 5.00 RPRINT 5/15/70 RPR 20 C ***************************************************************** RPR 30 C RPRINT COLS ++, ++, ... ++ (MAXIMUM OF 50 COLS) (NO OF SD IS 8) RPR 40 C RPRINT COLS ++, ++, ... ++ WITH ** SIGNIFICANT DIGITS (49 COL MAX)RPR 50 C RPRINT COLS ++ .. ++ WITH ** SD, ... (NWMAX=13, NWIDTH+NBLANK=15)RPR 60 C RPR 70 C RPRINT ** COLS, COL++ WITH ,, SD ... (NWMAX=22, NBLANK=3) RPR 80 C RPRINT ** COLS, ++ WITH ,, SD AND NWMAX = ,,, ... (NBLANK=3) RPR 90 C RPRINT ** COLS, ++ WITH ,, SD NWMAX ,, NBLANK ,, ... RPR 100 C ***** RPR 110 C FLOATING 1PEW,D IS OBTAINED IN LAST TOW OPTIONS IF NWMAX=0. RPR 120 C W=NSIGDS+5 AND D=NSIGDS-1 RPR 130 C FIXED FW.D IS OBTAINED IN LAST TWO OPTIONS IF NWMAX LT 0. RPR 140 C W=-NWMAX AND D=NSIGDS RPR 150 C IW IS OBTAINED IN LAST TWO OPTIONS IF NSIGDS=0 AND NWMAX=-W. RPR 160 C ******************************************************************RPR 170 C REPLACE TRAILING ZEROS BY BLANKS IF COUNT LT NRMAX RPR 180 C IF COLUMN CONTAINS ALL ZEROS AND FIRST ARGUMENT IS A COLUMN NUMBERRPR 190 C NO COLUMN HEADING IS GIVEN RPR 200 C IF FIRST ARGUMENT IS NOT A COLUMN NUMBER (1) NO HEADING IF WIDTH RPR 210 C LESS THAN 6, (2) COL NO IF 6 LE WIDTH LT 12, (0) COLUMN XXX. IFRPR 220 C WIDTH GREATER THAN OR RQUAL TO 12. RPR 230 C IF NUMBER IS FLOATED ASTERISK IS PUT TO RIGHT OF FIELD. RPR 240 C NUMBERS ARE PRINTED IN BLOCKS OF 5 IF NRMAX IS LESS THAN 49. RPR 250 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/17/69. RPR 260 C ******************************************************************RPR 270 COMMON /ABCDEF/ L(48) RPR 280 COMMON /BLOCRC/ NRC,RC(12600) RPR 290 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NRPR 300 1ARGS,VWXYZ(8),NERROR RPR 310 DIMENSION ARGS(100) RPR 320 EQUIVALENCE (ARGS(1),RC(12501)) RPR 330 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG RPR 340 COMMON /SCRAT/ NS,NS2,A(13500) RPR 350 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH RPR 360 COMMON /FMAT/ IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) RPR 370 C ******************************************************************RPR 380 DIMENSION NWIDTH(100), NDECS(100), NBLANK(100), IRGS(100), NCOUNT(RPR 390 1100), NWMAX(100), NSIGDS(100), AL(48), NF(100), NWM(100) RPR 400 EQUIVALENCE (NWIDTH(1),A(1001)), (NDECS(1),A(1101)), (NBLANK(1),A(RPR 410 11201)), (IRGS(1),A(1301)), (NCOUNT(1),A(1401)), (NWMAX(1),A(1601))RPR 420 2, (NSIGDS(1),A(1701)), (AL(1),L(1)), (NF(1),A(1801)), (NWM(1),A(19RPR 430 301)) RPR 440 C ***** RPR 450 C IRGS(I) NEEDS FOR HEADS BECAUSE CHKCOL IS USED RPR 460 C LINES 20 TO 70 DO ERROR CHECKING RPR 470 IF (L1.NE.6) GO TO 20 RPR 480 NARGS=NARGS-1 RPR 490 IF (KIND(1).EQ.1) GO TO 50 RPR 500 IF (IARGS(1).LE.0.OR.IARGS(1).GT.NROW) GO TO 60 RPR 510 NRJ=IARGS(1)-1 RPR 520 IF (NARGS.LT.1) GO TO 30 RPR 530 DO 10 I=1,NARGS RPR 540 KIND(I)=KIND(I+1) RPR 550 IARGS(I)=IARGS(I+1) RPR 560 10 ARGS(I)=ARGS(I+1) RPR 570 20 IF (NARGS.GT.0) GO TO 40 RPR 580 30 CALL ERROR (10) RPR 590 GO TO 400 RPR 600 40 IF (NRMAX.GT.0) GO TO 70 RPR 610 CALL ERROR (9) RPR 620 GO TO 400 RPR 630 50 CALL ERROR (3) RPR 640 GO TO 400 RPR 650 60 CALL ERROR (11) RPR 660 GO TO 400 RPR 670 C ALL ARGUMENTS ARE INTEGERS. RPR 680 70 NPAR=1 RPR 690 IF (KIND(1).EQ.1.OR.KIND(NARGS).EQ.1) GO TO 90 RPR 700 DO 80 I=1,NARGS RPR 710 NSIGDS(I)=8 RPR 720 NF(I)=1 RPR 730 NWM(I)=0 RPR 740 NWMAX(I)=13 RPR 750 80 IRGS(I)=IARGS(I) RPR 760 CALL CHKCOL (J) RPR 770 IF (J.NE.0) GO TO 50 RPR 780 NA=NARGS RPR 790 GO TO 160 RPR 800 C LAST ARGUMENT IS NOT AN INTEGER, NSIGDS IS GIVEN. RPR 810 90 IF (KIND(1).EQ.1) GO TO 130 RPR 820 LL=0 RPR 830 DO 100 I=1,NARGS RPR 840 IF (KIND(I).EQ.0) GO TO 100 RPR 850 LL=LL+1 RPR 860 ARGS(LL)=ARGS(I) RPR 870 100 CONTINUE RPR 880 NL=0 RPR 890 DO 120 I=1,NARGS RPR 900 IF (KIND(I).EQ.0) GO TO 110 RPR 910 NL=NL+1 RPR 920 GO TO 120 RPR 930 110 I2=I-NL RPR 940 IARGS(I2)=IARGS(I) RPR 950 NSIGDS(I2)=ARGS(NL+1) RPR 960 NWMAX(I2)=13 RPR 970 NF(I2)=1 RPR 980 NWM(I2)=0 RPR 990 IRGS(I2)=IARGS(I2) RPR1000 120 KIND(I2)=0 RPR1010 NA=NARGS-NL RPR1020 NARGS=NA RPR1030 CALL CHKCOL (J) RPR1040 IF (J.NE.0) GO TO 50 RPR1050 GO TO 160 RPR1060 C FIRST ARGUMENT IS NOT AN INTEGER, PARAMETERS ARE GIVEN. RPR1070 130 IF (ARGS(1).LE.0.) GO TO 50 RPR1080 IRVSP=ARGS(1) RPR1085 NPAR=(NARGS-1)/IRVSP RPR1090 IF (NPAR.NE.2.AND.NPAR.NE.3.AND.NPAR.NE.4) GO TO 30 RPR1100 A(1)=ABS(FLOAT(NPAR)*ARGS(1)+1.-FLOAT(NARGS)) RPR1110 IF (A(1).GT.0.0) GO TO 30 RPR1120 NA=ARGS(1) RPR1130 DO 150 I=1,NA RPR1140 ISUB=2+NPAR*(I-1) RPR1150 IRGS(I)=IARGS(ISUB) RPR1160 IARGS(I)=IARGS(ISUB) RPR1170 CALL ADRESS (ISUB,IARGS(I)) RPR1180 IF (IARGS(I).LE.0) GO TO 50 RPR1190 NSIGDS(I)=IARGS(ISUB+1) RPR1200 NWMAX(I)=IARGS(ISUB+2)*(NPAR/3)+22*(1-NPAR/3) RPR1210 NF(I)=1 RPR1220 NWM(I)=0 RPR1230 IF (NWMAX(I).GT.0) GO TO 150 RPR1240 IF (NWMAX(I).LT.0) GO TO 140 RPR1250 C FLOATING RPR1260 NWIDTH(I)=NSIGDS(I)+5 RPR1270 NDECS(I)=NSIGDS(I)+2 RPR1280 NF(I)=-1 RPR1290 NWM(I)=-1 RPR1300 GO TO 150 RPR1310 C FIXED RPR1320 140 NWIDTH(I)=-NWMAX(I) RPR1330 NDECS(I)=NSIGDS(I) RPR1340 NSIGDS(I)=8 RPR1350 NWM(I)=-1 RPR1360 150 NBLANK(I)=IARGS(ISUB+3)*(NPAR/4)+3*(1-NPAR/4) RPR1370 IF(NPAR.EQ.4.AND.NBLANK(1).LT.1) NBLANK(1)=1 RPR1375 C LINES 160 TO 240 INITIALIZE AND CALL FXFARG RPR1380 160 IF (NERROR.NE.0) GO TO 400 RPR1390 IF (L1.NE.6) GO TO 210 RPR1400 I1=1 RPR1405 I2=0 RPR1410 165 LL=1 RPR1415 I2=MIN0(8,NA)+I2 RPR1420 NA=NA-8 RPR1425 DO 200 I=I1,I2 RPR1430 K=IARGS(I)+NRJ RPR1440 IF (NWMAX(I).LE.0) GO TO 170 RPR1450 CALL RFORMT (RC(K),1,NSIGDS(I),NWIDTH(I),NDECS(I),NWMAX(I),A(1),A(RPR1460 11),0,0) RPR1470 170 IF (NPAR.EQ.1) NBLANK(I)=15-NWIDTH(I) RPR1480 CALL RFORMT (A,NF(I),NSIGDS(I),NWIDTH(I),NDECS(I),NWM(I),RC(K),A(LRPR1490 1L),NBLANK(I),0) RPR1500 LL=LL+NWIDTH(I)+NBLANK(I) RPR1510 IF (NWIDTH(I).LT.NWMAX(I).OR.NWMAX(I).LE.0) GO TO 200 RPR1520 IF (NBLANK(I).EQ.0) GO TO 200 RPR1530 I5=LL-NDECS(I)+NSIGDS(I)-1 RPR1540 IF (A(I5)-AL(39)) 180,190,180 RPR1550 180 IF (A(I5)-AL(40)) 200,190,200 RPR1560 190 K=LL-NWIDTH(I)-1 RPR1570 A(K)=AL(41) RPR1580 200 CONTINUE RPR1590 NL=MIN0(LL-1,120) RPR1600 WRITE (IPRINT,410) (A(I),I=2,NL) RPR1610 IF(NA.LE.0) GO TO 400 RPR1615 I1=I2+1 RPR1620 GO TO 165 RPR1625 210 I1=1 RPR1630 DO 240 I=1,NA RPR1640 K=IARGS(I) RPR1650 C DETERMINE COUNT OF COL I RPR1660 NCOUNT(I)=NRMAX RPR1670 DO 220 J=1,NRMAX RPR1680 K1=K+NRMAX-J RPR1690 IF (ABS(RC(K1)).GT.0.) GO TO 230 RPR1700 220 NCOUNT(I)=NCOUNT(I)-1 RPR1710 230 IF (NCOUNT(I).GT.NRMAX-3) NCOUNT(I)=NRMAX RPR1720 IF (NCOUNT(I).EQ.0) NWIDTH(I)=NWMAX(I) RPR1730 IF (NCOUNT(I).EQ.0) GO TO 240 RPR1740 IF (NWMAX(I).LE.0) GO TO 240 RPR1750 CALL RFORMT (RC(K),NCOUNT(I),NSIGDS(I),NWIDTH(I),NDECS(I),NWMAX(I)RPR1760 1,A(1),A(1),0,0) RPR1770 240 IF (NPAR.EQ.1) NBLANK(I)=15-NWIDTH(I) RPR1780 C LINE 250 TO 390 CALL FXFORM AND PRINT IN READABLE FORMAT RPR1790 250 IF (L1.NE.8) CALL PAGE (4) RPR1800 I4=0 RPR1810 DO 260 I=I1,NA RPR1820 I4=I4+NWIDTH(I)+NBLANK(I) RPR1830 IF(I4.LE.120) GO TO 260 RPR1840 I4=I-I1 RPR1850 GO TO 270 RPR1860 260 IF (I.EQ.NA) I4=NA-I1+1 RPR1870 270 I2=I4+I1-1 RPR1880 NARGS=I2-I1+1 RPR1890 C FROM HERE TO 290 PUTS IN COL HEADING IF FIRST ARG NOT A COL NO. RPR1900 IF (NPAR.EQ.1) GO TO 290 RPR1910 CALL RFORMT (A,1,1,119,119,0,1.0,A(1),0,0) RPR1920 LL=1 RPR1930 DO 280 I=I1,I2 RPR1940 LL=LL+NWIDTH(I)+NBLANK(I) RPR1950 IF (NWIDTH(I).LT.6.OR.NCOUNT(I).EQ.0) GO TO 280 RPR1960 A(200)=IRGS(I) RPR1970 I5=FLOG10(A(200))+1.0 RPR1980 CALL RFORMT (A,1,I5,6,0,0,A(200),A(LL-6),0,0) RPR1990 A(LL-1)=AL(45) RPR2000 IF (NWIDTH(I).LT.12) GO TO 280 RPR2010 A(LL-12)=AL(13) RPR2020 A(LL-11)=AL(25) RPR2030 A(LL-10)=AL(22) RPR2040 A(LL-9)=AL(31) RPR2050 A(LL-8)=AL(23) RPR2060 A(LL-7)=AL(24) RPR2070 280 CONTINUE RPR2080 WRITE (IPRINT,410) (A(I),I=2,LL) RPR2090 GO TO 320 RPR2100 290 IF (L1.EQ.8) GO TO 325 RPR2110 CALL HEADS (IRGS(I1),I4,0,1) RPR2120 DO 310 I=I1,I2 RPR2130 IF (NCOUNT(I).GT.0) GO TO 310 RPR2140 I5=12*(I-I1)+1 RPR2150 DO 300 I6=1,12 RPR2160 LHEAD(I5)=L(45) RPR2170 300 I5=I5+1 RPR2180 310 CONTINUE RPR2190 I5=12*I4 RPR2200 WRITE (IPRINT,420) (LHEAD(I6),I6=1,I5) RPR2210 320 WRITE (IPRINT,410) RPR2220 325 DO 390 J=1,NRMAX RPR2230 LL=1 RPR2240 DO 350 I=I1,I2 RPR2250 K=IARGS(I)+J-1 RPR2260 C PRINT BLANKS IF NCOUNT(I) LT NRMAX RPR2270 IF (J.GT.NCOUNT(I)) NDECS(I)=NWIDTH(I) RPR2280 CALL RFORMT (A,NF(I),NSIGDS(I),NWIDTH(I),NDECS(I),NWM(I),RC(K),A(LRPR2290 1L),NBLANK(I),0) RPR2300 LL=LL+NWIDTH(I)+NBLANK(I) RPR2310 IF (NWIDTH(I).LT.NWMAX(I).OR.NWMAX(I).LE.0) GO TO 350 RPR2320 IF (NBLANK(I).EQ.0) GO TO 350 RPR2330 C PUT IN ASTERISK IF READABLE RETURNS FLOATING RPR2340 I5=LL-NDECS(I)+NSIGDS(I)-1 RPR2350 IF (A(I5)-AL(39)) 330,340,330 RPR2360 330 IF (A(I5)-AL(40)) 350,340,350 RPR2370 340 K=LL-NWIDTH(I)-1 RPR2380 A(K)=AL(41) RPR2390 350 CONTINUE RPR2400 C I=2 COMPENSATES FOR 1X RPR2410 NL=LL-1 RPR2420 WRITE (IPRINT,410) (A(I),I=2,NL) RPR2430 C PRINT IN BLOCKS OF FIVE RPR2440 IF(J.EQ.NRMAX) GO TO 355 RPR2445 IF (MOD(J,5).EQ.0.AND.NRMAX.LE.48) WRITE (IPRINT,410) RPR2450 IF (MOD(J,10).EQ.0.AND.NRMAX.GT.48) WRITE (IPRINT,410) RPR2460 C CALL NEW PAGE IF NRMAX GT 50 RPR2470 355 IF(MOD(J,50).NE.0) GO TO 390 RPR2480 IF (J.EQ.NRMAX) GO TO 390 RPR2485 IF (L1.NE.8) CALL PAGE (4) RPR2490 IF(L1.EQ.8) GO TO 390 RPR2500 I5=12*I4 RPR2510 IF (NPAR.GT.1) GO TO 360 RPR2520 WRITE (IPRINT,420) (LHEAD(I6),I6=1,I5) RPR2530 GO TO 380 RPR2540 C FROM HERE TO 380 PUTS IN COL HEADING IF FIRST ARG NOT A COL NO. RPR2550 360 CALL RFORMT (A,1,1,119,119,0,1.0,A(1),0,0) RPR2560 LL=1 RPR2570 DO 370 I=I1,I2 RPR2580 LL=LL+NWIDTH(I)+NBLANK(I) RPR2590 IF (NWIDTH(I).LT.6.OR.NCOUNT(I).EQ.0) GO TO 370 RPR2600 A(200)=IRGS(I) RPR2610 I5=FLOG10(A(200))+1.0 RPR2620 CALL RFORMT (A,1,I5,6,0,0,A(200),A(LL-6),0,0) RPR2630 A(LL-1)=AL(45) RPR2640 IF (NWIDTH(I).LT.12) GO TO 370 RPR2650 A(LL-12)=AL(13) RPR2660 A(LL-11)=AL(25) RPR2670 A(LL-10)=AL(22) RPR2680 A(LL-9)=AL(31) RPR2690 A(LL-8)=AL(23) RPR2700 A(LL-7)=AL(24) RPR2710 370 CONTINUE RPR2720 WRITE (IPRINT,410) (A(I),I=2,LL) RPR2730 380 WRITE (IPRINT,410) RPR2740 390 CONTINUE RPR2750 C ADJUST FOR MORE THAN 8 COLUMNS RPR2760 IF (I2.EQ.NA) GO TO 400 RPR2770 IF(L1.NE.8) GO TO 145 RPR2772 WRITE(IPRINT, 410) RPR2778 145 I1=I2+1 RPR2780 GO TO 250 RPR2790 400 RETURN RPR2810 C RPR2820 410 FORMAT (1X,119A1) RPR2830 420 FORMAT (8(3X,12A1)) RPR2840 END RPR2850 SUBROUTINE SELECT SEL 10 C VERSION 5.00 SELECT 5/15/70 SEL 20 COMMON /BLOCRC/ NRC,RC(12600) SEL 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSEL 40 1ARGS,VWXYZ(8),NERROR SEL 50 DIMENSION ARGS(100) SEL 60 EQUIVALENCE (ARGS(1),RC(12501)) SEL 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG SEL 80 COMMON /SCRAT/ NS,NS2,A(13500) SEL 90 C SEL 100 C ITYPE=1 SELECT IN COL ++ VALUES APPROX COL ++ TO WITHIN **, SEL 110 C STORE IN COL ++ SEL 120 C ITYPE=1 SELECT IN COL ++ VALUES APPROX COL ++ TO WITHIN **, SEL 130 C STORE IN COL ++ TO COL ++ SEL 140 C ITYPE=1 SELECT IN COL ++ VALUES APPROX COL ++ TO WITHIN ++, SEL 150 C STORE ++ TO ++, STORE NUMBER FALLING WITHIN TOL IN COSEL 160 C SEL 170 C ITYPE=2 SEARCH IN COL ++ FOR NUMBERS IN ++, TRANSFER CORRESP VSEL 180 C FROM ++ INTO ++, ++ INTO ++, ETC SEL 190 C SEL 200 C ITYPE=3 CENSOR COL ++ FOR $$, REPLACING BY $$, STORE IN COL ++SEL 210 C SEL 220 C ITPE=5 MATCH COLUMN (C) WITH (E), EXTRACT (E), PUT IN COLUMN (C)SEL 230 C WRITTEN BY DAVID HOGBEN SEL, NBS. 2/28/70. (CENSOR REVISED) SEL 240 C SEL 250 GO TO (10,100,130,40,130), L2 SEL 260 10 IF (KIND(3)) 50,20,50 SEL 270 20 K=3 SEL 280 30 CALL ERROR (K) SEL 290 40 RETURN SEL 300 50 IARGS(3)=IARGS(2) SEL 310 KIND(3)=0 SEL 320 IF (NARGS-4) 60,70,80 SEL 330 60 K=10 SEL 340 GO TO 30 SEL 350 65 K=11 SEL 360 GO TO 30 SEL 370 70 IARGS(5)=IARGS(4) SEL 380 NARGS=NARGS+1 SEL 390 KIND(5)=KIND(4) SEL 400 80 IF (NARGS-6) 90,90,60 SEL 410 90 IF (IARGS(4)-IARGS(5)) 230,230,20 SEL 420 100 IF (NARGS-4) 60,110,110 SEL 430 110 IF (2*(NARGS/2)-NARGS) 60,120,60 SEL 440 120 CALL CHKCOL(J) SEL 450 IF (J) 20,200,20 SEL 460 130 IF (NARGS-4) 60,140,60 SEL 470 140 CALL ADRESS (1,I1) SEL 480 IF (I1) 20,65,150 SEL 490 150 CALL ADRESS (2,I2) SEL 500 IF (I2) 160,65,170 SEL 510 160 I2 = -I2 SEL 520 170 CALL ADRESS (3,I3) SEL 530 IF (I3) 180,65,190 SEL 540 180 I3 = -I3 SEL 550 190 CALL ADRESS (4,I4) SEL 560 IF (I4) 20,65,200 SEL 570 200 IF (NRMAX) 210,210,220 SEL 580 210 K = 9 SEL 590 GO TO 30 SEL 555 220 IF (NERROR.NE.0) GO TO 40 SEL 560 GO TO (250,450,520,40,520), L2 SEL 565 230 IF (IARGS(5)-IARGS(4)-NRMAX+1) 120,120,240 SEL 570 240 IARGS(5)=IARGS(4)+NRMAX-1 SEL 580 GO TO 120 SEL 590 C SELECT SEL 600 250 DO 280 I=1,NRMAX SEL 610 L=IARGS(1)+I-1 SEL 620 K=IARGS(2)+I-1 SEL 630 J=IARGS(4)+I-1 SEL 640 M=NRMAX+I SEL 650 A(I)=RC(K) SEL 660 A(M)=RC(L) SEL 670 260 RC(J)=0.0 SEL 680 IF (J-I-IARGS(5)+1) 270,280,280 SEL 690 270 J=NROW+J SEL 700 GO TO 260 SEL 710 280 CONTINUE SEL 720 ARG3=ABS(ARGS(3)) SEL 730 DO 440 I=1,NRMAX SEL 740 K=NRMAX+1 SEL 750 L=2*NRMAX SEL 760 M=3*NRMAX SEL 770 N=4*NRMAX SEL 780 I1=IARGS(4)+I-1 SEL 790 J1=IARGS(6)+I-1 SEL 800 DO 300 J=K,L SEL 810 AT=ABS(A(I)-A(J)) SEL 820 IF (ARG3-AT) 300,290,290 SEL 830 290 M=M+1 SEL 840 A(M)=AT SEL 850 N=N+1 SEL 860 A(N)=A(J) SEL 870 300 CONTINUE SEL 880 IF (M-3*NRMAX-1) 310,330,350 SEL 890 310 IF (NARGS-5) 440,440,320 SEL 900 320 RC(J1)=0.0 SEL 910 GO TO 440 SEL 920 330 RC(I1)=A(N) SEL 930 IF (NARGS-5) 440,440,340 SEL 940 340 RC(J1)=1.0 SEL 950 GO TO 440 SEL 960 350 M1=3*NRMAX+2 SEL 970 360 K2=0 SEL 980 DO 380 J=M1,M SEL 990 IF (A(J)-A(J-1)) 370,380,380 SEL1000 370 AT=A(J) SEL1010 A(J)=A(J-1) SEL1020 A(J-1)=AT SEL1030 N=J+NRMAX SEL1040 AT=A(N) SEL1050 A(N)=A(N-1) SEL1060 A(N-1)=AT SEL1070 K2=K2+1 SEL1080 380 CONTINUE SEL1090 IF (K2) 390,390,360 SEL1100 390 N=4*NRMAX+1 SEL1110 400 RC(I1)=A(N) SEL1120 I1=I1+NROW SEL1130 N=N+1 SEL1140 IF (N-M-NRMAX) 410,410,420 SEL1150 410 IF (I1-I-IARGS(5)+1) 400,400,420 SEL1160 420 IF (NARGS-5) 440,440,430 SEL1170 430 RC(J1)=M-3*NRMAX SEL1180 440 CONTINUE SEL1190 GO TO 40 SEL1200 C SEARCH SEL1210 450 I1=NARGS-1 SEL1220 DO 470 I=1,NRMAX SEL1230 K=IARGS(1)+I-1 SEL1240 L=IARGS(2)+I-1 SEL1250 M=NRMAX+I SEL1260 A(I)=RC(L) SEL1270 A(M)=RC(K) SEL1280 J1=2 SEL1290 DO 460 N=3,I1,2 SEL1300 L=J1*NRMAX+I SEL1310 M=IARGS(N)+I-1 SEL1320 A(L)=RC(M) SEL1330 460 J1=J1+1 SEL1340 DO 470 N=4,NARGS,2 SEL1350 M=IARGS(N)+I-1 SEL1360 470 RC(M)=0.0 SEL1370 K=NRMAX+1 SEL1380 L=2*NRMAX SEL1390 DO 510 I=1,NRMAX SEL1400 AT=ABS(A(I)/1.E8) SEL1410 DO 500 J=K,L SEL1420 IF (ABS(A(I)-A(J))-AT) 480,480,500 SEL1430 480 J1=1 SEL1440 DO 490 N=4,NARGS,2 SEL1450 M=IARGS(N)+I-1 SEL1460 I1=J1*NRMAX+J SEL1470 RC(M)=A(I1) SEL1480 490 J1=J1+1 SEL1490 GO TO 510 SEL1500 500 CONTINUE SEL1510 510 CONTINUE SEL1520 GO TO 40 SEL1530 C CENSOR OR MATCH SEL1540 520 DO 580 I=1,NRMAX SEL1550 IF (RC(I1)-RC(I2)) 540,530,560 SEL1560 530 RC(I4) = RC(I3) SEL1570 GO TO 570 SEL1580 540 IF (L2-4) 530,40,570 SEL1590 560 IF (L2.EQ.5) GO TO 570 SEL1600 RC(I4) = RC(I1) SEL1610 570 I1 = I1+1 SEL1620 IF (KIND(2).EQ.0) I2=I2+1 SEL1630 IF (KIND(3).EQ.0) I3=I3+1 SEL1640 580 I4 = I4+1 SEL1650 GO TO 40 SEL1660 END SEL1670 SUBROUTINE SETQ STQ 10 C VERSION 5.00 SETQ 5/15/70 STQ 20 COMMON /BLOCRC/ NRC,RC(12600) STQ 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSTQ 40 1ARGS,VWXYZ(8),NERROR STQ 50 DIMENSION ARGS(100) STQ 60 EQUIVALENCE (ARGS(1),RC(12501)) STQ 70 COMMON /QRS/ NDROW,IFLAG,J,NNARG STQ 80 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND STQ 90 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST STQ 100 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP STQ 110 C CHECK IF END OF ROW HAS BEEN EXCEEDED PREVIOUSLY IN THIS SET. STQ 120 IF (IFLAG.NE.0.OR.NARGS.EQ.0) GO TO 80 STQ 130 C J IS WHERE NEXT DATA ITEM IS TO GO IN COLUMN STQ 140 C JJ IS WHERE LAST DATA ITEM OF THIS SET IS TO GO STQ 150 C NDROW IS ADDRESS OF LAST ELEMENT OF ROW. STQ 160 JJ=J+NARGS-1 STQ 170 IF (JJ.LE.NDROW) GO TO 10 STQ 180 CALL ERROR (201) STQ 190 IFLAG=1 STQ 200 IF (J.GT.NDROW) GO TO 80 STQ 210 JJ=NDROW STQ 220 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS STQ 230 10 IF (L1TP.NE.48) GO TO 50 STQ 240 K=1 STQ 250 DO 30 I=J,JJ STQ 260 IF (KIND(K).EQ.0) GO TO 20 STQ 270 IF (ARGS(K).NE.0.) GO TO 50 STQ 280 GO TO 30 STQ 290 20 IF (IARGS(K).NE.0) GO TO 50 STQ 300 30 CONTINUE STQ 310 40 INUNIT=INUNIP STQ 320 MODE=1 STQ 330 RETURN STQ 340 C THIS STATEMENT WAS 10 K=1 STQ 350 50 K=1 STQ 360 C ******************************************************************STQ 370 DO 70 I=J,JJ STQ 380 IF (KIND(K).EQ.0) GO TO 60 STQ 390 RC(I)=ARGS(K) STQ 400 GO TO 70 STQ 410 60 RC(I)=IARGS(K) STQ 420 70 K=K+1 STQ 430 J=JJ+1 STQ 440 NRMAX=MAX0(NRMAX,JJ-NDROW+NROW) STQ 450 C THE FOLLOWING CARDS ARE NEEDED ONLY FOR CSET TAPE STQ 460 IF (L1TP.NE.49) RETURN STQ 470 NTPCT=NTPCT-1 STQ 480 IF (NTPCT.EQ.0) GO TO 40 STQ 490 C ******************************************************************STQ 500 80 RETURN STQ 510 END STQ 520 SUBROUTINE SET SET 10 C VERSION 5.00 SET 5/15/70 SET 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND SET 30 COMMON /BLOCRC/ NRC,RC(12600) SET 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSET 50 1ARGS,VWXYZ(8),NERROR SET 60 DIMENSION ARGS(100) SET 70 EQUIVALENCE (ARGS(1),RC(12501)) SET 80 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG SET 90 COMMON /QRS/ NDROW,IFLAG,J,NNARG SET 100 C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS SET 110 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP SET 120 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST SET 130 C ******************************************************************SET 140 ISRFLG=1 SET 150 IF (NARGS.EQ.1.OR.NARGS.EQ.2) GO TO 10 SET 160 CALL ERROR (10) SET 170 GO TO 70 SET 180 10 MODE=2 SET 190 CALL ADRESS (NARGS,J) SET 200 IF (J) 20,30,40 SET 210 20 CALL ERROR (3) SET 220 GO TO 70 SET 230 30 CALL ERROR (11) SET 240 GO TO 70 SET 250 40 NDROW=J+NROW-1 SET 260 IF (NARGS.EQ.1) GO TO 60 SET 270 IF (KIND(1).NE.0) GO TO 20 SET 280 IF (IARGS(1).LE.NROW.AND.IARGS(1).GT.0) GO TO 50 SET 290 CALL ERROR (16) SET 300 GO TO 70 SET 310 50 J=J+IARGS(1)-1 SET 320 60 IFLAG=0 SET 330 MODE=2 SET 340 GO TO 80 SET 350 70 IFLAG=1 SET 360 C THE FOLLOWING CARDS ARE NEDDED ONLY FOR TAPE OPERATIONS SET 370 IF (L1TP.NE.48.AND.L1TP.NE.49) RETURN SET 380 MODE=1 SET 390 INUNIT=INUNIP SET 400 C ******************************************************************SET 410 80 RETURN SET 420 END SET 430 SUBROUTINE SETUP STP 10 C VERSION 5.00 SETUP 5/15/70 STP 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND STP 30 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST STP 40 COMMON /BLOCRC/ NRC,RC(12600) STP 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSTP 60 1ARGS,VWXYZ(8),NERROR STP 70 DIMENSION ARGS(100) STP 80 EQUIVALENCE (ARGS(1),RC(12501)) STP 90 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH STP 100 COMMON/PKSWT/IHCNT,IHTP STP 110 COMMON /SCRAT/ NS,NS2,A(13500) STP 120 COMMON /ICODE/ NIR,NID,NIRD,LIR,LID,LIRD STP 130 COMMON /BLOCKX/ INDEX(6,8),LEVEL STP 140 COMMON/PCONST/JPC,P(40),N(40) STP 150 COMMON /CONSTS/ PI,E,HALFPI,DEG,RAD,XALOG STP 160 C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS STP 170 COMMON /ICODTP/ NITP,LITP STP 180 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP STP 190 C ******************************************************************STP 200 P(1)=PI STP 210 P(2)=PI STP 220 P(3)=E STP 230 P(4)=E STP 240 KRDEND=80 STP 250 NERROR=0 STP 260 LEVEL=0 STP 270 MODE=1 STP 280 IPRINT=6 STP 290 IPUNCH=3 STP 300 INUNIT=5 STP 310 ISCRAT=45 STP 320 NS=13500 STP 330 KIO=0 STP 340 CALL AERR (-1) STP 350 NRC=12500 STP 360 NS2=NS/2 STP 370 C THESE VARIABLES MUST BE REDEFINED IF A NEW COMMAND IS ADDED STP 380 NIR=246 STP 390 NIRD=29 STP 400 NID=8 STP 410 LIR=300 STP 420 LID=9 STP 430 LIRD=30 STP 440 C THE FOLLOWING CARD IS NEEDED ONLY FOR TAPE OPERATIONS STP 450 NITP=9 STP 460 LITP=10 STP 470 INUNIP=INUNIT STP 480 IPUNCP=IPUNCH STP 490 C ******************************************************************STP 500 C STP 510 C ** THESE SWITCHES MUST BE SET BEFORE COMPILING, NEEDED INFORMATIONSTP 520 C FOR PACKING HEADS AND FORMATS. STP 530 C STP 540 C IHTP= NO. OF HEADINGS PERMITTED. STP 550 C THIS IS SET = 50 , HOWEVER IN ORDER TO SAVE SPACE ONE MAY DESIRE STP 560 C TO PERMIT FEWER HEADINGS. IF SO DIMENSION STATEMENT IN PREPAK STP 570 C FOR VARIABLE IHEAD MUST BE CHANGED. SECOND VALUE OF IHEAD INDI- STP 580 C CATES TOTAL NO. OF HEADINGS STP 590 C STP 600 IHTP=50 STP 610 C STP 620 RETURN STP 630 END STP 640 SUBROUTINE SKSYMV (A,NROW,N,K) SKS 10 C VERSION 5.00 SKSYMV 5/15/70 SKS 20 C FOR OMNITAB MATRIX S PEAVY 1/ 3/68 SKS 30 C SKS 40 C A MATRIX TO BE TESTED FOR SKEW SYMMETRY SKS 50 C NROW DIMENSION OF A SKS 60 C N PRESENT SIZE OF MATRIX SKS 70 C K STATUS SKS 80 C K=2 NO SYMMETRY SKS 90 C K=3 EXACT SKEW SYMMETRY SKS 100 C K=4 RELATIVE (1.E-7) SKEW SYMMETRY SKS 110 C SKS 120 DIMENSION A(NROW,NROW) SKS 130 K=3 SKS 140 NN=N-1 SKS 150 DO 40 J=1,NN SKS 160 IF (A(J,J).EQ.0.0) GO TO 10 SKS 170 K=2 SKS 180 RETURN SKS 190 10 I=J+1 SKS 200 DO 40 L=I,N SKS 210 IF (A(L,J).NE.0.) GO TO 20 SKS 220 T=ABS(A(J,L)) SKS 230 GO TO 30 SKS 240 20 T=ABS(1.0+A(L,J)/A(J,L)) SKS 250 30 IF (T.EQ.0.0) GO TO 40 SKS 260 K=4 SKS 270 IF (T.LE.1.E-7) GO TO 40 SKS 280 K=2 SKS 290 RETURN SKS 300 40 CONTINUE SKS 310 IF (A(N,N).NE.0.0) K=2 SKS 320 RETURN SKS 330 END SKS 340 SUBROUTINE SORDER SOD 10 C VERSION 5.00 SORDER 5/15/70 SOD 20 COMMON /BLOCRC/ NRC,RC(12600) SOD 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSOD 40 1ARGS,VWXYZ(8),NERROR SOD 50 DIMENSION ARGS(100) SOD 60 EQUIVALENCE (ARGS(1),RC(12501)) SOD 70 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG SOD 80 COMMON /SCRAT/ NS,NS2,A(13500) SOD 90 C SUBROUTINE BY CARLA MESSINA 221.04 JUNE 1967 SOD 100 C L2=9 FOR SORT, L2=9 FOR ORDER, L2=14 FOR HEIRARCHY SOD 110 C SOD 120 C TYPE 1 IS HEIRARCHY OF COL ++, STORE IN COL ++ SOD 130 C HEIRARCHY GIVES THE ROW LOCATION OF THE SMALLEST NO. OF THE SOD 140 C THE FIRST COLUMN IN THE FIRST ROW OF THE SECOND COLUMN SOD 150 C THE ROW NO. OF THE SECOND LOWEST NO. OF THE FIRST COLUMN IS STOREDSOD 160 C IN THE SECOND ROW OF THE SECOND COLUMN, .... THE ROW NO. OF THE SOD 170 C LARGEST NO. OF THE FIRST COL IS STORED IN THE NRMAX ROW OF THE 2NDSOD 180 C COLUMN. THE FIRST COLUMN IS UNCHANGED BY THIS COMMAND. SOD 190 C TYPE 2 IS ORDER COLUMNS ++,++,++, ETC SOD 200 C ORDER PLACES EACH ONE OF THE GIVEN COLUMNS IN NUMERICALLY SOD 210 C INCREASING ORDER. SOD 220 C TYPE 3 IS SORT COL ++ CARRY ALONE COLUMNS ++,++, ETC SOD 230 C SORT PLACES THE FIRST COLUMN IN NUMERICALLY INCREASING ORDER SOD 240 C WHILE PRESERVIING THE ROW RELATIONSHIPS AMONG THE GIVEN COLUMNS SOD 250 C SOD 260 C THESE INSTRUCTIONS CAN BE DONE FASTER IF A MACHINE LANGAUGE SOD 270 C PROGRAM IS SUBSTITUTED FOR THIS ONE. SOD 280 C SOD 290 IF (NARGS) 10,10,40 SOD 300 10 K=10 SOD 310 20 CALL ERROR (K) SOD 320 30 RETURN SOD 330 40 CALL CHKCOL (J) SOD 340 IF (J) 50,60,50 SOD 350 50 K=3 SOD 360 GO TO 20 SOD 370 60 IF (L2-9) 80,80,70 SOD 380 70 IF (NARGS-2) 10,80,10 SOD 390 80 IF (NERROR) 30,90,30 SOD 400 90 IF (NRMAX-1) 100,110,120 SOD 410 100 K=9 SOD 420 GO TO 20 SOD 430 110 IF (L2-9) 30,30,210 SOD 440 120 K3=1 SOD 450 K=IARGS(1)-1 SOD 460 130 DO 140 I=1,NRMAX SOD 470 J=K+I SOD 480 L=NRMAX+I SOD 490 A(I)=RC(J) SOD 500 140 A(L)=I SOD 510 K1=NRMAX SOD 520 150 K1=K1-1 SOD 530 K2=0 SOD 540 IF (K1-1) 160,160,170 SOD 550 160 K1=1 SOD 560 170 DO 190 I=1,K1 SOD 570 IF (A(I)-A(I+1)) 190,190,180 SOD 580 180 CC=A(I) SOD 590 A(I)=A(I+1) SOD 600 A(I+1)=CC SOD 610 L=NRMAX+I SOD 620 CC=A(L) SOD 630 A(L)=A(L+1) SOD 640 A(L+1)=CC SOD 650 K2=1 SOD 660 190 CONTINUE SOD 670 IF (K2) 150,200,150 SOD 680 200 IF (L2-9) 240,240,220 SOD 690 210 A(NRMAX+1)=1.0 SOD 700 220 K=IARGS(2)-1 SOD 710 DO 230 I=1,NRMAX SOD 720 J=K+I SOD 730 L=NRMAX+I SOD 740 230 RC(J)=A(L) SOD 750 GO TO 30 SOD 760 240 DO 250 I=1,NRMAX SOD 770 J=K+I SOD 780 250 RC(J)=A(I) SOD 790 IF (NARGS-2) 30,260,260 SOD 800 260 IF (L2-9) 290,270,270 SOD 810 270 IF (NARGS-K3) 30,30,280 SOD 820 280 K3=K3+1 SOD 830 K=IARGS(K3)-1 SOD 840 GO TO 130 SOD 850 290 DO 310 I=2,NARGS SOD 860 K=IARGS(I)-1 SOD 870 DO 300 J=1,NRMAX SOD 880 L=NRMAX+J SOD 890 J1=A(L)+FLOAT(K) SOD 900 300 A(J)=RC(J1) SOD 910 DO 310 J=1,NRMAX SOD 920 J1=K+J SOD 930 310 RC(J1)=A(J) SOD 940 GO TO 30 SOD 950 END SOD 960 SUBROUTINE SORTSM (N,SUM) SOM 10 C VERSION 5.00 SORTSM 5/15/70 SOM 20 C * SOM 30 COMMON /SCRAT/ NS,NS2,A(13500) SOM 40 C SORT COLUMN OF PRODUCTS FOR MATRIX MULTIPLICATION SOM 50 C AFTER SORTING START SUMMING BEGIN IN MIDDLE OF SORTED COLUMN SOM 60 C * SOM 70 DIMENSION X(1) SOM 80 DOUBLE PRECISION X,SAVE,SUM SOM 90 EQUIVALENCE (X,A) SOM 100 IF (N.NE.1) GO TO 10 SOM 110 SUM=X(NS2) SOM 120 RETURN SOM 130 10 K=0 SOM 140 IS=NS2 SOM 150 DO 30 I=2,N SOM 160 IF (X(IS)-X(IS-1)) 20,30,30 SOM 170 20 SAVE=X(IS-1) SOM 180 X(IS-1)=X(IS) SOM 190 X(IS)=SAVE SOM 200 K=1 SOM 210 30 IS=IS-1 SOM 220 IF (K.NE.0) GO TO 10 SOM 230 NP=N/2 SOM 240 IF (MOD(N,2).EQ.0) GO TO 40 SOM 250 NPA=NS2-NP-1 SOM 260 NPB=NPA+2 SOM 270 NPC=NS2-NP SOM 280 SUM=X(NPC) SOM 290 GO TO 50 SOM 300 40 SUM=0.D0 SOM 310 NPA=NS2-NP SOM 320 NPB=NPA+1 SOM 330 50 DO 60 I=1,NP SOM 340 SUM=SUM+X(NPA)+X(NPB) SOM 350 NPA=NPA-1 SOM 360 NPB=NPB+1 SOM 370 60 CONTINUE SOM 380 RETURN SOM 390 END SOM 400 SUBROUTINE SPACE SPA 10 C VERSION 5.00 SPACE 5/15/70 SPA 20 COMMON /BLOCRC/ NRC,RC(12600) SPA 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSPA 40 1ARGS,VWXYZ(8),NERROR SPA 50 DIMENSION ARGS(100) SPA 60 EQUIVALENCE (ARGS(1),RC(12501)) SPA 70 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH SPA 80 IF (NARGS-1) 40,32,10 SPA 90 10 I=10 SPA 100 20 CALL ERROR (I) SPA 110 30 RETURN SPA 120 32 IF (KIND(1).EQ.0) IF(IARGS(1)) 35,30,45 SPA 130 I=20 SPA 140 GO TO 20 SPA 150 35 I=3 SPA 160 GO TO 20 SPA 170 40 IARGS(1)=1 SPA 180 45 J=MIN0(60,IARGS(1)) SPA 190 IF (NERROR.NE.0) GO TO 30 SPA 200 DO 50 I=1,J SPA 210 50 WRITE (IPRINT,60) SPA 220 GO TO 30 SPA 230 C SPA 240 60 FORMAT (1X) SPA 250 END SPA 260 SUBROUTINE SPINV (A,M,KK,ISIG) SPI 10 C VERSION 5.0O0 SPINV 5/15/70 SPI 20 C 7058MI MATRIX INVERSION WITH MINIMUM ROUNDOFF ERROR ACCUMULATION.SPI 30 DIMENSION A(1) SPI 40 DATA ONE/1.0/,ZERO/0.0/,ER/1.E-8/ SPI 50 ISIG=0 SPI 60 N=M SPI 70 NN=KK SPI 80 N2=N+N SPI 90 DO 30 J=1,N SPI 100 NJCOL=(N+J-1)*NN SPI 110 DO 30 I=1,N SPI 120 KINJ=NJCOL+I SPI 130 IF (I-J) 10,20,10 SPI 140 10 A(KINJ)=ZERO SPI 150 GO TO 30 SPI 160 20 A(KINJ)=ONE SPI 170 30 CONTINUE SPI 180 C DETERMINE MAXIMUM ABS OF VARIABLE BEING ELIMINATED. THIS BECOMES SPI 190 L=0 SPI 200 40 L=L+1 SPI 210 LCOL=NN*L-NN SPI 220 KLL=LCOL+L SPI 230 IF (L-N) 50,100,200 SPI 240 C FIND THE LARGEST ELEMENT IN THE LTH COLUMN. SPI 250 50 J1=L SPI 260 C=ABS(A(KLL)) SPI 270 L1=L+1 SPI 280 DO 70 I=L1,N SPI 290 KIL=LCOL+I SPI 300 X=ABS(A(KIL)) SPI 310 IF (C-X) 60,70,70 SPI 320 C RECORD THE NUMBER OF THE ROW HAVING THE GREATER ELEMENT. SPI 330 60 J1=I SPI 340 C C BECOMES THE GREATER. SPI 350 C=X SPI 360 70 CONTINUE SPI 370 C INTERCHANGE ROW J1 WITH ROW L. J1 IS THE ROW WITH THE LARGEST ELEMSPI 380 C TEST TO SEE IF INTERCHANGING IS NECESSARY SPI 390 IF (J1-L) 80,100,80 SPI 400 80 DO 90 J=L,N2 SPI 410 JCOL=NN*J-NN SPI 420 KJIJ=JCOL+J1 SPI 430 HOLD=A(KJIJ) SPI 440 KLJ=JCOL+L SPI 450 A(KJIJ)=A(KLJ) SPI 460 A(KLJ)=HOLD SPI 470 90 CONTINUE SPI 480 C IF THE LARGEST ABSOLUTE ELEMENT IN A COLUMN IS ZERO WE HAVE A SINSPI 490 100 IF (ABS(A(KLL))-ER) 110,110,120 SPI 500 110 ISIG=4 SPI 510 GO TO 200 SPI 520 C ZERO ALL ELEMENTS IN THE LTH COLUMN BUT THE PIVOTAL ELEMENT. SPI 530 120 L1=1 SPI 540 L2=L-1 SPI 550 IF (L2) 130,130,150 SPI 560 130 IF (L-N) 140,170,140 SPI 570 140 L1=L+1 SPI 580 L2=N SPI 590 150 DO 160 I=L1,L2 SPI 600 KIL=LCOL+I SPI 610 Z=-A(KIL)/A(KLL) SPI 620 DO 160 J=L,N2 SPI 630 JCOL=NN*J-NN SPI 640 KIJ=JCOL+I SPI 650 KLJ=JCOL+L SPI 660 160 A(KIJ)=A(KIJ)+Z*A(KLJ) SPI 670 IF (N-L2) 40,40,130 SPI 680 C DIVIDE BY DIAGONAL ELEMENTS. SPI 690 170 DO 180 I=1,N SPI 700 KKK=NN*I-NN+I SPI 710 ZZ=A(KKK) SPI 720 DO 180 J=1,N2 SPI 730 KKI=NN*J-NN+I SPI 740 180 A(KKI)=A(KKI)/ZZ SPI 750 C RETURN AFTER PUTTING A INVERSE INTO B SPI 760 DO 190 J=1,N SPI 770 JCOL=NN*J-NN SPI 780 NJCOL=NN*N+JCOL SPI 790 DO 190 I=1,N SPI 800 KIJ=JCOL+I SPI 810 KINJ=NJCOL+I SPI 820 190 A(KIJ)=A(KINJ) SPI 830 200 RETURN SPI 840 END SPI 850 SUBROUTINE STATIS STA 10 C VERSION 5.00 STATIS 5/15/70 STA 20 C S PEAVY STA 30 C OMNITAB COMMAN IS AS FOLLOWS STA 40 C I WITH WEIGHTS STA 50 C A. STATIS COL +++ WEIGHTS +++ START STORING RESULTS +++ STA 60 C (RESULTS WILL BE STORED IN THE NEXT 4 COL) STA 70 C B. STATIS COL +++ WHTS +++ RESULTS +++,+++,+++,+++ STA 80 C II WITHOUT WHTS STA 90 C A. SAME AS I. A. EXCEPT WHTS COL OMITTED STA 100 C B. SAME AS I. B. EXCEPT WHTS COL OMITTED STA 110 COMMON /BLOCRC/ NRC,RC(12600) STA 120 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSTA 130 1ARGS,VWXYZ(8),NERROR STA 140 DIMENSION ARGS(100) STA 150 EQUIVALENCE (ARGS(1),RC(12501)) STA 160 COMMON /SCRAT/ NS,NS2,A(13500) STA 170 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH STA 180 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG STA 200 DIMENSION SA(3125,3), ISA(3125) STA 210 DIMENSION IB(10) STA 220 EQUIVALENCE (A(101),ISA), (A(3226),SA) STA 230 DIMENSION BCON(4), BKCON(4), AKCON(4), AT5(6), CK1(6), DK2(6), XK1STA 240 1(7), YK2(7) STA 250 DATA BCON(1),BCON(2),BCON(3),BCON(4)/3.6948,-1.6561,.406,2.7764/,BSTA 260 1KCON(1),BKCON(2),BKCON(3),BKCON(4)/7.45894,-.89082,.61522,2.56706/STA 270 2,AKCON(1),AKCON(2),AKCON(3),AKCON(4)/-.51732,-.61863,-.04122,.5589STA 280 37/,AT5(1),AT5(2),AT5(3),AT5(4),AT5(5),AT5(6)/1.9599640,2.3722712,2STA 290 4.8224986,2.5558497,1.5895341,.7328982/,CK1(1),CK1(2),CK1(3),CK1(4)STA 300 5,CK1(5),CK1(6)/-.70285,-.02006,-.01687,-.01447,-.01263,.67839/,DK2STA 310 6(1),DK2(2),DK2(3),DK2(4),DK2(5),DK2(6)/-1.49016,.13384,.09764,.074STA 320 776,.05931,1.68641/,XK1(1),XK1(2),XK1(3),XK1(4),XK1(5),XK1(6),XK1(7STA 330 8)/-40.343875,14.1365,-2.743342,.84143957,.001066,-6.3701507E-6,1.7STA 340 949484E-8/,YK2(1),YK2(2),YK2(3),YK2(4),YK2(5),YK2(6),YK2(7)/50.2982STA 350 $33,-11.395210,6.0537922,1.1542370,-9.8051279E-4,5.5609437E-6,1.458STA 360 $4433E-8/,CONK/1.959964/ STA 370 DATA ZERO/0.0/,ONE/1.0/,TWO/2.0/ STA 380 IF (L2.EQ.1.OR.NARGS.NE.1) GO TO 5 STA 385 CALL ERROR (236) STA 387 RETURN STA 390 5 DO 10 I=1,60 STA 395 10 A(I)=0.0 STA 400 NXCOL=IARGS(1) STA 410 NXWT=IARGS(2) STA 420 ISTORE=1 STA 430 NAR=NARGS STA 440 IWT=1 STA 450 IF (NARGS.EQ.1) GO TO 30 STA 460 IF (NARGS.EQ.3.AND.IARGS(NARGS).LT.0) GO TO 20 STA 470 GO TO 40 STA 480 20 NARGS=NARGS-1 STA 490 IWT=2 STA 500 30 ISTORE=2 STA 510 GO TO 50 STA 520 40 IF (NARGS.NE.2.AND.NARGS.NE.3.AND.NARGS.NE.5.AND.NARGS.NE.6) CALL STA 530 1ERROR (10) STA 540 50 J=NARGS STA 550 CALL CKIND (J) STA 560 IF (J.NE.0) CALL ERROR (3) STA 570 CALL CHKCOL (J) STA 580 IF (J.NE.0) CALL ERROR (11) STA 590 IF (NRMAX*4.LE.NS) GO TO 60 STA 600 CALL ERROR (214) STA 610 RETURN STA 620 60 IF (NERROR.NE.0) RETURN STA 630 IXN=NRMAX STA 640 A(1)=NRMAX STA 650 K=IARGS(1) STA 660 M=1 STA 670 IF (NAR.EQ.3.OR.NAR.EQ.6) GO TO 80 STA 680 NZW=NRMAX STA 690 SUM=0.0 STA 700 S2=0. STA 710 WT=0.0 STA 720 ASUMWT=0. STA 730 DO 70 I=1,IXN STA 740 SA(I,2)=RC(K) STA 750 SA(I,3)=1.0 STA 760 ISA(I)=M STA 770 SA(I,1)=RC(K) STA 780 K=K+1 STA 790 M=M+1 STA 800 WT=WT+1. STA 810 SUM=SUM+SA(I,2) STA 820 ASUMWT=ASUMWT+ABS(SA(I,2)) STA 830 70 S2=S2+SA(I,2)**2 STA 840 SUMWT=SUM STA 850 GO TO 110 STA 860 80 SUM=0. STA 870 WT=0. STA 880 SUMWT=0.0 STA 890 MA=IARGS(2) STA 900 S2=0.0 STA 910 IWT=2 STA 920 NEGWT=0 STA 930 ASUMWT=0. STA 940 DO 100 I=1,IXN STA 950 IF (RC(MA).EQ.0.) GO TO 90 STA 960 IF (RC(MA).LT.0.0) NEGWT=NEGWT+1 STA 970 SA(M,2)=RC(K) STA 980 SA(M,3)=RC(MA) STA 990 ISA(M)=M STA1000 SA(M,1)=RC(K) STA1010 S2=S2+SA(M,2)**2*RC(MA) STA1020 SUM=SUM+RC(K) STA1030 WT=WT+RC(MA) STA1040 SUMWT=SA(M,2)*RC(MA)+SUMWT STA1050 ASUMWT=ASUMWT+ABS(SA(M,2))*RC(MA) STA1060 M=M+1 STA1070 90 K=K+1 STA1080 100 MA=MA+1 STA1090 NZW=M-1 STA1100 IF (NEGWT.GT.0) CALL ERROR (223) STA1110 IF (NZW.GT.0) GO TO 110 STA1120 CALL ERROR (224) STA1130 RETURN STA1140 110 A(2)=NZW STA1150 A(3)=SUM/A(2) STA1160 A(4)=SUMWT/WT STA1170 A(24)=(2.0*A(2)-1.)/3.0 STA1180 A(25)=FSQRT((16.*A(2)-29.)/90.) STA1190 A(39)=S2 STA1200 A(42)=ASUMWT STA1210 A(43)=ASUMWT/WT STA1220 IXN=NZW STA1230 IXNM1=IXN-1 STA1240 120 IST=0 STA1250 DO 130 I=2,IXN STA1260 IF (SA(I-1,1).LE.SA(I,1)) GO TO 130 STA1270 K=ISA(I-1) STA1280 ISA(I-1)=ISA(I) STA1290 ISA(I)=K STA1300 T=SA(I-1,1) STA1310 SA(I-1,1)=SA(I,1) STA1320 SA(I,1)=T STA1330 IST=1 STA1340 130 CONTINUE STA1350 IF (IST.NE.0) GO TO 120 STA1360 NALPHA=.25*A(2) STA1370 IXA=NALPHA+1 STA1380 IXNA=IXN-NALPHA STA1390 TSUM=0. STA1400 TWSUM=0 STA1410 TWT=0 STA1420 DO 140 I=IXA,IXNA STA1430 M=ISA(I) STA1440 TWSUM=TWSUM+SA(I,1)*SA(M,3) STA1450 TWT=TWT+SA(M,3) STA1460 140 TSUM=TSUM+SA(I,1) STA1470 A(7)=TSUM/(A(2)-2.*FLOAT(NALPHA)) STA1480 A(8)=TWSUM/TWT STA1490 N2=(NZW+1)/2 STA1500 A(5)=SA(N2,1) STA1510 IF (MOD(NZW,2).EQ.0) A(5)=(A(5)+SA(N2+1,1))/TWO STA1520 A(6)=(SA(1,1)+SA(IXN,1))/TWO STA1530 A(11)=SA(IXN,1)-SA(1,1) STA1540 A(34)=SA(1,1) STA1550 A(35)=SA(IXN,1) STA1560 DELX=A(11)/10. STA1570 XB=SA(1,1) STA1580 XT=XB+DELX STA1590 L=1 STA1600 DO 170 I=1,10 STA1610 IC=0 STA1620 150 IF (SA(L,1).GE.XT) GO TO 160 STA1630 IC=IC+1 STA1640 L=L+1 STA1650 IF (L.LT.IXN) GO TO 150 STA1660 160 A(I+50)=IC STA1670 170 XT=XT+DELX STA1680 IF (L.GT.IXN) GO TO 190 STA1690 DO 180 I=L,IXN STA1700 IF (SA(I,1).GE.XT-DELX) A(60)=A(60)+1. STA1710 180 CONTINUE STA1720 190 DO 200 I=1,IXNM1 STA1730 200 SA(I,3)=SA(I+1,1)-SA(I,1) STA1740 LA=1 STA1750 DO 210 I=1,IXN STA1760 K=ISA(I) STA1770 SA(K,1)=LA STA1780 210 LA=LA+1 STA1790 K=0 STA1800 RNS=0. STA1810 RNSS=ONE STA1820 LR=0 STA1830 DO 250 I=1,IXNM1 STA1840 IF (SA(I,3).NE.0.0.AND.K.EQ.0) GO TO 240 STA1850 IF (SA(I,3).NE.0.0) GO TO 220 STA1860 RNS=RNS+RNSS STA1870 K=K+1 STA1880 GO TO 250 STA1890 220 K=K+1 STA1900 RNS=RNS+RNSS STA1910 RNS=RNS/FLOAT(K) STA1920 DO 230 L=1,K STA1930 LR=LR+1 STA1940 LRR=ISA(LR) STA1950 230 SA(LRR,1)=RNS STA1960 LR=LR-1 STA1970 RNS=0. STA1980 K=0 STA1990 240 LR=LR+1 STA2000 250 RNSS=RNSS+ONE STA2010 ICI=0 STA2020 IPLUS=0 STA2030 IMINUS=0 STA2040 IDRUNS=0 STA2050 IC=0 STA2060 ADEV=0.0 STA2070 DEV3=0.0 STA2080 DEV2=0.0 STA2090 DEV=0.0 STA2100 DEVI=0.0 STA2110 DEVWT=0. STA2120 DEV4=0.0 STA2130 AK=1. STA2140 KWT=IARGS(2) STA2150 NRXX=KWT+NRMAX-1 STA2160 TA=1.0 STA2170 DO 320 I=1,IXN STA2180 T=SA(I,2)-A(4) STA2190 SA(I,3)=T STA2200 DEV=T+DEV STA2210 ADEV=ADEV+ABS(T) STA2220 DEV2=DEV2+T**2 STA2230 DEV3=DEV3+T**3 STA2240 DEV4=DEV4+T**4 STA2250 DEVI=AK*T+DEVI STA2260 AK=AK+1.0 STA2270 IF (IWT.EQ.1) GO TO 280 STA2280 260 IF (RC(KWT).NE.0.) GO TO 270 STA2290 IF (KWT.GE.NRXX) GO TO 290 STA2300 KWT=KWT+1 STA2310 GO TO 260 STA2320 270 TA=RC(KWT) STA2330 280 DEVWT=DEVWT+TA*T**2 STA2340 290 IF (T.LT.0.0) GO TO 300 STA2350 IPLUS=IPLUS+1 STA2360 ICI=+1 STA2370 GO TO 310 STA2380 300 IMINUS=IMINUS+1 STA2390 ICI=-1 STA2400 310 IF (IC.EQ.ICI) GO TO 320 STA2410 IC=ICI STA2420 IDRUNS=IDRUNS+1 STA2430 320 KWT=KWT+1 STA2440 A(13)=DEVWT/(A(2)-1.) STA2450 A(9)=FSQRT(A(13)) STA2460 A(10)=A(9)/FSQRT(WT) STA2470 A(14)=100.*A(9)/A(4) STA2480 A(28)=IPLUS STA2490 A(29)=IMINUS STA2500 A(31)=1.+(2.*A(28)*A(29)/A(2)) STA2510 A(32)=FSQRT((2.*A(28)*A(29)*(2.*A(28)*A(29)-A(28)-A(29)))/((A(28)+STA2520 1A(29))**2*(A(2)-1.))) STA2530 A(36)=(DEV3/A(2))**2/((A(2)-1.)/A(2)*A(13))**3 STA2540 A(37)=(DEV4/A(2))/((A(2)-1.)/A(2)*A(13))**2 STA2550 A(38)=SUMWT STA2560 A(40)=DEVWT STA2570 A(30)=IDRUNS STA2580 A(33)=(A(30)-A(31))/A(32) STA2590 A(19)=12.*DEVI/(A(2)*(A(2)**2-1.)) STA2600 A(20)=FSQRT((1./(A(2)-2.))*(12.*DEV2/(A(2)*(A(2)**2-1.))-A(19)**2)STA2610 1) STA2620 A(21)=A(19)/A(20) STA2630 CALL PROB (ONE,A(2)-ONE,A(21)*A(21),A(22)) STA2640 DIF=0 STA2650 IRUN=1 STA2660 DO 325 I=2,IXN STA2665 TA=SA(I,2)-SA(I-1,2) STA2670 IF(TA) 326,325,326 STA2675 325 CONTINUE STA2680 326 DO 330 I=2,IXN STA2685 T=SA(I,2)-SA(I-1,2) STA2690 DIF=DIF+T**2 STA2700 IF (TA*T.GE.0.0) GO TO 330 STA2710 TA=T STA2720 IRUN=IRUN+1 STA2730 330 CONTINUE STA2740 A(23)=IRUN STA2750 A(26)=DIF/(A(2)-1.) STA2760 A(27)=A(26)/A(13) STA2770 A(41)=A(4)*FSQRT(WT)/A(9) STA2780 A(12)=ADEV/A(2) STA2790 NU=NZW-1 STA2800 VNU=NU STA2810 T=ZERO STA2820 TK1=ZERO STA2830 TK2=ZERO STA2840 IF (NU.GE.5) GO TO 350 STA2850 DO 340 I=1,4 STA2860 V=I/NU STA2870 T=T+BCON(I)*V STA2880 TK2=BKCON(I)*V+TK2 STA2890 340 TK1=TK1+AKCON(I)*V STA2900 GO TO 400 STA2910 350 T=((((AT5(6)/VNU+AT5(5))/VNU+AT5(4))/VNU+AT5(3))/VNU+AT5(2))/VNU+ASTA2920 1T5(1) STA2930 IF (NU.GT.10) GO TO 370 STA2940 DO 360 I=1,6 STA2950 V=(I+4)/NU STA2960 TK1=TK1+CK1(I)*V STA2970 360 TK2=TK2+DK2(I)*V STA2980 GO TO 400 STA2990 370 IF (NU.GT.100) GO TO 390 STA3000 DO 380 I=1,7 STA3010 V=VNU**(I-4) STA3020 TK1=TK1+XK1(I)*V STA3030 380 TK2=TK2+YK2(I)*V STA3040 GO TO 400 STA3050 390 V2=FSQRT(TWO*VNU) STA3060 V2M1=FSQRT(TWO*VNU-ONE) STA3070 TK1=V2/(CONK+V2M1) STA3080 TK2=V2/(-CONK+V2M1) STA3090 400 A(15)=A(4)-T*A(10) STA3100 A(16)=A(4)+T*A(10) STA3110 A(17)=TK1*A(9) STA3120 A(18)=TK2*A(9) STA3130 C START PRINT OUT STA3140 IF (L2.EQ.2) GO TO 560 STA3150 CALL PAGE (4) STA3160 IF (IWT.EQ.2) GO TO 410 STA3170 WRITE (IPRINT,640) NXCOL,NZW STA3180 GO TO 440 STA3190 410 IF (NZW.NE.NRMAX) GO TO 420 STA3200 WRITE (IPRINT,650) NXCOL,NXWT,NZW STA3210 GO TO 430 STA3220 420 WRITE (IPRINT,660) NXCOL,NXWT,NZW,NRMAX STA3230 430 WRITE (IPRINT,670) STA3240 440 DO 450 I=1,10 STA3250 450 IB(I)=A(I+50) STA3260 WRITE (IPRINT,680) (IB(I),I=1,10) STA3270 WRITE (IPRINT,690) STA3280 WRITE (IPRINT,700) (A(I+2),A(I+8),I=1,6) STA3290 WRITE (IPRINT,710) (A(I),I=15,18) STA3300 WRITE (IPRINT,720) (A(I),A(I+15),I=19,22),(A(I),I=38,41) STA3310 IB(1)=A(23) STA3320 IB(2)=A(28) STA3330 IB(3)=A(29) STA3340 IB(4)=A(30) STA3350 WRITE (IPRINT,730) IB(1),A(42),A(24),A(43),(A(I),I=25,27),(IB(I),ISTA3360 1=2,4),(A(I),I=31,33) STA3370 WRITE (IPRINT,740) STA3380 KB=ISA(1) STA3390 T=SA(KB,2) STA3400 LINEP=40 STA3410 LINE=0 STA3420 LW=IARGS(2) STA3430 DO 520 I=1,IXNM1 STA3440 IF (LINEP.LT.40) GO TO 470 STA3450 LINEP=0 STA3460 CALL PAGE (4) STA3470 WRITE (IPRINT,750) STA3480 IF (IWT.EQ.1) GO TO 460 STA3490 WRITE (IPRINT,760) STA3500 GO TO 470 STA3510 460 WRITE (IPRINT,770) STA3520 470 K=ISA(I+1) STA3530 TA=SA(K,2)-T STA3540 GO TO (500,480), IWT STA3550 480 IF (RC(LW).NE.0.0) GO TO 490 STA3560 LW=LW+1 STA3570 GO TO 480 STA3580 490 WRITE (IPRINT,790) I,SA(I,2),SA(I,1),SA(I,3),RC(LW),ISA(I),T,TA STA3590 LW=LW+1 STA3600 GO TO 510 STA3610 500 WRITE (IPRINT,780) I,SA(I,2),SA(I,1),SA(I,3),ISA(I),T,TA STA3620 510 T=SA(K,2) STA3630 LINE=LINE+1 STA3640 IF (LINE.NE.10) GO TO 520 STA3650 LINE=0 STA3660 LINEP=LINEP+10 STA3670 WRITE (6,800) STA3680 520 CONTINUE STA3690 IF (IWT.EQ.1) GO TO 550 STA3700 530 IF (RC(LW).NE.0.0) GO TO 540 STA3710 LW=LW+1 STA3720 GO TO 530 STA3730 540 WRITE (IPRINT,790) NZW,SA(NZW,2),SA(NZW,1),SA(NZW,3),RC(LW),ISA(NZSTA3740 1W),T STA3750 GO TO 560 STA3760 550 WRITE (IPRINT,780) NZW,SA(NZW,2),SA(NZW,1),SA(NZW,3),ISA(NZW),T STA3770 560 IF (ISTORE.EQ.2) RETURN STA3780 IF (NARGS.EQ.2.OR.NARGS.EQ.3) GO TO 570 STA3790 L=IARGS(NARGS-3) STA3800 M=IARGS(NARGS-2) STA3810 K=IARGS(NARGS-1) STA3820 J=IARGS(NARGS) STA3830 GO TO 580 STA3840 570 L=IARGS(NARGS) STA3850 M=L+NROW STA3860 K=M+NROW STA3870 J=K+NROW STA3880 580 DO 590 I=1,NZW STA3890 MB=ISA(I) STA3900 RC(K)=SA(MB,2) STA3910 RC(M)=SA(I,1) STA3920 RC(J)=SA(I,3) STA3930 M=M+1 STA3940 K=K+1 STA3950 590 J=J+1 STA3960 IF (NZW.EQ.NRMAX) GO TO 610 STA3970 NZW1=NZW+1 STA3980 DO 600 I=NZW1,NRMAX STA3990 RC(M)=0. STA4000 RC(K)=0. STA4010 RC(J)=0. STA4020 M=M+1 STA4030 K=K+1 STA4040 600 J=J+1 STA4050 610 NTOP=60 STA4060 IF (NROW.LT.NTOP) NTOP=NROW STA4070 DO 620 I=1,NTOP STA4080 RC(L)=A(I) STA4090 620 L=L+1 STA4100 IF (NRMAX.LT.60) RETURN STA4110 DO 630 I=61,NRMAX STA4120 RC(L)=0. STA4130 630 L=L+1 STA4140 RETURN STA4150 C STA4160 640 FORMAT (1H0,4X,28HSTATISTICAL ANALYSIS OF COL ,I4,33X,4HN = ,I4) STA4170 650 FORMAT (1H0,4X,28HSTATISTICAL ANALYSIS OF COL ,I4,8X,15HWEIGHTS INSTA4180 1 COL ,I4,6X,4HN = ,I4) STA4190 660 FORMAT (1H0,4X,28HSTATISTICAL ANALYSIS OF COL ,I4,8X,15HWEIGHTS INSTA4200 1 COL ,I4,6X,4HN = ,I4,33H(NO OF NON-ZERO WTS) COL LENGTH =,I4) STA4210 670 FORMAT (1H0,24X,64HALL COMPUTATIONS ARE BASED ON OBSERVATIONS WITHSTA4220 1 NON-ZERO WEIGHTS) STA4230 680 FORMAT (1H0/15X,27HFREQUENCY DISTRIBUTON (1-6),7X,10I6) STA4240 690 FORMAT (1H0/5X,26HMEASURES OF LOCATION (2-2),34X,28HMEASURES OF DISTA4250 1SPERSION (2-6)) STA4260 700 FORMAT (1H0, STA4265 1 9X,26HUNWEIGHTED MEAN =, 1PE15.7,20X, STA4270 2 26HSTANDARD DEVIATION =, E15.7 / STA4275 310X,26HWEIGHTED MEAN =, E15.7,20X, STA4280 4 26HS.D. OF MEAN =, E15.7 / STA4290 510X,26HMEDIAN =, E15.7,20X, STA4295 6 26HRANGE =, E15.7 / STA4300 710X,26HMID-RANGE =, E15.7,20X, STA4305 8 26HMEAN DEVIATION =, E15.7 / STA4310 910X,26H25 PCT UNWTD TRIMMED MEAN=, E15.7,20X, STA4315 A 26HVARIANCE =, E15.7 / STA4320 B10X,26H25 PCT WTD TRIMMED MEAN =, E15.7,20X, STA4325 C 26HCOEFFICIENT OF VARIATION =, E15.7 ) STA4330 710 FORMAT (1H0//20X,50HA TWO-SIDED 95 PCT CONFIDENCE INTERVAL FOR MEASTA4350 1N IS1PE11.4,3H TO,E11.4,6H (2-2)/20X,50HA TWO-SIDED 95 PCT CONFIDESTA4360 2NCE INTERVAL FOR S.D. IS,E11.4,3H TO,E11.4,6H (2-7)) STA4370 720 FORMAT (1H0//5X,30HLINEAR TREND STATISICS (5-1) ,30X,16HOTHER STASTA4380 1TISTICS//10X,5HSLOPE,20X,1H=,1PE15.7,20X,7HMINIMUM,18X,1H=,E15.7/1STA4390 20X,13HS.D. OF SLOPE,12X,1H=,E15.7,20X,7HMAXIMUM,18X,1H=,E15.7/10X,STA4400 326HSLOPE/S.D. OF SLOPE = T =,E15.7,20X,8HBETA ONE,17X,1H=,E15.7/1STA4410 40X,35HPROB EXCEEDING ABS VALUE OF OBS T =,0PF6.3,20X,8HBETA TWO,17STA4420 5X,1H=,1PE15.7/71X,17HWTD SUM OF VALUES,8X,1H=,E15.7/71X,18HWTD SUMSTA4430 6 OF SQUARES,7X,1H=,E15.7/5X,24HTESTS FOR NON-RANDOMNESS,42X,26HWTDSTA4440 7 SUM OF DEVS SQUARED =,E15.7/71X,11HSTUDENT,S T,14X,1H=,E15.7) STA4450 730 FORMAT (10X,26HNO OF RUNS UP AND DOWN =,I5,30X,26HWTD SUM ABSOLUSTA4460 1TE VALUES =,1PE15.7/10X,26HEXPECTED NO OF RUNS =,0PF7.1,28X,STA4470 226HWTD AVE ABSOLUTE VALUES =,1PE15.7/10X,26HS.D. OF NO OF RUNS STA4480 3 =,0PF8.2/10X,26HMEAN SQ SUCCESSIVE DIFF =,1PE16.7/10X,26HMEANSTA4490 4 SQ SUCC DIFF/VAR =,0PF9.3///10X,24HDEVIATIONS FROM WTD MEAN//1STA4500 55X,21HNO OF + SIGNS =,I5/15X,21HNO OF - SIGNS =I5/15X,STA4510 610HNO OF RUNS,10X,1H=,I5/15X,21HEXPECTED NO OF RUNS =,F7.1/15X,12HSTA4520 7S.D. OF RUNS,8X,1H=,F8.2/15X,21HDIFF./S.D. OF RUNS =,F9.3) STA4530 740 FORMAT (/////68H NOTE - ITEMS IN PARENTHESES REFER TO PAGE NUMBER STA4540 1IN NBS HANDBOOK 91) STA4550 750 FORMAT (//27X,12HOBSERVATINS,47X,20HORDERED OBSERVATIONS) STA4560 760 FORMAT (1H0,8X,1HI,9X,4HX(I),9X,4HRANK,7X,9HX(I)-MEAN,7X,4HW(I),16STA4570 1X,3HNO.,8X,4HX(J),10X,11HX(J+1)-X(J)) STA4580 770 FORMAT (1H0,8X,1HI,9X,4HX(I),9X,4HRANK,7X,9HX(I)-MEAN,27X,3HNO.,8XSTA4590 1,4HX(J),10X,11HX(J+1)-X(J)) STA4600 780 FORMAT (I10,1PE17.7,0PF9.1,1PE17.7,22X,I6,1P2E17.7) STA4610 790 FORMAT (I10,1PE17.7,0PF9.1,1PE17.7,1PE12.3,10X,I6,1P2E17.7) STA4620 800 FORMAT (1H ) STA4630 END STA4640 SUBROUTINE STMT (NSTMT) STM 10 C VERSION 5.00 STMT 5/15/70 STM 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND STM 30 C STM 40 C THIS SUBROUTINE ASSEMBLES AND CHECKS A STATEMENT NUMBER. STM 50 C STM 60 C CALLED BY.. .MAIN. STM 70 MISC=10*KARD(M) STM 80 10 M=M+1 STM 90 K=KARD(M) STM 100 IF (K.GE.10) GO TO 30 STM 110 MISC=10*(MISC+K) STM 120 IF (MISC.LT.10000) GO TO 10 STM 130 C STM 140 C ILLEGAL STATEMENT NUMBER EXIT STM 150 C STM 160 20 KARG=1 STM 170 RETURN STM 180 C STM 190 C NON-NUMERIC FOUND, IS IT A . STM 200 C STM 210 30 IF (K.EQ.37) GO TO 50 STM 220 C STM 230 C IS IT A / STM 240 C STM 250 40 IF (K.EQ.36) GO TO 70 STM 260 C STM 270 C IS IT A SPACE STM 280 C STM 290 IF(K-44) 20,60,20 STM 300 C STM 310 C . FOUND, MUST BE FOLLOWED BY ONE AND ONLY ONE NUMERAL STM 320 C STM 330 50 M=M+1 STM 340 K=KARD(M) STM 350 IF (K.GE.10) GO TO 20 STM 360 MISC=MISC+K STM 370 60 M=M+1 STM 380 K=KARD(M) STM 390 GO TO 40 STM 400 70 M=M+1 STM 410 K=KARD(M) STM 420 C STM 430 C / FOUND, MUST BE FOLLOWED BY BLANKS THEN/OR A LETTER STM 440 C STM 450 IF (K.EQ.44) GO TO 70 STM 460 IF (K.GE.36.OR.K.LT.10) GO TO 20 STM 470 C STM 480 C LEGAL STATEMENT NUMBER FOUND STM 490 C STM 500 NSTMT=MISC STM 510 KARG=0 STM 520 RETURN STM 530 END STM 540 SUBROUTINE STORE (J) STO 10 C VERSION 5.00 STORE 5/15/70 STO 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND STO 30 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) STO 40 COMMON /BLOCRC/ NRC,RC(12600) STO 50 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NSTO 60 1ARGS,VWXYZ(8),NERROR STO 70 DIMENSION ARGS(100) STO 80 EQUIVALENCE (ARGS(1),RC(12501)) STO 90 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG STO 100 C STORAGE LAYOUT.. STATEMENT NUMBER STO 110 C NUMBER OF WORDS IN ENTRY STO 120 C NARGS+64*(L1+64*L2) STO 130 C ALL ITEMS ARE STORED IN ( ENTY 1 ) STO 140 C FLOATING POINT TO ALLOW ( 2 ) STO 150 C CONVERSION TO DOUBLE- STO 160 C PRECISION. ( LAST WORD ) STO 170 C STO 180 IF (IOVFL.NE.0) RETURN STO 190 IZE=J+2 STO 200 IF (NSTMT.GT.NSTMTH) GO TO 90 STO 210 C STO 220 C STATEMENT IS AN INSERTION OR A REPLACEMENT STO 230 C STO 240 L=LOCATE(NSTMT) STO 250 IF (L.GT.0) GO TO 30 STO 260 C STO 270 L=-L STO 280 IDIF=IZE STO 290 10 LL=NCOM STO 300 C STATEMENT IS AN INSERTION, OPEN GAP STO 310 II=LL+IDIF STO 320 IF (II.GE.LCOM) GO TO 100 STO 330 DO 20 I=L,NCOM STO 340 COM(II)=COM(LL) STO 350 II=II-1 STO 360 20 LL=LL-1 STO 370 GO TO 60 STO 380 C STO 390 C STATEMENT IS REPLACEMENT STO 400 C STO 410 30 IDIF=IZE-IFIX(COM(L+1)) STO 420 IF (IDIF) 40,60,10 STO 430 C STO 440 C NEW STATEMENT SMALLER THAN OLD, CLOSE UP GAP. STO 450 C STO 460 40 I=L-IDIF STO 470 II=L STO 480 DO 50 IA=I,NCOM STO 490 COM(II)=COM(IA) STO 500 50 II=II+1 STO 510 C STO 520 C INSERT STATEMENT STO 530 C STO 540 60 COM(L)=NSTMT STO 550 COM(L+1)=IZE STO 560 COM(L+2)=NARGS+64*(L1+64*L2) STO 570 NCOM=NCOM+IDIF STO 580 IF (IZE.EQ.3) GO TO 80 STO 590 DO 70 I=4,IZE STO 600 COM(L+3)=ARGTAB(I-3) STO 610 70 L=L+1 STO 620 80 CONTINUE STO 630 RETURN STO 640 C STO 650 C PUT STATEMENT ON END STO 660 C STO 670 90 L=NCOM STO 680 IDIF=IZE STO 690 NSTMTX=NSTMTH STO 700 NSTMTH=NSTMT STO 710 IF (NCOM+IDIF.LT.LCOM) GO TO 60 STO 720 C STO 730 C COM STORAGE OVERFLOW STO 740 C STO 750 100 IOVFL=1 STO 760 CALL ERROR (12) STO 770 RETURN STO 780 END STO 790 SUBROUTINE STORMT (C,N,NP,K,A) STT 10 C VERSION 5.00 STORMT 5/15/70 STT 20 C * STT 30 C SUBROUTINE STORES MATRIX C(NP,K ) FROM SCRATCH AREA A STT 40 C * STT 50 DIMENSION A(1), C(N,1) STT 60 IS=1 STT 70 DO 10 J=1,K STT 80 DO 10 I=1,NP STT 90 C(I,J)=A(IS) STT 100 10 IS=IS+1 STT 110 RETURN STT 120 END STT 130 SUBROUTINE STRUVE (Z,A,B,C) STR 10 C VERSION 5.00 STRUVE 5/15/70 STR 20 DIMENSION C(1) STR 30 DOUBLE PRECISION Z,A,B,C,X,P,Q,R,S,DBEJ STR 40 X=DABS(Z) STR 50 IF (X.GT..0D0) GO TO 10 STR 60 A=.0D0 STR 70 B=.0D0 STR 80 GO TO 40 STR 90 10 IF (X.GT.70.D0) GO TO 30 STR 100 CALL BEJN (0,C,X) STR 110 P=.0D0 STR 120 Q=.0D0 STR 130 DO 20 N=1,49 STR 140 J=2*N STR 150 K=J+1 STR 160 R=J-1 STR 170 S=4*N**2-1 STR 180 P=P+C(J)/R STR 190 20 Q=Q+C(K)/S STR 200 A=P/.78539816339D0 STR 210 B=(2.D0*Q+1.D0-C(1))/1.5707963268D0 STR 220 GO TO 40 STR 230 30 S=1.D0/X**2 STR 240 P=1.D0-S*(1.D0-9.D0*S*(1.D0-25.D0*S*(1.D0-49.D0*S))) STR 250 A=DBEJ(X,0,5)+P/(X*1.5707963268D0) STR 260 Q=1.D0+S*(1.D0-3.D0*S*(1.D0-15.D0*S*(1.D0-35.D0*S))) STR 270 B=DBEJ(X,1,5)+Q/(1.5707963268D0) STR 280 40 RETURN STR 290 END STR 300 SUBROUTINE SYMV (A,NROW,N,K) SYM 10 C VERSION 5.00 SYMV 5/15/70 SYM 20 C FOR OMNITAB WRITTEN BY S PEAVY 11/29/67 SYM 30 C A-FIRST ELEMENT OF MATRIX A SYM 40 C NROW -NO. OF ROWS IN A AS DEFINED IN A DIMENSION ST SYM 50 C N -PRESENT SIZE OF A SYM 60 C K -STATUS FOR SYMMETRY SYM 70 C K=0 EXACT SYMMETRY A A(I,J)/A(J,I))=1 SYM 80 C K=1 SYMM TO A RELATIVE RROR ABS(1-A(I,J)/A(J,I))= OR LESS 1.E-7 SYM 90 C K=2 NO SYMMETRY SYM 100 C SYM 110 DIMENSION A(NROW,NROW) SYM 120 K=0 SYM 130 NN=N-1 SYM 140 DO 40 J=1,NN SYM 150 I=J+1 SYM 160 DO 40 L=I,N SYM 170 IF (A(J,L)) 20,10,20 SYM 180 10 T=ABS(A(L,J)) SYM 190 GO TO 30 SYM 200 20 T=ABS(1.0-A(L,J)/A(J,L)) SYM 210 30 IF (T.EQ.0.) GO TO 40 SYM 220 K=1 SYM 230 IF (T.LE.1.E-7) GO TO 40 SYM 240 K=2 SYM 250 RETURN SYM 260 40 CONTINUE SYM 270 RETURN SYM 280 END SYM 290 SUBROUTINE TAPOP2 TP2 10 C VERSION 5.00 TAPOP2 5/15/70 TP2 20 C THIS SUBROUTINE IS NEDDED ONLY FOR TAPE OPERATIONS TP2 30 C L1= 45 L2=1,7 TP2 40 C READ TAPE A-F A-F (FORMAT) INTO COLUMNS ++,++,++,++, ETC. TP2 50 C READ UNTIL A RECORD OF A ZEROS ARE ENCOUNTERED TP2 60 C IF NO FORMAT IS GIVEN, CARDS ARE READ AS IN READ COMMAND TP2 70 C L1= 46 L2=1,7 TP2 80 C CREAD TAPE A-F A-F (FORMAT) ,, CARDS INTO COLUMNS ++,++,++,ETTP2 90 C CREAD TAPE A-F ,,CARDS INTO COLUMNS ++,++,++,ETC. TP2 100 C READ USING A COUNTER TP2 110 C L1= 47 L2=1,7 TP2 120 C WRITE TAPE A-F A-F(FORMAT) FORM COLUMNS ++,++,++,++,ETC. TP2 130 C A RECORD OF ZEROS IS WRITTEN AFTER NRMAX VALUES TP2 140 C L1= 48 L2=1 TP2 150 C SET TAPE A-F INTO COLUMNS ++ TP2 160 C SET TAPE A-F INTO ROW ,, OF COLUMN ++ TP2 170 C READ UNTIL A RECORD OF ZEROS IS ENCOUNTERED TP2 180 C L1= 49 L2=1 TP2 190 C CSET TAPE A-F ,, VALUES INTO COLUMN ++ TP2 200 C CSET TAPE A-F ,, VALUES INTO ROW ,, OF COLUMN ++ TP2 210 C READ USING A COUNTER TP2 220 C L1=50 L2=1 TP2 230 C ENDFILE TAPE A-F TP2 240 C L1= 50 L2=2 TP2 250 C REWIND TAPE A-F TP2 260 C L1= 50 L2=3 TP2 270 C SKIP TAPE A-F FORWARD ,, RECORDS TP2 280 C L1= 50 L2=4 TP2 290 C BACKSPACE TAPE A-F ,, RECORDS TP2 300 COMMON /BLOCKC/ KIO,IUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST TP2 310 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NTP2 320 1ARGS,VWXYZ(8),NERROR TP2 330 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG TP2 340 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH TP2 350 COMMON /SCRAT/ NS,NS2,A(13500) TP2 360 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP TP2 370 C CHECK FOR CORRECT NUMBER IF ARGUMENTS TP2 380 IF(L1.LT.50) IF(NARGS-2) 5,30,30 TP2 390 GO TO (10,10,20,20), L2 TP2 400 5 CALL ERROR (10) TP2 410 GO TO 30 TP2 420 10 IF (NARGS.NE.1) CALL ERROR (10) TP2 430 GO TO 40 TP2 440 20 IF (NARGS.NE.2) CALL ERROR (10) TP2 450 C ALL ARGUMENTS SHOULD BE INTEGERS TP2 460 30 J=NARGS TP2 470 CALL CKIND (J) TP2 480 IF (J.NE.0) CALL ERROR (3) TP2 490 C IS TAPE NUMBER CORRECT TP2 500 40 IF (IARGS(1).LT.7.OR.IARGS(1).GT.12) CALL ERROR (28) TP2 510 IF (NERROR.NE.0) RETURN TP2 520 L1P=L1-44 TP2 530 GO TO (50,70,90,60,80,170), L1P TP2 540 50 IF (L2.EQ.1) GO TO 60 TP2 550 INUNIT=IARGS(1) TP2 560 IARGS(1)=0 TP2 570 GO TO 130 TP2 580 60 IA=2 TP2 590 GO TO 100 TP2 600 70 IF (L2.NE.1) GO TO 60 TP2 610 80 NTPCT=IARGS(2) TP2 620 IA=3 TP2 630 GO TO 100 TP2 640 90 IA=2 TP2 650 IPUNCH=IARGS(1) TP2 660 GO TO 110 TP2 670 100 INUNIT=IARGS(1) TP2 680 110 I=1 TP2 690 DO 120 II=IA,NARGS TP2 700 IARGS(I)=IARGS(II) TP2 710 120 I=I+1 TP2 720 NARGS=NARGS-IA+1 TP2 730 130 L1TP=L1 TP2 740 GO TO (140,140,150,160,160), L1P TP2 750 140 CALL READX TP2 760 RETURN TP2 770 150 CALL PUNCH TP2 780 RETURN TP2 790 160 CALL SET TP2 800 RETURN TP2 810 170 ITPP=IARGS(1) TP2 820 GO TO (180,190,200,220), L2 TP2 830 180 ENDFILE ITPP TP2 840 RETURN TP2 850 190 REWIND ITPP TP2 860 RETURN TP2 870 200 IREC=IARGS(2) TP2 880 DO 210 I=1,IREC TP2 890 READ (ITPP,240) A(1) TP2 900 210 CONTINUE TP2 910 RETURN TP2 920 220 IREC=IARGS(2) TP2 930 DO 230 I=1,IREC TP2 940 BACKSPACE ITPP TP2 950 230 CONTINUE TP2 960 RETURN TP2 970 C TP2 980 240 FORMAT (80A1) TP2 990 END TP21000 SUBROUTINE TAPOP TAP 10 C VERSION 5.00 TAPOP 5/15/70 TAP 20 C RV SUBROUTINE USED WITH TAPE COMMANDS TAP 30 COMMON /TAPE/ NAME4(2),NTPCT,IPUNCP,INUNIP,L1TP TAP 40 COMMON /CODE/ IALPH(6),NALPH(5),ID(9,3),IR(300,4),IRD(30,6) TAP 50 COMMON/ABCDEF/L(48) TAP 55 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND TAP 60 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG TAP 70 COMMON /CODETP/ ITP(10,4) TAP 80 NAME4(1)=0 TAP 90 NAME4(2)=0 TAP 100 NTPCT=0 TAP 110 10 K=KARD(M) TAP 120 C THE TAPE ID MAY BE A NUMBER OR A LETTER TAP 130 IF (K.LT.36) IF (K-10) 20,30,30 TAP 135 M=M+1 TAP 140 GO TO 10 TAP 150 20 ITAPE=KARD(M)+6 TAP 160 MP=M-1 TAP 170 GO TO 50 TAP 180 30 MP=M-1 TAP 190 CALL NNAME (NAME4(1)) TAP 200 ITAPE=0 TAP 210 DO 40 I=1,6 TAP 220 IF (NAME4(1).NE.IALPH(I)) GO TO 40 TAP 230 ITAPE=I+6 TAP 240 GO TO 50 TAP 250 40 CONTINUE TAP 260 50 IF(ITAPE.GT.9) GO TO 60 TAP 270 KARD(MP)=L(45) TAP 280 KARD(MP+1)=ITAPE TAP 290 GO TO 80 TAP 300 60 KARD(MP)=1 TAP 310 KARD(MP+1)=ITAPE-10 TAP 320 C CREAD READ WRITE TAP 340 80 IF (NAME(1).NE.ITP(2,1).AND.NAME(1).NE.ITP(1,1).AND.NAME(1).NE.ITPTAP 350 1(3,1)) GO TO 110 TAP 360 NAME4(1)=0 TAP 370 NAME4(2)=0 TAP 380 M=M+1 TAP 390 90 K=KARD(M) TAP 400 IF (K.LT.36) IF (K-10) 110,100,100 TAP 410 M=M+1 TAP 420 GO TO 90 TAP 430 100 CALL NNAME (NAME4(1)) TAP 440 110 M=MP TAP 450 RETURN TAP 460 END TAP 470 SUBROUTINE THERMO THE 10 C VERSION 5.00 THERMO 5/15/70 THE 20 C IT NOW CONTAINS THE COMMANDS CTOF, FTOC, ATOMIC, MOLWT, EINSTEIN, THE 30 C PFTRANSLATIONAL, PFATOMIC, AND PARTFUNCTION THE 40 C THERMODYNAMIC PACKAGE WRITTEN BY R. MCCLENON, MSRDS-NBS, NOV. 69 THE 50 C THE 60 C THE VALUES OF L2 ARE -- THE 70 C 1 -CTOF (CENTIGRADE TO FAHRENHEIT) THE 80 C 2 - FTOC (FAHRENHEIT TO CENTIGRADE0 THE 90 C 3 - ATOMIC MASS TABLE THE 100 C 4 - MOLWT (MOLECULAR WEIGHT) THE 110 C 5 - EINSTEIN FUNCTION THE 120 C 6 - PFTRANS (PARTITION FUNCTIONAL TRNASLATIONSAL) THE 130 C 7 - PFATOM ( P.F. ATOMIC) THE 140 C 8 - PARTFUNCTION THE 150 C 9 - BOLDISTRIBUTION (BOLZMAN DISTRIBUTION) THE 160 C THE 170 C WRITTEN BY R. MCCLENON, NSRDS-NBS, DEC. 1969 THE 180 C THE 190 C COMMAND FORMATS ARE AS FOLLOWS -- THE 200 C CTOF OF $$ STORE IN COL ++ THE 210 C FTOC OF $$ STORE IN COL ++ THE 220 C ATOMIC MASSES STORE IN COL ++ THE 230 C MOLWT Z=,, AMOUNT,, Z=,, AMOUNT=,, ... STORE SUM IN COL ++ THE 240 C EINSTEIN TEMP IN $$ VIB FREQ IN WAVE NO IN $$ START STORING IN ++THE 250 C OR EINSTEIN TEMP IN $$ FREQ IN $$ GAS CONST R=,, START IN ++ THE 260 C PFTRNAS TEMP IN $$ MOL WT M IN $$ START STORING IN $$ THE 270 C PFATOM TEMP IN $$ MOL WT M IN $$ WAVE NO IN ++ DEGEN G IN ++ THE 280 C START STORING IN COL ++ THE 290 C PARTFUNC TEMP IN $$ WAVE NO IN ++ G IN ++ START STORING IN ++ THE 300 C VIBDIST TEMP IN $$ WAVE NO IN ++ G IN ++ START STORING IN ++ THE 310 C THE 320 C SEE HANDBOOK 101 FOR DETAILS ON STORAGE BY ALL COMMANDS EXCEPT THE 330 C VIBDIST (WHICH IS NEW) THE 340 C VIBDIST STORES THE PERCENTAGE OF MOLECULES IN EACH OF THE THE 350 C VIBRATIONAL ENERGY LEVELS. IF THEERE ARE N ENERGY LEVELS VIBDIST THE 360 C WILL USE N COLUMNS FOR STORAGE THE 370 C THE 380 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NTHE 390 1ARGS,VWXYZ(8),NERROR THE 400 EQUIVALENCE (ARGS(1),RC(12501)) THE 410 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG THE 420 DIMENSION ARGS(100) THE 430 COMMON /BLOCRC/ NRC,RC(12600) THE 440 DOUBLE PRECISION X,EXX,EXDIF,FDEXP,FDLOG,Q0,Q1,Q2,G,QQ THE 450 COMMON /SCRAT/ NS,NS2,A(13500) THE 460 C DIMENSION QQ(NS2) THE 470 DIMENSION QQ(6750) THE 480 EQUIVALENCE (A(1),QQ(1)) THE 490 DIMENSION ATWT(103) THE 500 DATA ATWT(1),ATWT(2),ATWT(3),ATWT(4),ATWT(5),ATWT(6)/1.00800,4.002THE 510 160,6.94100,9.01218,10.81000,12.01100/ THE 520 DATA ATWT(7),ATWT(8),ATWT(9),ATWT(10),ATWT(11),ATWT(12)/14.00670,1THE 530 15.99940,18.99840,20.187900,22.98980,24.40500/ THE 540 DATA ATWT(13),ATWT(14),ATWT(15),ATWT(16),ATWT(17),ATWT(18)/26.9815THE 550 10,28.08600,30.97380,32.06000,35.35400,39.48000/ THE 560 DATA ATWT(19),ATWT(20),ATWT(21),ATWT(22),ATWT(23),ATWT(24)/39.1020THE 570 10,40.08000,44.95590,47.90000,50.94140,51.99600/ THE 580 DATA ATWT(25),ATWT(26),ATWT(27),ATWT(28),ATWT(29),ATWT(30)/54.9380THE 590 10,55.84700,58.93320,58.71000,63.54600,65.37000/ THE 600 DATA ATWT(31),ATWT(32),ATWT(33),ATWT(34),ATWT(35),ATWT(36)/69.7200THE 610 10,72.59000,74.92160,78.96000,79.90400,83.80000/ THE 620 DATA ATWT(37),ATWT(38),ATWT(39),ATWT(40),ATWT(41),ATWT(42)/85.4678THE 630 10,87.62000,88.90590,91.22000,92.90640,95.94000/ THE 640 DATA ATWT(43),ATWT(44),ATWT(45),ATWT(46),ATWT(47),ATWT(48)/98.9062THE 650 10,101.07000,102.90550,106.40000,107.86800,112.40000/ THE 660 DATA ATWT(49),ATWT(50),ATWT(51),ATWT(52),ATWT(53),ATWT(54)/114.820THE 670 100,118.69000,121.75000,127.60000,126.90450,131.30000/ THE 680 DATA ATWT(55),ATWT(56),ATWT(57),ATWT(58),ATWT(59),ATWT(60)/132.905THE 690 150,137.34000,138.90550,140.12000,140.90770,144.24000/ THE 700 DATA ATWT(61),ATWT(62),ATWT(63),ATWT(64),ATWT(65),ATWT(66)/147.000THE 710 100,150.40000,151.96000,157.20000,158.92540,162.50000/ THE 720 DATA ATWT(67),ATWT(68),ATWT(69),ATWT(70),ATWT(71),ATWT(72)/164.930THE 730 130,167.26000,168.93420,173.04000,174.97000,178.49000/ THE 740 DATA ATWT(73),ATWT(74),ATWT(75),ATWT(76),ATWT(77),ATWT(78)/180.947THE 750 190,183.85000,186.20000,190.20000,192.22000,195.09000/ THE 760 DATA ATWT(79),ATWT(80),ATWT(81),ATWT(82),ATWT(83),ATWT(84)/196.966THE 770 150,200.59000,204.37000,207.20000,208.98060,210.00000/ THE 780 DATA ATWT(85),ATWT(86),ATWT(87),ATWT(88),ATWT(89),ATWT(90)/210.000THE 790 100,222.00000,223.00000,226.02540,227.02000,232.03810/ THE 800 DATA ATWT(91),ATWT(92),ATWT(93),ATWT(94),ATWT(95),ATWT(96)/231.035THE 810 190,238.02900,237.04820,239.00000,243.00000,247.00000/ THE 820 DATA ATWT(97),ATWT(98),ATWT(99),ATWT(100),ATWT(101),ATWT(102)/247.THE 830 100000,239.00000,254.00000,253.0000,255.00000,257.00000/ THE 840 DATA ATWT(103)/255.0/ THE 850 GO TO (10,250,260,380,490,590,640,710,760), L2 THE 860 C THIS IS CTOF THE 870 10 M=1 THE 880 20 IF (NARGS-2) 1210,30,1210 THE 890 30 CALL ADRESS (2,I2) THE 900 IF (I2) 1220,1230,40 THE 910 40 CALL ADRESS (1,I1) THE 920 IF (I1) 50,1230,50 THE 930 50 IF (NRMAX) 1240,1240,60 THE 940 60 IF (NERROR) 1180,70,1180 THE 950 70 IF (I1) 160,1230,80 THE 960 80 IE=0 THE 970 DO 150 J=1,NRMAX THE 980 II1=I1+J-1 THE 990 II2=I2+J-1 THE1000 IF (M-1) 1180,100,90 THE1010 90 RC(II2)=(RC(II1)-32.0)/1.8 THE1020 IF (RC(II2)+273.15) 110,150,150 THE1030 100 IF (RC(111)+273.15) 110,140,140 THE1040 110 IF (IE) 130,120,130 THE1050 120 CALL ERROR (230) THE1060 IE=1 THE1070 130 IF (M-1) 1180,140,150 THE1080 140 RC(II2)=(1.8*RC(II1))+32.0 THE1090 150 CONTINUE THE1100 GO TO 1180 THE1110 160 IF (M-1) 1180,180,170 THE1120 170 T=(ARGS(1)-32.)/1.8 THE1130 IF (T+273.15) 190,230,230 THE1140 180 IF (ARGS(1)+273.15) 190,220,220 THE1150 190 IF (IE) 210,200,210 THE1160 200 CALL ERROR (230) THE1170 IE=1 THE1180 210 IF (M-1) 1180,220,230 THE1190 220 T=(1.8*ARGS(1))+32.0 THE1200 230 DO 240 J=1,NRMAX THE1210 II2=I2+J-1 THE1220 240 RC(II2)=T THE1230 GO TO 1180 THE1240 C THIS IS FTOC THE1250 250 M=2 THE1260 GO TO 20 THE1270 C THIS IS ATOMIC WEIGHT THE1280 260 IF (NARGS-1) 1210,280,270 THE1290 270 CALL ERROR (221) THE1300 280 CALL ADRESS (1,I1) THE1310 IF (I1) 1220,1230,290 THE1320 290 IF (NROW-92) 300,310,310 THE1330 300 CALL ERROR (226) THE1340 310 IF (NERROR) 1180,320,1180 THE1350 320 IF (NROW-103) 330,340,340 THE1360 330 L=NROW THE1370 GO TO 350 THE1380 340 L=103 THE1390 350 DO 360 J=1,L THE1400 II1=I1+J-1 THE1410 360 RC(II1)=ATWT(J) THE1420 IF (NRMAX-L) 370,1180,1180 THE1430 370 NRMAX=L THE1440 GO TO 1180 THE1450 C THIS IS MOLWT THE1460 380 I=NARGS THE1470 CALL CKIND (I) THE1480 IF (I-1) 390,1220,1220 THE1490 390 N=NARGS/2 THE1500 IF (NARGS-2*N) 400,1210,400 THE1510 400 IF (NRMAX) 1240,1240,410 THE1520 410 CALL ADRESS (NARGS,I) THE1530 IF (I) 1220,1230,420 THE1540 420 WT=0.0 THE1550 IF (N-1) 1210,430,430 THE1560 430 IF (NERROR) 1180,440,1180 THE1570 440 DO 470 J=2,NARGS,2 THE1580 K=IARGS(J-1) THE1590 IF (K-103) 450,450,1250 THE1600 450 IF (K) 1250,1250,460 THE1610 460 WT=WT+ATWT(K)*FLOAT(IARGS(J)) THE1620 470 CONTINUE THE1630 DO 480 J=1,NRMAX THE1640 II=I+J-1 THE1650 480 RC(II)=WT THE1660 GO TO 1180 THE1670 C SPACE RESERVED FOR EINSTEIN, PFTRANS, PFATOMIC AND PARTFUNCTION THE1680 C THIS IS EINSTEIN THE1690 490 IF (NARGS-5) 500,1210,1210 THE1700 500 IF (NARGS-3) 1210,510,530 THE1710 510 CALL ADRESS (3,I) THE1720 IF (I) 1220,1230,520 THE1730 520 R=1.0 THE1740 II=IARGS(3) THE1750 GO TO 560 THE1760 530 CALL ADRESS (4,I) THE1770 IF (I) 1220,1230,540 THE1780 540 IF (KIND(3)-1) 1220,550,1220 THE1790 550 R=ARGS(3) THE1800 II=IARGS(4) THE1810 IF (R) 1250,1250,560 THE1820 560 CALL ADRESS (2,IFQ) THE1830 IF (IFQ) 570,1230,580 THE1840 570 F=ARGS(2) THE1850 IF (F) 1250,1250,580 THE1860 580 IF (NCOL-II-7) 1230,800,800 THE1870 590 IF (NARGS-3) 1210,600,1210 THE1880 600 CALL ADRESS (3,I) THE1890 IF (I) 1220,1230,610 THE1900 610 II=IARGS(3) THE1910 CALL ADRESS (2,IWT) THE1920 IF (IWT) 620,1230,630 THE1930 620 WT=ARGS(2) THE1940 IF (WT) 1250,1250,630 THE1950 630 IF (NCOL-II-6) 1230,800,800 THE1960 640 IF (NARGS-5) 1210,650,1210 THE1970 650 CALL ADRESS (5,I) THE1980 IF (I) 1220,1230,660 THE1990 660 II=IARGS(5) THE2000 CALL ADRESS (2,IWT) THE2010 IF (IWT) 670,1230,680 THE2020 670 WT=ARGS(2) THE2030 IF (WT) 1250,1250,680 THE2040 680 CALL ADRESS (3,IFQ) THE2050 IF (IFQ) 1220,1230,690 THE2060 690 CALL ADRESS (4,IG) THE2070 IF (IG) 1220,1230,700 THE2080 700 IF (NCOL-II-6) 1230,800,800 THE2090 710 IF (NARGS-4) 1210,720,1210 THE2100 720 CALL ADRESS (4,I) THE2110 IF (I) 1220,1230,730 THE2120 730 II=IARGS(4) THE2130 CALL ADRESS (2,IFQ) THE2140 IF (IFQ) 1220,1230,740 THE2150 740 CALL ADRESS (3,IG) THE2160 IF (IG) 1220,1230,750 THE2170 750 IWT=0 THE2180 IF (NCOL-II-3) 1230,800,800 THE2190 760 IF (NARGS-4) 1210,770,1210 THE2200 770 CALL ADRESS (4,I) THE2210 IF (I) 1220,1230,780 THE2220 780 IWT=0 THE2230 II=IARGS(4) THE2240 CALL ADRESS (2,IFQ) THE2250 IF (IFQ) 1220,1230,790 THE2260 790 CALL ADRESS (3,IG) THE2270 IF (IG) 1220,1230,800 THE2280 800 CALL ADRESS (1,ITP) THE2290 IF (ITP) 810,1230,820 THE2300 810 T=ARGS(1) THE2310 IF (T) 1250,1250,820 THE2320 820 IE=0 THE2330 IF (NRMAX) 1240,1240,830 THE2340 830 IF (NERROR) 1180,840,1180 THE2350 840 IF (L2-8) 890,850,850 THE2360 850 DO 880 J=NROW,1,-1 THE2370 IIG=IG+J-1 THE2380 IF (RC(IIG)) 1260,880,860 THE2390 860 KK=J THE2400 IF (KK-NS2) 890,890,870 THE2410 870 IF (L2-8) 890,890,1190 THE2420 880 CONTINUE THE2430 GO TO 1270 THE2440 890 DO 1170 J=1,NRMAX THE2450 IF (ITP-1) 910,900,900 THE2460 900 IIT=ITP+J-1 THE2470 T=RC(IIT) THE2480 IF (T) 1150,910,910 THE2490 910 IF (IWT) 940,920,930 THE2500 920 WT=1.0 THE2510 GO TO 940 THE2520 930 IIW=IWT+J-1 THE2530 WT=RC(IIW) THE2540 IF (WT) 1150,940,940 THE2550 940 IF (L2-8) 1000,950,950 THE2560 950 Q0=0. THE2570 Q1=0. THE2580 Q2=0. THE2590 DO 990 JJ=1,KK THE2600 IIF=IFQ+JJ-1 THE2610 IIG=IG+JJ-1 THE2620 E=RC(IIF) THE2630 G=RC(IIG) THE2640 IF (G) 1260,960,960 THE2650 960 IF (E) 1130,970,970 THE2660 970 X=1.43879D0*DBLE(E)/DBLE(T) THE2670 EXX=FDEXP(-X) THE2680 Q0=Q0+G*EXX THE2690 Q1=Q1+G*X*EXX THE2700 Q2=Q2+G*X*X*EXX THE2710 IF (L2-8) 990,990,980 THE2720 980 QQ(JJ)=G*EXX THE2730 990 CONTINUE THE2740 GO TO 1010 THE2750 1000 Q0=1.0 THE2760 Q1=0. THE2770 Q2=0. THE2780 IF (L2-6) 1020,1010,1010 THE2790 1010 FE=2.5*FLOG(T)+1.5*FLOG(WT)-3.66495+SNGL(FDLOG(Q0)) THE2800 HE=2.5D0+Q1/Q0 THE2810 S=FE+HE THE2820 CP=2.5D0+Q2/Q0-(Q1/Q0)*(Q1/Q0) THE2830 HBYT=HE*T THE2840 GO TO 1050 THE2850 1020 IF (IFQ-1) 1040,1030,1030 THE2860 1030 IIF=IFQ+J-1 THE2870 E=RC(IIF) THE2880 IF (E) 1130,1040,1040 THE2890 1040 X=1.43879D0*DBLE(E)/DBLE(T) THE2900 EXX=FDEXP(-X) THE2910 EXDIF=1.0D0-EXX THE2920 FE=-FDLOG(EXDIF)*R THE2930 HE=(X*EXX/EXDIF)*R THE2940 CP=R*X*X*EXX/(EXDIF*EXDIF) THE2950 S=FE+HE THE2960 HBYT=HE*T THE2970 1050 K=I+J-1 THE2980 IF (L2-8) 1060,1090,1100 THE2990 1060 IF (L2-6) 1070,1080,1080 THE3000 1070 RC(K)=E THE3010 K=K+NROW THE3020 1080 RC(K)=T THE3030 K=K+NROW THE3040 RC(K)=FE THE3050 K=K+NROW THE3060 RC(K)=HE THE3070 K=K+NROW THE3080 RC(K)=S THE3090 K=K+NROW THE3100 RC(K)=CP THE3110 K=K+NROW THE3120 RC(K)=HBYT THE3130 GO TO 1170 THE3140 1090 RC(K)=Q0 THE3150 K=K+NROW THE3160 RC(K)=Q1 THE3170 K=K+NROW THE3180 RC(K)=Q2 THE3190 GO TO 1170 THE3200 1100 IF (NCOL-II-KK) 1200,1110,1110 THE3210 1110 DO 1120 JJ=1,KK THE3220 RC(K)=QQ(JJ)/Q0 THE3230 1120 K=K+NROW THE3240 GO TO 1170 THE3250 1130 Q0=1.0 THE3260 Q1=0. THE3270 Q2=0. THE3280 IF (IE) 1010,1140,1010 THE3290 1140 CALL ERROR (229) THE3300 IE=1 THE3310 GO TO 1010 THE3320 1150 FE=0. THE3330 HE=0. THE3340 CP=0. THE3350 S=0. THE3360 HBYT=0. THE3370 IF (IE) 1050,1160,1050 THE3380 1160 CALL ERROR (229) THE3390 IE=1 THE3400 GO TO 1050 THE3410 1170 CONTINUE THE3420 1180 RETURN THE3430 1190 CALL ERROR (23) THE3440 GO TO 1180 THE3450 1200 CALL ERROR (17) THE3460 GO TO 1180 THE3470 1210 CALL ERROR (10) THE3480 GO TO 1180 THE3490 1220 CALL ERROR (20) THE3500 GO TO 1180 THE3510 1230 CALL ERROR (11) THE3520 GO TO 1180 THE3530 1240 CALL ERROR (9) THE3540 GO TO 1180 THE3550 1250 CALL ERROR (3) THE3560 GO TO 1180 THE3570 1260 CALL ERROR (25) THE3580 GO TO 1180 THE3590 1270 CALL ERROR (224) THE3600 GO TO 1180 THE3610 END THE3620 SUBROUTINE TPCTPT (V,T) TPC 10 C VERSION 5.00 TPCTPT 5/15/70 TPC 20 IF (V.LE.0.) GO TO 30 TPC 30 IF (V-AINT(V)) 30,10,30 TPC 40 10 IF (V.GT.4.) GO TO 20 TPC 50 T=3.6948*AINT(1./V)-1.6561*AINT(2./V)+.406*AINT(3./V)+2.7764*AINT(TPC 60 14./V) TPC 70 RETURN TPC 80 20 T=1.959964+2.3722712/V+2.8224986/V**2+2.5558497/V**3+1.5895341/V**TPC 90 14+.73289821/V**5 TPC 100 C 25 FORMAT (1X/10X,,* INFORMATIVE DIAGNOSTICS *V IMPROPER,) TPC 110 C 30 WRITE (IPRINT,25) TPC 120 30 RETURN TPC 130 END TPC 140 SUBROUTINE TRANSF TRA 10 C VERSION 5.00 TRANSF 5/15/70 TRA 20 C SUBROUTINE TRANSF R.V. 5/2/68 TRA 30 C * TRA 40 C SUBROUTINE TO PROVIDE TRANSFORMATIONS B=UAU(T) AND C=U(I)AU TRA 50 C L2=1 TRANSFORMATION B=UAU(T) TRA 60 C GENERAL FORMS OF TRANSFORM TRA 70 C M(XAXT) A(,) K,K U(,) N,K STORE IN C(,) TRA 80 C L2=2 BACK TRANSFORMATION C=U(T)ALL TRA 100 C GENERAL FORMS OF BACKTRANS TRA 110 C M(XTAX) A(,) N,N U(,) N,K STORE IN C(,) TRA 120 C * TRA 130 COMMON /SCRAT/ NS,NS2,A(13500) TRA 140 COMMON /BLOCRC/ NRC,RC(12600) TRA 150 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NTRA 160 1ARGS,VWXYZ(8),NERROR TRA 170 DIMENSION ARGS(100) TRA 180 EQUIVALENCE (ARGS(1),RC(12501)) TRA 190 COMMON /BLOCKE/ NAME(4),L1,L2,ISRFLG TRA 200 DIMENSION X(3000) TRA 210 DOUBLE PRECISION X,SUM TRA 220 EQUIVALENCE (X,A) TRA 230 C * TRA 240 C CHECK TO SEE IF WE HAVE CORRECT NUMBER OF ARGUMENTS TRA 250 C * TRA 260 IF (NARGS.NE.10) CALL ERROR (10) TRA 270 C * TRA 280 C CHECK TO SEE IF ALL ARGUMENTS ARE INTEGERS TRA 290 C * TRA 300 J=NARGS TRA 310 CALL CKIND (J) TRA 320 IF (J.NE.0) CALL ERROR (3) TRA 330 C * TRA 340 C CHECK TO SEE IF DIMENSIONS ARE CORRECT TRA 350 C * TRA 360 GO TO (30,40),L2 TRA 370 30 IF (IARGS(3).NE.IARGS(4).OR.IARGS(3).NE.IARGS(8)) CALL ERROR (3) TRA 440 GO TO 50 TRA 450 40 IF (IARGS(3).NE.IARGS(4).OR.IARGS(3).NE.IARGS(7)) CALL ERROR (3) TRA 460 C * TRA 470 C CHECK TO SEE IF DIMENSIONS ARE OUT OF RANGE TRA 480 C COMPUTE ADDRESSES TRA 490 C * TRA 500 50 IF (NARGS.EQ.10) GO TO 60 TRA 510 IARGS(12)=IARGS(L2+5) TRA 520 IARGS(11)=IARGS(L2+5) TRA 530 GO TO 70 TRA 540 60 IARGS(12)=IARGS(L2+6) TRA 550 IARGS(11)=IARGS(L2+6) TRA 560 GO TO 80 TRA 570 70 IARGS(10)=IARGS(NARGS) TRA 580 IARGS(9)=IARGS(NARGS-1) TRA 590 IARGS(8)=IARGS(NARGS-2) TRA 600 IARGS(7)=IARGS(NARGS-3) TRA 610 IARGS(6)=IARGS(5) TRA 620 IARGS(5)=IARGS(4) TRA 630 IARGS(4)=IARGS(3) TRA 640 80 J=3 TRA 650 CALL MTXCHK (J) TRA 660 IF (J-1) 110,90,100 TRA 670 90 CALL ERROR (3) TRA 680 RETURN TRA 690 100 CALL ERROR (17) TRA 700 RETURN TRA 710 C * TRA 720 C CHECK FOR PREVIOUS ERRORS TRA 730 C * TRA 740 110 IF (NERROR.NE.0) RETURN TRA 750 IROWA=IARGS(3) TRA 760 ISP=1 TRA 770 IROWU=IARGS(11) TRA 780 GO TO (120,130), L2 TRA 790 120 IADD1=1 TRA 800 IADD2=NROW TRA 810 GO TO 140 TRA 820 130 IADD1=NROW TRA 830 IADD2=1 TRA 840 140 DO 180 J=1,IROWU TRA 850 DO 170 I=1,IROWU TRA 860 IUP=IARGS(5)+(I-1)*IADD1 TRA 870 IA=IARGS(1) TRA 880 IUT=IARGS(5)+(J-1)*IADD1 TRA 890 ISX=NS2 TRA 900 DO 160 L=1,IROWA TRA 910 IU=IUP TRA 920 DO 150 K=1,IROWA TRA 930 X(ISX)=RC(IU)*RC(IA)*RC(IUT) TRA 940 ISX=ISX-1 TRA 950 IU=IU+IADD2 TRA 960 IA=IA+1 TRA 970 150 CONTINUE TRA 980 IA=IA+NROW-IROWA TRA 990 IUT=IUT+IADD2 TRA1000 160 CONTINUE TRA1010 CALL SORTSM (IROWA*IROWA,SUM) TRA1020 A(ISP)=SUM TRA1030 ISP=ISP+1 TRA1040 170 CONTINUE TRA1050 180 CONTINUE TRA1060 C * TRA1070 C STORE REULTS IN WORKSHEET TRA1080 C * TRA1090 IS=1 TRA1100 IC=IARGS(9) TRA1110 DO 200 J=1,IROWU TRA1120 DO 190 I=1,IROWU TRA1130 RC(IC)=A(IS) TRA1140 IS=IS+1 TRA1150 IC=IC+1 TRA1160 190 CONTINUE TRA1170 IC=IC+NROW-IROWU TRA1180 200 CONTINUE TRA1190 RETURN TRA1200 END TRA1210 SUBROUTINE TWOWAY (LL) TWO 10 C VERSION 5.00 TWOWAY 5/15/70 TWO 20 COMMON /BLOCRC/ NRC,RC(12600) TWO 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NTWO 40 1ARGS,VWXYZ(8),NERROR TWO 50 DIMENSION ARGS(100) TWO 60 EQUIVALENCE (ARGS(1),RC(12501)) TWO 70 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH TWO 80 COMMON /KFMT/ KFMT(100) TWO 90 COMMON /SCRAT/ NS,NS2,A(13500) TWO 100 COMMON /ABCDEF/ L(48) TWO 110 DIMENSION IIRGS(100) TWO 120 EQUIVALENCE (KFMT,IIRGS) TWO 130 DOUBLE PRECISION FDSQRT,DK2,SUM TWO 140 DIMENSION ASTO(120) TWO 150 EQUIVALENCE (ND1,KIND(100)), (ND2,KIND(99)), (ND3,KIND(98)), (ND4,TWO 160 1KIND(97)), (ND5,KIND(96)), (ND6,KIND(95)), (ND7,KIND(94)), (ND8,KITWO 170 2ND(93)), (ND9,KIND(92)), (ND10,KIND(91)), (ND11,KIND(90)), (ND12,KTWO 180 3IND(89)), (ND13,KIND(88)), (ND14,KIND(87)), (ND16,KIND(86)), (ND17TWO 190 4,KIND(85)), (ND18,KIND(84)), (ND19,KIND(83)) TWO 200 C ******************************************************************TWO 210 C OMNITAB TWOWAY ANALYSIS OF VARIANCE SUBROUTINE TWO 220 C WRITTEN BY DAVID HOGBEN, SEL, NBS. 4/17/69 VERSION. TWO 230 C TWO 240 C TWOWAY ANALYSIS FOR F = ,, C = ,, DATA IN ++ VECTORS START IN ++ TWO 250 C (WEIGHTS IN COL ++) TWO 260 C MEASUREMENTS ARE STORED IN THE COLUMN ROW BY ROW TWO 270 C LAST ARGUMENT USED ONLY IF WEIGHTS ARE UNEQUAL (E.G. IF ZERO WTS TWO 280 C FOR MISSING OBSERVATIONS OR REJECTED OUTLIERS) TWO 290 C COEFFICIENTS ARE STORED IN COL (X+R+C-1) TWO 300 C RESIDUALS ARE STORED IN COL (X+R+C) TWO 310 C STANDARD DEVIATIONS OF PREDICTED VALUES ARE IN COL (X+R+C+1) TWO 320 C SUM OF SQUARES ARE STORED IN COLUMN (X+R+C+2) TWO 330 C R*C MUST = NRMAX WHICH MUST BE LESS THAN OR EQUAL TO NO. OF ROWS TWO 340 C (X+R+C+2) MUST BE LESS THAN OR EQUAL TO THE NUMBER OF COLUMNS TWO 350 C R+C+6 MUST BE LESS THAN OR EQUAL TO NCOL TWO 360 C TUKEY,S TEST FOR NON-ADDITIIVITY IS NOT DONE IF WTS ARE SPECIFIED TWO 370 C IF ZERO WTS ARE USED FOR M.O. THE ESTIMATES GIVEN ARE THE SAME ASTWO 380 C THOSE OBTAINED FROM DATA AUGMENTED USING THE M.O. FORMULA TWO 390 C SIZE OF TABLED CONSTRAINED BY NS AND ORTHO TWO 400 C MID-RANGE SUBTRACTED BEFORE DOING FIT TWO 410 C AUTOMATIC OUTPUT USING READABLE FORMAT TWO 420 C TABLE OF STANDARDIZED RESIDUALS IS GIVEN ON PAGE TWO. TWO 430 C FORMAT STATEMENT NUMBERS ARE * TWO 440 C TWO 450 C ******************************************************************TWO 460 C LINES 10 TO 20 GIVE CONSTANTS TWO 470 IX1(I,J,IN)=IN+(I*(I-1))/2+J TWO 480 M1=IARGS(1) TWO 490 M2=IARGS(2) TWO 500 M3=IARGS(3) TWO 510 M4=M1*M2 TWO 520 M5=M1+M2-1 TWO 530 M6=M1-1 TWO 540 M7=M1+1 TWO 550 M8=M2-1 TWO 560 M9=M6*M8 TWO 570 M10=M4-1 TWO 580 M11=IARGS(4) TWO 590 IF (NARGS.EQ.5) M12=IARGS(5) TWO 600 M13=NARGS TWO 610 M14=1 TWO 620 M15=M9-1 TWO 630 M16=M6+M8 TWO 640 M17=M4/2 TWO 650 M20=M9 TWO 660 IF (M1.LT.2.OR.M2.LT.2) GO TO 90 TWO 670 M21=2*(M1+M2)+1 TWO 680 C LINES 30 TO 90 GIVE ERROR CHECKS TWO 690 IF (M13-4) 10,20,30 TWO 700 10 CALL ERROR (10) TWO 710 RETURN TWO 720 20 IF (IARGS(3)-IARGS(4)) 80,90,90 TWO 730 30 IF (M13-5) 40,40,10 TWO 740 40 IF (IARGS(5)-NCOL) 60,60,50 TWO 750 50 CALL ERROR (11) TWO 760 RETURN TWO 770 60 IF (IARGS(3)-IARGS(5)) 70,90,70 TWO 780 70 IF (IARGS(5)-IARGS(4)) 80,90,90 TWO 790 80 DO 110 I=1,M13 TWO 800 IF (KIND(I)) 90,100,90 TWO 810 90 CALL ERROR (3) TWO 820 RETURN TWO 830 100 IF (IARGS(I)) 50,50,110 TWO 840 110 CONTINUE TWO 850 IF (NRMAX-IARGS(1)*IARGS(2)) 120,130,120 TWO 860 120 CALL ERROR (16) TWO 870 RETURN TWO 880 130 IF (M5+M11+2.LT.NCOL.AND.M21+6.LT.NROW) GO TO 140 TWO 890 CALL ERROR (17) TWO 900 RETURN TWO 910 140 NARGS=M5 TWO 920 IF (M5+7.GT.NCOL) GO TO 10 TWO 930 DO 150 I=1,M5 TWO 940 KIND(I)=0 TWO 950 150 IARGS(I)=M11+I-1 TWO 960 CALL CHKCOL (J) TWO 970 IF (J.NE.0) GO TO 90 TWO 980 IF (NERROR.NE.0) RETURN TWO 990 C LINES 100 TO 150 CONSTRUCT DESIGN MATRIX TWO1000 K=IARGS(1)-1 TWO1010 DO 160 I=1,M4 TWO1020 M19=K+I TWO1030 160 RC(M19)=1.0 TWO1040 DO 180 I=2,M1 TWO1050 K1=IARGS(I) TWO1060 DO 170 K=1,M6 TWO1070 DO 170 J=1,M2 TWO1080 K2=K1+M2*(K-1)+J-1 TWO1090 RC(K2)=0. TWO1100 170 IF (K.EQ.I-1) RC(K2)=1.0 TWO1110 DO 180 J=1,M2 TWO1120 K2=K1+M2*(M1-1)+J-1 TWO1130 180 RC(K2)=-1.0 TWO1140 DO 200 I=M7,M5 TWO1150 DO 200 K=1,M1 TWO1160 DO 190 J=1,M8 TWO1170 K2=IARGS(I)+M2*(K-1)+J-1 TWO1180 RC(K2)=0.0 TWO1190 190 IF (J.EQ.I-M1) RC(K2)=1.0 TWO1200 K2=IARGS(I)+M2*K-1 TWO1210 200 RC(K2)=-1.0 TWO1220 C LINES 300 TO 325 CALL NEW ORTHO TWO1230 NARGS=M1+M2+6 TWO1240 IARGS(1)=M3 TWO1250 IARGS(2)=M11 TWO1260 DO 210 I=4,NARGS TWO1270 210 IARGS(I)=M11+I-4 TWO1280 CALL ADRESS (1,K) TWO1290 IF (M13.EQ.4) GO TO 220 TWO1300 IARGS(2)=M12 TWO1310 CALL ADRESS (2,J) TWO1320 J=J-1 TWO1330 220 CONS1=RC(K) TWO1340 CONS2=RC(K) TWO1350 DO 240 I=1,M4 TWO1360 IF (M13.EQ.4) GO TO 230 TWO1370 J=J+1 TWO1380 IF (RC(J)) 240,240,230 TWO1390 230 IF (RC(K).LT.CONS1) CONS1=RC(K) TWO1400 IF (RC(K).GT.CONS2) CONS2=RC(K) TWO1410 240 K=K+1 TWO1420 K=K-M4 TWO1430 B=(CONS1+CONS2)/2.0 TWO1440 DO 250 I=1,M4 TWO1450 M19=K-1+I TWO1460 250 RC(M19)=RC(M19)-B TWO1470 DO 260 I=1,NARGS TWO1480 260 KIND(I)=0 TWO1490 L2=4 TWO1500 IARGS(3)=M1+M2-1 TWO1510 GO TO 690 TWO1520 270 IF (NERROR.NE.0) RETURN TWO1530 C LINES 330 TO 360 COMPUTE COEFFICIENTS AND THEIR STD. DEVIATIONS TWO1540 CALL ADRESS (NARGS-3,K) TWO1550 ASTO(M1+11)=0. TWO1560 DO 280 I=1,M6 TWO1570 M19=I+K TWO1580 ASTO(I+11)=RC(M19) TWO1590 ASTO(M1+11)=ASTO(M1+11)-RC(M19) TWO1600 K3=12+M1+M2+I TWO1610 K4=K+M1+M8+I TWO1620 280 ASTO(K3)=RC(K4) TWO1630 K3=M1+M1+M2+11 TWO1640 ASTO(K3+1)=ASTO(K3) TWO1650 K4=K+M6+M2 TWO1660 ASTO(M5+13)=RC(K4) TWO1670 ASTO(M5+12)=0. TWO1680 DO 290 I=1,M8 TWO1690 K4=11+M1+I TWO1700 K5=K+M6+I TWO1710 ASTO(K4)=RC(K5) TWO1720 K4=K5+M8+M1 TWO1730 K6=K3+I+1 TWO1740 ASTO(K6)=RC(K4) TWO1750 290 ASTO(M5+12)=ASTO(M5+12)-RC(K5) TWO1760 ASTO(M21+11)=ASTO(M21+10) TWO1770 C K5=K+M21+7 TWO1780 C DO 285 I=1,6 TWO1790 C K5=K5-1 TWO1800 C 285 RC(K5)=RC(K5-4) TWO1810 C LINES 400 TO 430 COMPUTE TERMS FOR ANOVA TWO1820 IF (LL.EQ.7) GO TO 350 TWO1830 IF (M13.EQ.5) GO TO 430 TWO1840 300 CALL ADRESS (NARGS,K) TWO1850 A(1)=0. TWO1860 A(2)=0. TWO1870 DO 310 I=1,M6 TWO1880 M19=K+I TWO1890 310 A(1)=A(1)+RC(M19) TWO1900 DO 320 I=1,M8 TWO1910 K4=M6+I+K TWO1920 320 A(2)=A(2)+RC(K4) TWO1930 K4=K+M5 TWO1940 A(3)=RC(K4) TWO1950 A(4)=RC(K4+1)-RC(K) TWO1960 A(5)=A(1)/FLOAT(M6) TWO1970 A(6)=A(2)/FLOAT(M8) TWO1980 A(7)=A(3)/FLOAT(M9) TWO1990 A(8)=A(5)/A(7) TWO2000 A(9)=A(6)/A(7) TWO2010 CALL PROB (FLOAT(M6),FLOAT(M9),A(8),A(10)) TWO2020 CALL PROB (FLOAT(M8),FLOAT(M9),A(9),A(11)) TWO2030 CALL RFORMT (A(1),4,8,NW1,NDEC1,20,A(1),A(1),0,0) TWO2040 CALL RFORMT (A(5),3,8,NW2,NDEC2,20,A(1),A(1),0,0) TWO2050 CALL PAGE (4) TWO2060 WRITE (IPRINT,1680) M1,M2 TWO2070 IF (M13.EQ.5) GO TO 510 TWO2080 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(1),A(101),25-NW1,0) TWO2090 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(5),A(126),25-NW2,0) TWO2100 C LINES 500 TO 550 PRINT ANOVA WHEN ALL WEIGHTS EQUAL ONE. TWO2110 WRITE (IPRINT,1690) M6,(A(I),I=101,150),A(8),A(10) TWO2120 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(2),A(101),25-NW1,0) TWO2130 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(6),A(126),25-NW2,0) TWO2140 WRITE (IPRINT,1700) M8,(A(I),I=101,150),A(9),A(11) TWO2150 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(3),A(201),25-NW1,0) TWO2160 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(7),A(226),25-NW2,0) TWO2170 WRITE (IPRINT,1710) M9,(A(I),I=201,250) TWO2180 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(4),A(101),25-NW1,0) TWO2190 WRITE (IPRINT,1720) M10,(A(I),I=101,125) TWO2200 C LINES 600 TO 645 COMPUTE AND PRINT FOR TUKEY'S TEST TWO2210 CALL ADRESS (1,J) TWO2220 A(12)=0. TWO2230 DO 330 I1=1,M1 TWO2240 DO 330 I2=1,M2 TWO2250 J1=J+M2*(I1-1)+I2-1 TWO2260 M19=M1+11+I2 TWO2270 330 A(12)=A(12)+ASTO(I1+11)*ASTO(M19)*RC(J1) TWO2280 A(12)=(A(12)*A(12))/((A(1)/FLOAT(M1))*(A(2)/FLOAT(M2))) TWO2290 A(13)=A(3)-A(12) TWO2300 A(6)=A(13)/FLOAT(M9-1) TWO2310 A(16)=A(12)/A(6) TWO2320 CALL PROB (1.,FLOAT(M9)-1.,A(16),A(17)) TWO2330 A(5)=A(12) TWO2340 A(14)=A(3) TWO2350 CALL RFORMT (A(12),3,8,NW1,NDEC1,20,A(1),A(1),0,0) TWO2360 CALL RFORMT (A(5),3,8,NW2,NDEC2,20,A(1),A(1),0,0) TWO2370 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(12),A(101),25-NW1,0) TWO2380 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(5),A(126),25-NW2,0) TWO2390 WRITE (IPRINT,1740) M14,(A(I),I=101,150),A(16),A(17) TWO2400 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(13),A(101),25-NW1,0) TWO2410 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(6),A(126),25-NW2,0) TWO2420 WRITE (IPRINT,1750) M15,(A(I),I=101,150) TWO2430 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(14),A(101),25-NW1,0) TWO2440 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(7),A(126),25-NW2,0) TWO2450 WRITE (IPRINT,1710) M9,(A(I),I=101,150) TWO2460 WRITE (IPRINT,1760) TWO2470 DO 340 I=1,4 TWO2480 340 ASTO(I)=A(I) TWO2490 C LINES 650 TO 690 PRINT COEFFICIENTS AND THEIR STD. DEVIATIONS TWO2500 350 CALL ADRESS (1,K) TWO2510 DO 360 I=1,M4 TWO2520 K5=K-1+I TWO2530 360 RC(K5)=RC(K5)+B TWO2540 J=K TWO2550 CALL ADRESS (NARGS-3,K) TWO2560 K5=K+M21+7 TWO2570 DO 370 I=1,6 TWO2580 K5=K5-1 TWO2590 370 RC(K5)=RC(K5-4) TWO2600 DO 380 I=1,M21 TWO2610 K5=K+I TWO2620 380 RC(K5)=ASTO(I+11) TWO2630 RC(K)=RC(K)+B TWO2640 K5=K+M21+1 TWO2650 A(1000)=RC(K5) TWO2660 RC(K5)=RC(K5+3) TWO2670 CALL ADRESS (2,J1) TWO2680 CALL ADRESS (NARGS,J2) TWO2690 A(1002)=0.0 TWO2700 SUM=0.0D0 TWO2710 DO 390 I=1,M4 TWO2720 A(1002)=A(1002)+RC(J1) TWO2730 SUM=SUM+RC(J1)*RC(J)**2 TWO2740 J=J+1 TWO2750 390 J1=J1+1 TWO2760 J1=J2+M1+M2 TWO2770 RC(J1)=SUM TWO2780 RC(J1+1)=RC(J1+1)+B*FSQRT(A(1002)) TWO2790 RC(J2)=RC(J1+1)**2 TWO2800 IF (LL.EQ.6) GO TO 400 TWO2810 RC(K5)=A(1000) TWO2820 RETURN TWO2830 400 K5=K+M5+2 TWO2840 CALL RFORMT (RC(K),M5+2,8,NW3,NDEC3,20,A(1),A(1),0,0) TWO2850 CALL RFORMT (RC(K5),M5+3,8,NW4,NDEC4,20,A(1),A(1),0,0) TWO2860 CALL RFORMT (A(1),1,8,NW3,NDEC3,0,RC(K),A(101),25-NW3,0) TWO2870 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,RC(K5),A(126),25-NW4,0) TWO2880 WRITE (IPRINT,1770) (A(J),J=101,150) TWO2890 K5=K+M21+1 TWO2900 RC(K5)=A(1000) TWO2910 DO 410 I=1,M1 TWO2920 K5=K+I TWO2930 K6=K5+M5+2 TWO2940 CALL RFORMT (A(1),1,8,NW3,NDEC3,0,RC(K5),A(101),25-NW3,0) TWO2950 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,RC(K6),A(125),25-NW4,0) TWO2960 410 WRITE (IPRINT,1780) I,(A(J),J=101,150) TWO2970 WRITE (IPRINT,1760) TWO2980 DO 420 I=1,M2 TWO2990 K5=K+M1+I TWO3000 K6=K5+M5+2 TWO3010 CALL RFORMT (A(1),1,8,NW3,NDEC3,0,RC(K5),A(101),25-NW3,0) TWO3020 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,RC(K6),A(126),25-NW4,0) TWO3030 420 WRITE (IPRINT,1790) I,(A(J),J=101,150) TWO3040 K6=K+M21+4 TWO3050 CALL RFORMT (A(1),1,8,NW4,NDEC4,0,RC(K6),A(101),50-NW4,0) TWO3060 WRITE (IPRINT,1760) TWO3070 WRITE (IPRINT,1800) (A(J),J=101,150) TWO3080 ASTO(1)=ASTO(1)+ASTO(2)+ASTO(3) TWO3090 ASTO(2)=ABS(ASTO(4)-ASTO(1))/ASTO(4) TWO3100 IF (ASTO(2).GT.5.E-7) CALL ERROR (228) TWO3110 GO TO 630 TWO3120 C LINES 700 TO 780 GIVE ANOVA WHEN WEIGHTS ARE SPECIFIED TWO3130 430 CALL ADRESS (2,J) TWO3140 C CHECK ON WEIGHTS TWO3150 K5=J-1 TWO3160 DO 470 I1=1,M1 TWO3170 M31=0 TWO3180 DO 460 I2=1,M2 TWO3190 K5=K5+1 TWO3200 IF (RC(K5)) 440,450,460 TWO3210 440 CALL ERROR (223) TWO3220 RETURN TWO3230 450 M31=M31+1 TWO3240 M9=M9-1 TWO3250 460 CONTINUE TWO3260 IF (M31.NE.M2) GO TO 470 TWO3270 CALL ERROR (224) TWO3280 RETURN TWO3290 470 CONTINUE TWO3300 K5=J-1 TWO3310 DO 500 I1=1,M2 TWO3320 M31=0 TWO3330 DO 490 I2=1,M1 TWO3340 K5=K5+1 TWO3350 IF (RC(K5)) 480,480,490 TWO3360 480 M31=M31+1 TWO3370 490 CONTINUE TWO3380 IF (M3.NE.M1) GO TO 500 TWO3390 CALL ERROR (224) TWO3400 RETURN TWO3410 500 CONTINUE TWO3420 M10=M6+M8+M9 TWO3430 GO TO 300 TWO3440 510 J=5 TWO3450 DO 520 I=1,M8 TWO3460 IARGS(J)=M11+M6+I TWO3470 520 J=J+1 TWO3480 DO 530 I=1,M6 TWO3490 IARGS(J)=M11+I TWO3500 530 J=J+1 TWO3510 DO 540 I=1,11 TWO3520 540 ASTO(I)=A(I) TWO3530 CALL ADRESS (1,J) TWO3540 CALL ADRESS (2,K) TWO3550 DO 550 I=1,M17 TWO3560 K5=J-1+I TWO3570 K6=J+M4-I TWO3580 A(20)=RC(K5) TWO3590 RC(K5)=RC(K6) TWO3600 RC(K6)=A(20) TWO3610 K5=K-1+I TWO3620 K6=K+M4-I TWO3630 A(20)=RC(K5) TWO3640 RC(K5)=RC(K6) TWO3650 550 RC(K6)=A(20) TWO3660 GO TO 690 TWO3670 560 CALL ADRESS (1,J) TWO3680 CALL ADRESS (2,K) TWO3690 CALL ADRESS (NARGS-2,K1) TWO3700 CALL ADRESS (NARGS-1,K2) TWO3710 DO 570 I=1,M17 TWO3720 K5=J-1+I TWO3730 K6=J+M4-I TWO3740 A(20)=RC(K5) TWO3750 RC(K5)=RC(K6) TWO3760 RC(K6)=A(20) TWO3770 K5=K2-1+I TWO3780 K6=K2+M4-I TWO3790 A(20)=RC(K5) TWO3800 RC(K5)=RC(K6) TWO3810 RC(K6)=A(20) TWO3820 K5=K1-1+I TWO3830 K6=K1+M4-I TWO3840 A(20)=RC(K5) TWO3850 RC(K5)=RC(K6) TWO3860 RC(K6)=A(20) TWO3870 K5=K-1+I TWO3880 K6=K+M4-I TWO3890 A(20)=RC(K5) TWO3900 RC(K5)=RC(K6) TWO3910 570 RC(K6)=A(20) TWO3920 A(18)=0. TWO3930 CALL ADRESS (NARGS,K) TWO3940 DO 580 I=1,M8 TWO3950 K5=I+K TWO3960 580 A(18)=A(18)+RC(K5) TWO3970 A(17)=0. TWO3980 DO 590 I=1,M6 TWO3990 K5=M2+I+K-1 TWO4000 590 A(17)=A(17)+RC(K5) TWO4010 J1=M21-2 TWO4020 K5=201 TWO4030 K6=K+1 TWO4040 DO 600 I=1,J1 TWO4050 A(K5)=RC(K6) TWO4060 K5=K5+1 TWO4070 600 K6=K6+1 TWO4080 K5=K+1 TWO4090 K6=201+M8 TWO4100 J1=K+M16+4 TWO4110 J2=204+M16+M8 TWO4120 DO 610 I=1,M6 TWO4130 RC(K5)=A(K6) TWO4140 RC(J1)=A(J2) TWO4150 K5=K5+1 TWO4160 K6=K6+1 TWO4170 J1=J1+1 TWO4180 610 J2=J2+1 TWO4190 J1=K+M16+M8+3 TWO4200 J2=204+M16 TWO4210 DO 620 I=1,M8 TWO4220 RC(K5)=A(I+200) TWO4230 RC(J1)=A(J2) TWO4240 K5=K5+1 TWO4250 J1=J1+1 TWO4260 620 J2=J2+1 TWO4270 A(19)=A(17)/FLOAT(M6) TWO4280 A(20)=A(18)/FLOAT(M8) TWO4290 A(21)=A(19)/ASTO(7) TWO4300 CALL PROB (FLOAT(M6),FLOAT(M9),A(21),A(22)) TWO4310 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(17),A(101),25-NW1,0) TWO4320 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(19),A(126),25-NW2,0) TWO4330 WRITE (IPRINT,1690) M6,(A(I),I=101,150),A(21),A(22) TWO4340 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,A(18),A(101),25-NW1,0) TWO4350 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,A(20),A(126),25-NW2,0) TWO4360 WRITE (IPRINT,1700) M8,(A(I),I=101,150) TWO4370 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ASTO(3),A(101),25-NW1,0) TWO4380 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,ASTO(7),A(126),25-NW2,0) TWO4390 WRITE (IPRINT,1710) M9,(A(I),I=101,150) TWO4400 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ASTO(4),A(101),25-NW1,0) TWO4410 WRITE (IPRINT,1720) M10,(A(I),I=101,125) TWO4420 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ASTO(1),A(101),25-NW1,0) TWO4430 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,ASTO(5),A(126),25-NW2,0) TWO4440 WRITE (IPRINT,1690) M6,(A(I),I=101,150) TWO4450 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ASTO(2),A(101),25-NW1,0) TWO4460 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,ASTO(6),A(126),25-NW2,0) TWO4470 WRITE (IPRINT,1700) M8,(A(I),I=101,150),ASTO(9),ASTO(11) TWO4480 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ASTO(3),A(101),25-NW1,0) TWO4490 CALL RFORMT (A(1),1,8,NW2,NDEC2,0,ASTO(7),A(126),25-NW2,0) TWO4500 WRITE (IPRINT,1710) M9,(A(I),I=101,150) TWO4510 CALL RFORMT (A(1),1,8,NW1,NDEC1,0,ASTO(4),A(101),25-NW1,0) TWO4520 WRITE (IPRINT,1720) M10,(A(I),I=101,125) TWO4530 M31=M5+M9 TWO4540 M32=M4-M31 TWO4550 WRITE (IPRINT,1730) M31,M32,M12 TWO4560 CALL ADRESS (NARGS-3,K) TWO4570 K5=K+M6+M2+M2 TWO4580 K6=K+M1+M2 TWO4590 K3=M1+M1+M2+12 TWO4600 ASTO(K3)=RC(K5) TWO4610 ASTO(M21+11)=RC(K6) TWO4620 GO TO 350 TWO4630 630 CALL PAGE (4) TWO4640 WRITE (IPRINT,1810) M1,M2 TWO4650 M31=MIN0(15,M2) TWO4660 DO 640 I=1,M31 TWO4670 640 KIND(I)=I TWO4680 WRITE (IPRINT,1820) (KIND(I),I=1,M31) TWO4690 WRITE (IPRINT,1830) TWO4700 CALL ADRESS (NARGS-2,J) TWO4710 CALL ADRESS (NARGS-1,K3) TWO4720 IF (M13.EQ.5) KIND(2)=0 TWO4730 IF (M13.EQ.5) CALL ADRESS (2,M32) TWO4740 DO 670 I=1,M4 TWO4750 IF (M13.EQ.5) GO TO 650 TWO4760 A(I)=RC(J)/FSQRT(RC(K6)**2-RC(K3)**2) TWO4770 GO TO 660 TWO4780 650 IF (RC(M32).GT.0.0) A(I)=RC(J)/FSQRT((RC(K6)**2)/RC(M32)-RC(K3)**2TWO4790 1) TWO4800 IF (RC(M32).LE.0.0) A(I)=0.0 TWO4810 M32=M32+1 TWO4820 660 J=J+1 TWO4830 670 K3=K3+1 TWO4840 DO 680 I=1,M1 TWO4850 WRITE (IPRINT,1760) TWO4860 M31=M2*(I-1) TWO4870 KA=M31+M2 TWO4880 KB=M31+1 TWO4890 680 WRITE (IPRINT,1840) I,(A(K),K=KB,KA) TWO4900 RETURN TWO4910 C THIS IS NEW ORTHO - SFIT PORTION TWO4920 690 NMUI=1 TWO4930 CALL ADRESS (1,IIRGS(1)) TWO4940 CALL ADRESS (2,IIRGS(2)) TWO4950 NST=1 TWO4960 NEND=NARGS TWO4970 DO 700 I=4,NEND TWO4980 CALL ADRESS (I,IIRGS(I)) TWO4990 700 CONTINUE TWO5000 M=IARGS(3) TWO5010 N=NRMAX TWO5020 FN=N TWO5030 SU=0.0 TWO5040 L22=IIRGS(2) TWO5050 L22A=L22 TWO5060 DO 730 I=1,N TWO5070 IF (RC(L22A)) 710,730,720 TWO5080 710 CALL ERROR (25) TWO5090 RETURN TWO5100 720 SU=SU+1.0 TWO5110 730 L22A=L22A+1 TWO5120 FM=M TWO5130 IF (SU-FM) 740,750,760 TWO5140 740 CALL ERROR (24) TWO5150 RETURN TWO5160 750 DENOM=1.0 TWO5170 GO TO 770 TWO5180 760 DENOM=FSQRT(SU-FM) TWO5190 770 NPM=N+M TWO5200 M31=M-1 TWO5210 M32=M+1 TWO5220 N1=N-1 TWO5230 N2=N+1 TWO5240 MD1=(M*(M32))/2 TWO5250 ND1=M32*NPM TWO5260 ND2=M*NPM TWO5270 MD3=ND2+N TWO5280 ND3=ND1 TWO5290 ND4=ND3+NPM TWO5300 ND5=ND4+NPM TWO5310 ND6=ND5+M32 TWO5320 ND66=MD1+M TWO5330 ND7=ND6+ND66 TWO5340 ND8=ND7+ND66 TWO5350 ND9=ND8+M32 TWO5360 ND10=ND9+M TWO5370 ND11=ND10+M TWO5380 ND12=ND11+M TWO5390 ND13=ND12+MD1 TWO5400 ND14=ND13+M32 TWO5410 ND16=ND14+M TWO5420 ND17=ND16+M TWO5430 ND18=ND17+M TWO5440 ND19=ND18+NPM TWO5450 ND20=ND19+N TWO5460 IF (ND20.GT.NS) CALL ERROR (23) TWO5470 IF (NERROR.NE.0) RETURN TWO5480 NRBAR=1 TWO5490 I=4 TWO5500 MXARGS=M+4 TWO5510 L44=MXARGS-1 TWO5520 J=1 TWO5530 DO 790 I1=I,L44 TWO5540 K1=J TWO5550 L33=IIRGS(I1) TWO5560 K2=K1 TWO5570 DO 780 I2=1,N TWO5580 A(K2)=RC(L33) TWO5590 K2=K2+1 TWO5600 780 L33=L33+1 TWO5610 790 J=J+NPM TWO5620 K1=N2 TWO5630 DO 810 K=1,M TWO5640 K2=K1 TWO5650 DO 800 I=1,M TWO5660 A(K2)=0. TWO5670 800 K2=K2+1 TWO5680 K2=K1+K-1 TWO5690 K1=K1+NPM TWO5700 810 A(K2)=1.0 TWO5710 NBEI=1 TWO5720 NRHI=1 TWO5730 I18=1+ND13 TWO5740 NGAI=2 TWO5750 NSII=2 TWO5760 NDEI=1 TWO5770 NNUI=1 TWO5780 LZ1=1 TWO5790 LZ2=1 TWO5800 K=1 TWO5810 820 NTHI=1 TWO5820 830 NALI=1 TWO5830 NOMI=1 TWO5840 NJ=ND3+N+1 TWO5850 DO 840 J=1,M TWO5860 A(NJ)=0. TWO5870 840 NJ=NJ+1 TWO5880 850 KD1=(K-1)*NPM TWO5890 I1=ND3+1 TWO5900 I2=KD1+1 TWO5910 L22A=L22 TWO5920 DO 860 I=1,N TWO5930 A(I1)=A(I2)*RC(L22A) TWO5940 L22A=L22A+1 TWO5950 I1=I1+1 TWO5960 860 I2=I2+1 TWO5970 GO TO (870,900), NOMI TWO5980 870 IA1=1 TWO5990 IA2=ND5+1 TWO6000 DO 890 I=1,K TWO6010 I2=IA1 TWO6020 SUM=0.0 TWO6030 J2=ND3+1 TWO6040 DO 880 J=1,NPM TWO6050 SUM=SUM+A(J2)*A(I2) TWO6060 I2=I2+1 TWO6070 880 J2=J2+1 TWO6080 A(IA2)=SUM TWO6090 IA1=IA1+NPM TWO6100 890 IA2=IA2+1 TWO6110 GO TO 930 TWO6120 900 DK2=0. TWO6130 I1=(K-1)*NPM+1 TWO6140 IND3=ND3+1 TWO6150 DO 910 I=1,NPM TWO6160 DK2=DK2+A(IND3)*A(I1) TWO6170 I1=I1+1 TWO6180 910 IND3=IND3+1 TWO6190 DK=FDSQRT(DK2) TWO6200 A(I18)=DK TWO6210 I18=I18+1 TWO6220 K1=(K-1)*NPM+1 TWO6230 DO 920 I=1,NPM TWO6240 A(K1)=A(K1)/DK TWO6250 920 K1=K1+1 TWO6260 NOMI=1 TWO6270 GO TO 850 TWO6280 930 GO TO (940,1000), NDEI TWO6290 940 LZ1=-LZ1 TWO6300 IF (LZ1) 990,950,950 TWO6310 950 K1=K-1 TWO6320 IRUTH=ND5+1 TWO6330 DO 960 I=1,K1 TWO6340 A(IRUTH)=-A(IRUTH) TWO6350 960 IRUTH=IRUTH+1 TWO6360 IRUTH=K+ND5 TWO6370 A(IRUTH)=1.0 TWO6380 J2=ND4+1 TWO6390 DO 980 I=1,NPM TWO6400 SUM=0.0 TWO6410 J1=I TWO6420 J3=ND5+1 TWO6430 DO 970 J=1,K TWO6440 SUM=SUM+A(J1)*A(J3) TWO6450 J1=J1+NPM TWO6460 970 J3=J3+1 TWO6470 A(J2)=SUM TWO6480 980 J2=J2+1 TWO6490 GO TO 1090 TWO6500 990 ISAL=I18+M32 TWO6510 IRUTH=ND5+K TWO6520 A(ISAL)=FSQRT(A(IRUTH)) TWO6530 GO TO 950 TWO6540 1000 LZ2=-LZ2 TWO6550 IF (LZ2) 1010,950,950 TWO6560 1010 DO 1020 I=1,M TWO6570 IND5=ND5+I TWO6580 IND9=ND9+I TWO6590 IND8=ND8+I TWO6600 A(IND8)=A(IND5) TWO6610 1020 A(IND9)=A(IND5)*A(IND5) TWO6620 A(IND8+1)=A(IND5+1) TWO6630 A(ND10+1)=A(IND8+1)-A(ND9+1) TWO6640 IND10=ND10+1 TWO6650 IND9=ND9+1 TWO6660 DO 1030 J=1,M TWO6670 IND10=IND10+1 TWO6680 IND9=IND9+1 TWO6690 1030 A(IND10)=A(IND10-1)-A(IND9) TWO6700 FI=1.0 TWO6710 IND10=ND10 TWO6720 IND11=ND11 TWO6730 DO 1080 I=1,M TWO6740 IND10=IND10+1 TWO6750 IND11=IND11+1 TWO6760 IF (FN-FI) 1070,1070,1040 TWO6770 1040 IF (A(IND10)) 1050,1060,1060 TWO6780 1050 A(IND11)=-FSQRT(ABS(A(IND10))/(FN-FI)) TWO6790 GO TO 1080 TWO6800 1060 A(IND11)=FSQRT(A(IND10)/(FN-FI)) TWO6810 GO TO 1080 TWO6820 1070 A(IND10)=-1.0 TWO6830 1080 FI=FI+1.0 TWO6840 GO TO 950 TWO6850 1090 GO TO (1100,1120,1250), NTHI TWO6860 1100 K1=(K-1)*NPM+1 TWO6870 IND4=ND4+1 TWO6880 DO 1110 I=1,NPM TWO6890 A(K1)=A(IND4) TWO6900 K1=K1+1 TWO6910 1110 IND4=IND4+1 TWO6920 GO TO 1210 TWO6930 1120 IND18=ND18+1 TWO6940 IND4=ND4+1 TWO6950 DO 1130 I=1,N TWO6960 A(IND18)=A(IND4) TWO6970 IND18=IND18+1 TWO6980 1130 IND4=IND4+1 TWO6990 NI=N+1 TWO7000 DO 1140 I=1,M TWO7010 KK1=ND18+NI TWO7020 IND4=ND4+NI TWO7030 A(KK1)=-A(IND4) TWO7040 1140 NI=NI+1 TWO7050 IND4=ND4 TWO7060 IND19=ND19 TWO7070 DO 1150 I=1,N TWO7080 IND4=IND4+1 TWO7090 IND19=IND19+1 TWO7100 1150 A(IND19)=A(IND4) TWO7110 IF (NARGS-MXARGS) 1200,1180,1160 TWO7120 1160 L66=IIRGS(MXARGS+1)-1 TWO7130 L66A=L66 TWO7140 IND4=ND4 TWO7150 DO 1170 I=1,N TWO7160 L66A=L66A+1 TWO7170 IND4=IND4+1 TWO7180 1170 RC(L66A)=A(IND4) TWO7190 1180 L55=IIRGS(MXARGS) TWO7200 L55A=L55-1 TWO7210 NI=N+ND4 TWO7220 DO 1190 I=1,M TWO7230 NI=NI+1 TWO7240 L55A=L55+1 TWO7250 1190 RC(L55A)=-A(NI) TWO7260 1200 NTHI=3 TWO7270 GO TO 1100 TWO7280 1210 GO TO (1220,1230), NALI TWO7290 1220 NOMI=2 TWO7300 NALI=2 TWO7310 GO TO 850 TWO7320 1230 IF (K-M) 1240,1280,1280 TWO7330 1240 K=K+1 TWO7340 GO TO 820 TWO7350 1250 GO TO (1260,1270), NNUI TWO7360 1260 NNUI=2 TWO7370 GO TO 1370 TWO7380 1270 SS=DK/DENOM TWO7390 SSQ=SS*SS TWO7400 GO TO 1370 TWO7410 1280 GO TO (1290,1250), NBEI TWO7420 1290 K1=1 TWO7430 DO 1310 I=1,M TWO7440 I1=I*N+(I-1)*M TWO7450 DO 1300 J=1,I TWO7460 I2=J+I1 TWO7470 K2=K1+ND12 TWO7480 A(K2)=A(I2) TWO7490 1300 K1=K1+1 TWO7500 1310 CONTINUE TWO7510 NDEI=2 TWO7520 NBEI=2 TWO7530 NTHI=2 TWO7540 K=K+1 TWO7550 GO TO (1250,1320), NGAI TWO7560 1320 CONTINUE TWO7570 DO 1340 IL=1,M TWO7580 LOC=IX1(IL,0,ND6)+1 TWO7590 DO 1340 J=1,IL TWO7600 SUM=0. TWO7610 DO 1330 KK=IL,M TWO7620 LOC1=IX1(KK,IL,ND12) TWO7630 LOC2=IX1(KK,J,ND12) TWO7640 1330 SUM=SUM+A(LOC1)*A(LOC2) TWO7650 A(LOC)=SUM TWO7660 1340 LOC=LOC+1 TWO7670 J1=3+ND6 TWO7680 J=ND16+2 TWO7690 A(ND16+1)=FSQRT(A(ND6+1)) TWO7700 DO 1350 I=2,M TWO7710 IF (M.EQ.1) GO TO 1360 TWO7720 A(J)=FSQRT(A(J1)) TWO7730 J=J+1 TWO7740 1350 J1=J1+I+1 TWO7750 1360 NGAI=1 TWO7760 GO TO 1250 TWO7770 1370 GO TO (1380,1420), NRHI TWO7780 1380 IF (NRBAR) 1390,1460,1390 TWO7790 1390 NRBAR=NRBAR-1 TWO7800 NTHI=2 TWO7810 NRHI=2 TWO7820 L11=IIRGS(1)-1 TWO7830 L11A=L11-1 TWO7840 I1=ND2+1 TWO7850 DO 1400 I=1,N TWO7860 A(I1)=RC(L11A) TWO7870 L11A=L11A+1 TWO7880 1400 I1=I1+1 TWO7890 I1=MD3+1 TWO7900 DO 1410 I=1,M TWO7910 A(I1)=0. TWO7920 1410 I1=I1+1 TWO7930 GO TO 830 TWO7940 1420 GO TO (1380,1430), NSII TWO7950 1430 IND7=ND7+1 TWO7960 IND6=ND6+1 TWO7970 DO 1440 I=1,MD1 TWO7980 A(IND7)=SSQ*A(IND6) TWO7990 IND7=IND7+1 TWO8000 1440 IND6=IND6+1 TWO8010 IND16=ND16+1 TWO8020 IND17=ND17+1 TWO8030 DO 1450 I=1,M TWO8040 A(IND17)=SS*A(IND16) TWO8050 IND16=IND16+1 TWO8060 1450 IND17=IND17+1 TWO8070 GO TO 1380 TWO8080 1460 L55A=L55+M TWO8090 ISF=1 TWO8100 L55B=L55A+M-1 TWO8110 IF (L55B.LE.NROW+L55-1) GO TO 1470 TWO8120 IF (M.GE.NROW) GO TO 1580 TWO8130 ISF=2 TWO8140 L55B=L55+NROW-1 TWO8150 1470 IND17=ND17+1 TWO8160 DO 1480 I=L55A,L55B TWO8170 RC(I)=A(IND17) TWO8180 1480 IND17=IND17+1 TWO8190 GO TO (1490,1580), ISF TWO8200 1490 IMS=NROW-2*M TWO8210 IF (IMS.GT.6) IMS=6 TWO8220 GO TO (1570,1560,1550,1540,1530,1500), IMS TWO8230 1500 L11A=IIRGS(1) TWO8240 L22A=L22 TWO8250 YBAR=0.0 TWO8260 WSUM=0.0 TWO8270 DO 1510 I=1,N TWO8280 WSUM=WSUM+RC(L22A) TWO8290 YBAR=YBAR+RC(L22A)*RC(L11A) TWO8300 L22A=L22A+1 TWO8310 1510 L11A=L11A+1 TWO8320 YBAR=YBAR/WSUM TWO8330 L11A=IIRGS(1) TWO8340 L22A=L22 TWO8350 YYBAR=0. TWO8360 DO 1520 I=1,N TWO8370 YYBAR=RC(L22A)*(RC(L11A)-YBAR)**2+YYBAR TWO8380 L22A=L22A+1 TWO8390 1520 L11A=L11A+1 TWO8400 R2=1.-SSQ*(SU-FM)/YYBAR TWO8410 IF (R2.LT.0.) R2=0.0 TWO8420 IF (R2.GT.1.0) R2=1.0 TWO8430 RC(L55B+6)=R2 TWO8440 1530 RC(L55B+5)=SSQ TWO8450 1540 RC(L55B+4)=SS TWO8460 1550 RC(L55B+3)=SU-FM TWO8470 1560 RC(L55B+2)=FM TWO8480 1570 RC(L55B+1)=SU TWO8490 1580 IND2=ND2+1 TWO8500 IND3=ND3+1 TWO8510 IND4=ND19+1 TWO8520 IPIC=1 TWO8530 IY=IIRGS(1) TWO8540 YSUM=0.0 TWO8550 L22A=L22 TWO8560 DO 1600 I=1,N TWO8570 IP=IPIC TWO8580 SP=0.0 TWO8590 DO 1590 II=1,M TWO8600 SP=SP+A(IP)**2 TWO8610 1590 IP=IP+NPM TWO8620 A(IND2)=FSQRT(SP)*SS TWO8630 IPIC=IPIC+1 TWO8640 IND2=IND2+1 TWO8650 A(IND3)=RC(IY)-A(IND4) TWO8660 IND3=IND3+1 TWO8670 IND4=IND4+1 TWO8680 YSUM=YSUM+RC(IY)**2*RC(L22A) TWO8690 L22A=L22A+1 TWO8700 1600 IY=IY+1 TWO8710 LST=IIRGS(MXARGS+3) TWO8720 IND9=ND9 TWO8730 DO 1610 I=1,M TWO8740 IND9=IND9+1 TWO8750 RC(LST)=A(IND9) TWO8760 1610 LST=LST+1 TWO8770 IF (NROW-(M+1)) 1650,1630,1620 TWO8780 1620 RC(LST+1)=A(ND9) TWO8790 1630 RC(LST)=(SU-FM)*SSQ TWO8800 LST=LST+2 TWO8810 IF (M+2.GE.NROW) GO TO 1650 TWO8820 LSTA=LST+M-1 TWO8830 IF (2*M+2.GT.NROW) LSTA=IIRGS(MXARGS+3)+NROW-1 TWO8840 IND8=ND8 TWO8850 DO 1640 I=LST,LSTA TWO8860 IND8=IND8+1 TWO8870 1640 RC(I)=A(IND8) TWO8880 1650 LSTOR=IIRGS(MXARGS+2) TWO8890 IPIC=1 TWO8900 IND2=ND2+1 TWO8910 DO 1660 I=1,N TWO8920 RC(LSTOR)=A(IND2) TWO8930 IND2=IND2+1 TWO8940 1660 LSTOR=LSTOR+1 TWO8950 IF (IARGS(5)-IARGS(4)-1) 1670,270,560 TWO8960 1670 RETURN TWO8970 C TWO8980 C TWO8990 1680 FORMAT (//,31X,34H ANALYSIS OF VARIANCE FOR TWO-WAY ,I2,3H X ,I2,6TWO9000 1H TABLE,//,4X,7H SOURCE,13X,5H D.F.,10X,14HSUM OF SQUARES,13X,12HMTWO9010 2EAN SQUARES,10X,17HF RATIO F PROB./) TWO9020 1690 FORMAT (4X,20H BETWEEN ROWS ,I4,50A1,6X,0PF11.3,F9.3) TWO9030 1700 FORMAT (4X,20H BETWEEN COLS ,I4,50A1,6X,0PF11.3,F9.3) TWO9040 1710 FORMAT (4X,20H RESIDUALS ,I4,50A1) TWO9050 1720 FORMAT (4X,20H TOTAL ,I4,25A1//) TWO9060 1730 FORMAT (9X,40HA WEIGHTED LEAST SQUARES ANALYSIS USING ,I4,22H NON-TWO9070 1ZERO WEIGHTS AND ,I4,24H ZERO WEIGHTS IN COLUMN ,I4/) TWO9080 1740 FORMAT (39X,31HTUKEY'S TEST FOR NON-ADDITIVITY//,4X,20H NON-ADDITITWO9090 1VITY ,I4,50A1,6X,0PF11.3,F9.3) TWO9100 1750 FORMAT (4X,20H BALANCE ,I4,50A1) TWO9110 1760 FORMAT (1X) TWO9120 1770 FORMAT (//5X,11HCOEFFICIENT,14X,8HESTIMATE,17X,9HSTD. DEV.//5X,10HTWO9130 1GRAND MEAN,50A1/) TWO9140 1780 FORMAT (5X,7HROW ,I3,50A1) TWO9150 1790 FORMAT (5X,7HCOLUMN ,I3,50A1) TWO9160 1800 FORMAT (5X,10HRESIDULA ,50A1) TWO9170 1810 FORMAT (//10X,I2,3H X ,I2,86H TABLE OF RESIDUALS, STANDARDIZED BY TWO9180 1DIVIDING EACH RESIDUAL BY ITS STANDARD DEVIATION.) TWO9190 1820 FORMAT (/,8H COLUMN,15(3X,I4,1X)) TWO9200 1830 FORMAT (8H ROW ) TWO9210 1840 FORMAT (2X,I4,2X,15(2X,F6.2)) TWO9220 END TWO9230 SUBROUTINE VARCON (NAME) VAR 10 C VERSION 5.00 VARCON 5/15/70 VAR 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND VAR 30 DIMENSION NAME(2), N(14) VAR 40 DATA N(1),N(2),N(3),N(4),N(5),N(6),N(7),N(8),N(9),N(10),N(11),N(12VAR 50 1),N(13),N(14)/10705,2604,16038,16767,17496,18225,18954,1377,15001,VAR 60 25*0/ VAR 70 C VAR 80 C LOOKUP NAME IN VARIABLE-NAME TABLE VAR 90 C VAR 100 C NAME IN TABLE VAR 110 C VAR 120 C NRMAX,COLTOP,V,W,X,Y,Z VAR 130 C VAR 140 DO 10 I=1,7 VAR 150 IF (NAME(1).EQ.N(I).AND.NAME(2).EQ.N(I+7)) GO TO 20 VAR 160 10 CONTINUE VAR 170 I=0 VAR 180 20 ARG=I VAR 190 RETURN VAR 200 END VAR 210 SUBROUTINE VECTOR (A,J) VEC 10 C VERSION 5.00 VECTOR 5/15/70 VEC 20 COMMON /BLOCRC/ NRC,RC(12600) VEC 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NVEC 40 1ARGS,VWXYZ(8),NERROR VEC 50 DIMENSION ARGS(100) VEC 60 EQUIVALENCE (ARGS(1),RC(12501)) VEC 70 C VEC 80 C VECTORIZE A IN TO COLUMN STARTING AT J VEC 90 C VEC 100 IF (NRMAX.EQ.0) GO TO 20 VEC 110 K=J+NRMAX-1 VEC 120 DO 10 I=J,K VEC 130 10 RC(I)=A VEC 140 20 RETURN VEC 150 END VEC 160 SUBROUTINE XECUTE XEC 10 C VERISON 5.00 XECUTE 5/15/70 XEC 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG XEC 30 COMMON/BLOCKX/ INDEX(6,8),LEVEL XEC 40 C ***** XEC 50 C L1=1-10 FOR COMMANDS CONSISTING OF ONE OR TWO VERIABLES XEC 60 C EXAMPLES RESET XEC 70 C RESET X XEC 80 C PRINT A XEC 90 C L1=11-50 FOR COMMANDS CONSISTING OF ONE VARIABLE XEC 100 C EXAMPLES ADD XEC 110 C MPROP XEC 120 C L1=51-63 FOR COMMANDS CONSISTING OF TWO VARIABLES XEC 130 C EXAMPLES CLOSE UP XEC 140 C M(X'X') XEC 150 90 GO TO (100,200,300,400,500,600,700,800,900,1000, XEC 160 11100,1200,1300,1400,1500,1600,1700,1800,1900,2000, XEC 170 22100,2200,2300,2400,2500,2600,2700,2800,2900,3000, XEC 180 33100,3200,3300,3400,3500,3600,3700,3800,3900,4000, XEC 190 44100,4200,4300,4400,4500,4600,4700,4800,4900,5000, XEC 200 55100,5200,5300,5400,5500,5600,5700,5800,5900,6000, XEC 210 66100,6200,6300),L1 XEC 220 C RESET XEC 230 100 CALL RESET XEC 240 GO TO 9999 XEC 250 C PRINT PRINT A-F XEC 260 200 CALL PRINTX XEC 270 GO TO 9999 XEC 280 C PUNCH XEC 290 300 CALL PUNCH XEC 300 GO TO 9999 XEC 310 C APRINT APRINT A-F XEC 320 400 CALL APRINT XEC 330 GO TO 9999 XEC 340 C READ READ A-F XEC 350 500 CALL READX XEC 360 GO TO 9999 XEC 370 C ABRIDGE XEC 380 600 CALL ABRIDG XEC 390 GO TO 9999 XEC 400 C MPRINT MPRINT A-F XEC 410 700 CALL APRINT XEC 420 C NPRINT NPRINT A-F XEC 430 GO TO 9999 XEC 440 800 CALL PRINTX XEC 450 GO TO 9999 XEC 460 C L1=9 AVAILABLE XEC 470 900 RETURN XEC 480 C L1=10 AVAILABLE XEC 490 1000 RETURN XEC 500 C ADD,SUB,MULT,DIV,RAISE,SUBTRACT,DIVIDE,MULTIPLY XEC 510 1100 CALL ARITH XEC 520 GO TO 9999 XEC 530 C SIN,ASIN,SIND,ASIND,SINH,ASINH XEC 540 C COS,ACOS,COSD,ACOSD,COSH,ACOSH XEC 550 C TAN,ATAN,TAND,ATAND,TANH,ATANH,NEGEXP XEC 560 C COT,ACOT,COTD,ACOTD,COTH,ACOTH XEC 570 C ABS,ABSOLUTE,EXP,EXPONENT,LOG,LOGE,LOGTEN,ANTILOG,SQRT,RAISE XEC 580 C INTEGER,FRACTION,SQUARE XEC 590 1200 CALL FUNCT XEC 600 GO TO 9999 XEC 610 C L1=13 XEC 620 1300 GO TO (1301,1302,1303,1304,1305,1306,1307,1308,1309,1310, XEC 630 11311,1312,1313,1314),L2 XEC 640 C GENERATE XEC 650 1301 CALL GENER XEC 660 GO TO 9999 XEC 670 C SET XEC 680 1302 CALL SET XEC 690 GO TO 9999 XEC 700 C FIXED XEC 710 1303 CALL FIXFLO XEC 720 GO TO 9999 XEC 730 C FLOATING XEC 740 1304 GO TO 1303 XEC 750 C PLOT XEC 760 1305 CALL PLOT XEC 770 GO TO 9999 XEC 780 C PAGE PLOT XEC 790 1306 CALL PLOT XEC 800 GO TO 9999 XEC 810 C L1=13 L2=7 AVAILABLE XEC 820 1307 RETURN XEC 830 C NEW PAGE XEC 840 1308 CALL PAGE(4) XEC 850 GO TO 9999 XEC 860 C SPACE XEC 870 1309 CALL SPACE XEC 880 GO TO 9999 XEC 890 C CGS XEC 900 1310 CALL PHYCON(0) XEC 910 GO TO 9999 XEC 920 C SI XEC 930 1311 CALL PHYCON(-1) XEC 940 GO TO 9999 XEC 950 C FLEXIBLE XEC 960 1312 GO TO 1303 XEC 970 C PRINT NOTE XEC 980 1313 CALL NOTEPR(3) XEC 990 GO TO 9999 XEC1000 C ROUND XEC1010 1314 CALL FNEIC XEC1020 GO TO 9999 XEC1030 C L1=14 XEC1040 1400 GO TO(1401,1402,1403,1404,1405,1406,1407,1408,1409,1410,1411,1412,XEC1050 1 1413,1414,1415),L2 XEC1060 C BEGIN XEC1070 1401 CALL BEGIN XEC1080 GO TO 9999 XEC1090 C SCAN XEC1100 1402 GO TO 1401 XEC1110 C REPEAT EXECUTE PERFORM XEC1120 1403 J=1 XEC1130 CALL REPINC(J) XEC1140 IF(J)9999,9999,90 XEC1150 C L1=14 L2= 4 AVAILABLE XEC1160 1404 RETURN XEC1170 C L1=14 L2=5 AVAILABLE XEC1180 1405 RETURN XEC1190 C INCREMENT XEC1200 1406 J=3 XEC1210 CALL REPINC(J) XEC1220 GO TO 9999 XEC1230 C L1=14 L2=7 AVAILABLE XEC1240 1407 RETURN XEC1250 C RESTORE XEC1260 1408 J=3 XEC1270 CALL REPINC(J) XEC1280 GO TO 9999 XEC1290 C IFLT XEC1300 1409 CALL IFS XEC1310 GO TO 9999 XEC1320 C IFEQ XEC1330 1410 GO TO 1409 XEC1340 C IFGT XEC1350 1411 GO TO 1409 XEC1360 C IFGE XEC1370 1412 GO TO 1409 XEC1380 C IFNE XEC1390 1413 GO TO 1409 XEC1400 C IFLE XEC1410 1414 GO TO 1409 XEC1420 C COMPARE XEC1430 1415 GO TO 1409 XEC1440 C MDEFINE MZERO MERASE MIDENT MDIAGONAL XEC1450 C ADEFINE AZERO AERASSE XEC1460 1500 CALL MOP XEC1470 GO TO 9999 XEC1480 C MINVERT INVERT SOLVE XEC1490 1600 CALL INVERT XEC1500 GO TO 9999 XEC1510 C L1=17 NO L2 VALUES ARE NEEDED IN SUBROUTINES XEC1520 1700 GO TO (1701,1702,1703,1704,1705),L2 XEC1530 C MMULT MMULTIPLY XEC1540 1701 CALL MMULT XEC1550 GO TO 9999 XEC1560 C MRAISE XEC1570 1702 CALL MRAISE XEC1580 GO TO 9999 XEC1590 C MKRONECHER XEC1600 1703 CALL MKRON XEC1610 GO TO 9999 XEC1620 C MTRAIN XEC1630 1704 CALL MTRIAN XEC1640 GO TO 9999 XEC1650 C MEIGEN XEC1660 1705 CALL MEIGEN XEC1670 GO TO 9999 XEC1680 1800 IF (L2.GT.8) GO TO 1809 XEC1690 C MADD MSUB MTRANS SCALAR AMULT MSUBTRACT XEC1700 C AADD ASUB ATRANS ARAISE ADIVIDE ASUBTRACT AMULTIPLY XEC1710 CALL MATRIX XEC1720 GO TO 9999 XEC1730 C ACOLALES AAVERA XEC1740 1809 CALL COALES XEC1750 GO TO 9999 XEC1760 C NORMLAGUERE LAGUERE HERMIT LEGENDRE TCHEBYSHEV UCHEBYSHEV XEC1770 1900 CALL ALLSUB XEC1780 GO TO 9999 XEC1790 C PARSUM PARPRODUCT RMS AVERAGE SUM XEC1800 2000 CALL MSCROW XEC1810 GO TO 9999 XEC1820 C L1=21 XEC1830 2100 GO TO (2101,2102,2103,2104,2105,2106,2107,2108,2109,2110,2111, XEC1840 12112,2113,2114,2115,2116,2117,2118,2119),L2 XEC1850 C ROWSUM ROW SUM XEC1860 2101 CALL PROROW XEC1870 GO TO 9999 XEC1880 C PRODUCT XEC1890 2102 GO TO 2101 XEC1900 C DEFINE XEC1910 2103 CALL DEFINE XEC1920 GO TO 9999 XEC1930 C L1=21 L2=4 AVAILABLE XEC1940 2104 RETURN XEC1950 C MAX MAXIMUM XEC1960 2105 CALL EXTREM XEC1970 GO TO 9999 XEC1980 C MIN MINIMUM XEC1990 2106 GO TO 2105 XEC2000 C L1=21 L2=7 AVAILABLE XEC2010 2107 RETURN XEC2020 C SQRT XEC2030 2108 CALL SORDER XEC2040 GO TO 9999 XEC2050 C ORDER XEC2060 2109 GO TO 2108 XEC2070 C ERASE XEC2080 2110 CALL ERASE XEC2090 GO TO 9999 XEC2100 C EXCHANGE XEC2110 2111 CALL EXCHNG XEC2120 GO TO 9999 XEC2130 C FLIP XEC2140 2112 CALL FLIP XEC2150 GO TO 9999 XEC2160 C CHANGE XEC2170 2113 CALL CHANGE XEC2180 GO TO 9999 XEC2190 C HIERARCHY XEC2200 2114 GO TO 2108 XEC2210 C LIST XEC2220 C WRITE SUBROUTINE FOR LIST XEC2230 2115 CALL LIST(0) XEC2240 GO TO 9999 XEC2250 C NO LIST XEC2260 C WRITE SUBROUTINE XEC2270 2116 CALL LIST(1) XEC2280 GO TO 9999 XEC2290 C NULL XEC2300 2117 GO TO 9999 XEC2310 C ERROR XEC2320 2118 CALL FNEC XEC2330 GO TO 9999 XEC2340 C CERF XEC2350 2119 GO TO 2118 XEC2360 C POLYFIT FIT MORTHO XEC2370 C SPOLYFIT SFIT XEC2380 2200 CALL ORTHO XEC2390 GO TO 9999 XEC2400 C L1=23 XEC2410 2300 GO TO (2301,2302,2303,2304,2305,2306,2307,2308,2309,2310,2311, XEC2420 12312),L2 XEC2430 C CLOSE UP XEC2440 2301 CALL MISC2 XEC2450 GO TO 9999 XEC2460 C COUNT XEC2470 2302 GO TO 2301 XEC2480 C SHORTEN XEC2490 2303 GO TO 2301 XEC2500 C EXPAND XEC2510 2304 GO TO 2301 XEC2520 C DUPLICATE XEC2530 2305 GO TO 2301 XEC2540 C MOVE AMOVE MMOVE XEC2550 2306 CALL MOVE XEC2560 GO TO 9999 XEC2570 C L1=23 L2=7 AVAILABLE XEC2580 2307 RETURN XEC2590 C L1=23 L2=8 AVAILABLE XEC2600 2308 RETURN XEC2610 C L1=23 L2=9 AVAILABLE XEC2620 2309 RETURN XEC2630 C PROMOTE XEC2640 2310 CALL PDMOTE XEC2650 GO TO 9999 XEC2660 C DEMOTE XEC2670 2311 GO TO 2310 XEC2680 C DIMENSION DIM XEC2690 2312 CALL DIMENS XEC2700 GO TO 9999 XEC2710 C L1=24 XEC2720 2400 GO TO (2401,2402,2403,2404,2405,2406,2407,2408,2409,2410, XEC2730 1 2411,2412,2413,2414,2415),L2 XEC2740 C STATIS XEC2750 2401 CALL STATIS XEC2760 GO TO 9999 XEC2770 C SSTATIS XEC2780 2402 GO TO 2401 XEC2790 C RANKS XEC2800 2403 CALL RANKS XEC2810 GO TO 9999 XEC2820 C GAUSS QUADRATURE XEC2830 2404 CALL GQUAD XEC2840 GO TO 9999 XEC2850 C F PROBABILITY XEC2860 2405 CALL FPROB XEC2870 GO TO 9999 XEC2880 C TWOWAY XEC2890 2406 CALL TWOWAY(L2) XEC2900 GO TO 9999 XEC2910 C STWOWAY XEC2920 2407 CALL TWOWAY(L2) XEC2930 GO TO 9999 XEC2940 C HISTOG XEC2950 2408 CALL HISTGM XEC2960 GO TO 9999 XEC2970 C NHISTO XEC2980 2409 CALL HISTGM XEC2990 GO TO 9999 XEC3000 C FREQUE XEC3010 2410 CALL FRDIST XEC3020 GO TO 9999 XEC3030 C CORREL XEC3040 2411 CALL CORREL XEC3050 GO TO 9999 XEC3060 C SCORRE XEC3070 2412 CALL CORREL XEC3080 GO TO 9999 XEC3090 C ONEWAY XEC3100 2413 CALL ONEWAY XEC3110 GO TO 9999 XEC3120 C SONEWAY XEC3130 2414 GO TO 2413 XEC3140 C UNIFORM RANDOM XEC3150 2415 CALL FNKC XEC3160 GO TO 9999 XEC3170 C SELECT SEARCH CENSOR MATCH XEC3180 2500 IF (L2.EQ.4) GO TO 2504 XEC3190 CALL SELECT XEC3200 GO TO 9999 XEC3210 2504 CALL INTERP XEC3220 GO TO 9999 XEC3230 C MVECDIAG MVECMAT MMATVEC MVECDIAGONAL XEC3240 2600 CALL EXPCON XEC3250 GO TO 9999 XEC3260 C MPROPERTIES APROPERTIES SMPROP SAPROP XEC3270 2700 CALL MPROP XEC3280 GO TO 9999 XEC3290 C ITERATE ISETUP ISOLATE XEC3300 2800 CALL ITERAT XEC3310 GO TO 9999 XEC3320 C SEPARATE INSERT MAXMIN EXTREMA XEC3330 2900 CALL CMSEPA XEC3340 GO TO 9999 XEC3350 C BESSEL SUBROUTINES XEC3360 3000 CALL BESSEL XEC3370 GO TO 9999 XEC3380 C THERMO XEC3390 3100 CALL THERMO XEC3400 GO TO 9999 XEC3410 C COMPLEX ARITHMETIC XEC3420 3200 CALL COMPLX XEC3430 GO TO 9999 XEC3440 C L1=33 XEC3450 C L1=34 XEC3460 C L1=35 XEC3470 C L1=36 XEC3480 C L1=37 XEC3490 C L1=38 XEC3500 C L1=39 XEC3510 C L1=40 XEC3520 C L1=41 XEC3530 C L1=42 XEC3540 C L1=43 XEC3550 C L1=44 XEC3560 3300 RETURN XEC3570 3400 RETURN XEC3580 3500 RETURN XEC3590 3600 RETURN XEC3600 3700 RETURN XEC3610 3800 RETURN XEC3620 3900 RETURN XEC3630 4000 RETURN XEC3640 4100 RETURN XEC3650 4200 RETURN XEC3660 4300 RETURN XEC3670 4400 RETURN XEC3680 C***** THE FOLLOWING CARDS ARE NEEDED ONLY FOR TAPE OPERATIONS XEC3690 C THE STATEMENTS 4500 -5000 WERE RETURN STATEMENTS XEC3700 C READ TAPE XEC3710 4500 CALL TAPOP2 XEC3720 GO TO 9999 XEC3730 C CREAD TAPE XEC3740 4600 GO TO 4500 XEC3750 C WRITE TAPE XEC3760 4700 GO TO 4500 XEC3770 C SET TAPE XEC3780 4800 GO TO 4500 XEC3790 C CSET TAPE XEC3800 4900 GO TO 4500 XEC3810 C ENDFILE TAPE,REWIND TAPE SKIP TAPE, BACKSPACE TAPE XEC3820 5000 GO TO 4500 XEC3830 C***********************************************************************XEC3840 C M(XX') M(X'X') X(XAX') M(X'AX) XEC3850 5100 CALL MXTX XEC3860 GO TO 9999 XEC3870 C M(AD),M(DA) XEC3880 5200 CALL MDAMAD XEC3890 GO TO 9999 XEC3900 C M(V'A) M(AV) XEC3910 5300 CALL ARYVEC XEC3920 GO TO 9999 XEC3930 C L1=54 XEC3940 5400 GO TO (5401,5401,5402,5403,5404,5405,5406,5407),L2 XEC3950 C L2=1 XEC3960 5401 RETURN XEC3970 C DUMMY A XEC3990 5402 CALL DUMMYA XEC4000 GO TO 9999 XEC4010 C DUMMY B XEC4020 5403 CALL DUMMYB XEC4030 GO TO 9999 XEC4040 C DUMMY C XEC4050 5404 CALL DUMMYC XEC4060 GO TO 9999 XEC4070 C DUMMY D XEC4080 5405 CALL DUMMYD XEC4090 GO TO 9999 XEC4100 C DUMMY E XEC4110 5406 CALL DUMMYE XEC4120 GO TO 9999 XEC4130 C DUMMY F XEC4140 5407 CALL DUMMYF XEC4150 GO TO 9999 XEC4160 C L1=55 XEC4170 C L1=56 XEC4180 C L1=57 XEC4190 C L1=58 XEC4200 C L1=59 XEC4210 C L1=60 XEC4220 C L1=61 XEC4230 C L1=62 XEC4240 C L1=63 XEC4250 5500 RETURN XEC4260 5600 RETURN XEC4270 5700 RETURN XEC4280 5800 RETURN XEC4290 5900 RETURN XEC4300 6000 RETURN XEC4310 6100 RETURN XEC4320 6200 RETURN XEC4330 6300 RETURN XEC4340 9999 CALL AERR(0) XEC4350 IF(LEVEL.LE.0) RETURN XEC4360 J=2 XEC4370 CALL REPINC(J) XEC4380 IF(LEVEL.LE.0) RETURN XEC4390 GO TO 90 XEC4400 END XEC4410 SUBROUTINE XFORMT XFO 10 C VERSION 5.00 XFORMT 5/15/70 XFO 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND XFO 30 C XFO 40 C LOOK FOR LETTER A-F FOLLOWED BY NON-ALPHANUMERIC CHARACTER XFO 50 C A $ = 46 STOPS THE SCAN XFO 60 10 M=M+1 XFO 70 IF (KARD(M).LT.10.OR.KARD(M).GT.15) IF (KARD(M)-46) 10,20,10 XFO 75 IF (KARD(M+1).LE.35) GO TO 20 XFO 80 C CALL PREPAK TO STORE FORMAT XFO 90 C IF IND=0 FORMAT IS O.K. AND STORED XFO 100 C IF IND=1 NUMBER OF ( DOES NOT EQUAL THE NUMBER OF ) XFO 110 C XFO 120 CALL PREPAK (1,IND,IR,IR,IR) XFO 130 IF (IND.EQ.0) RETURN XFO 140 20 CALL ERROR (205) XFO 150 RETURN XFO 160 END XFO 170 SUBROUTINE XHEAD XHE 10 C VERSION 5.00 XHEAD 5/15/70 XHE 20 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND XHE 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NXHE 40 1ARGS,VWXYZ(8),NERROR XHE 50 COMMON /ABCDEF/ L(48) XHE 60 GO TO 20 XHE 70 10 M=M+1 XHE 80 20 IF (KARD(M).GE.10) IF (KARD(M)-46) 10,30,10 XHE 85 CALL AARGS XHE 90 I=ARG XHE 100 IF (KARG.EQ.0.AND.I.GT.0.AND.I.LE.NCOL) GO TO 60 XHE 110 30 CALL ERROR (204) XHE 120 RETURN XHE 130 50 M=M+1 XHE 140 60 IF (KARD(M).NE.36) IF (KARD(M)-46) 50,30,50 XHE 145 C XHE 150 C SLASH FOUND. PICK UP NEXT 12 CHARACTERS IN FORMAT A1 AND PACK XHE 160 C XHE 170 80 CALL PREPAK (2,IND,I,IR,IR) XHE 230 RETURN XHE 240 END XHE 250 SUBROUTINE XOMNIT (LG) XOM 10 C VERSION 5.00 XOMNIT 5/15/70 XOM 20 C ADD A SWITCH TO DETERMINE WHETHER PRINTX OR RPRINT WILL BE USED XOM 21 C INITIALIZE SWITCH TO ZERO FLEXIBLE FORMAT(RPRINT) WILL BE USED XOM 22 C SWITCH WILL BE SET TO 1 IF FIXED OR FLOATING IS ENCOUNTERED XOM 23 C IF PRINT COMMAND HAS DEC. ARGS FLEXIBLE FORMAT WILL BE USED XOM 24 C SWITCH WILL NOT BE CHANGED XOM 25 C FLEXIBLE COMMAND WILL CHANGE SWITCH TO 0 XOM 26 C IF PRINT WITH ALL INTEGER ARGS AND SWITCH=0 USE FLEXIBLE FORMAT XOM 27 C IF PRINT WITH ALL INTEGER ARGS AND SWITCH=1,USE SPECIFIED FORMAT XOM 28 C (FIXED OR FLOATING) XOM 29 COMMON /BLOCKA/ MODE,M,KARD(83),KARG,ARG,ARG2,NEWCD(80),KRDEND XOM 30 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) XOM 40 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST XOM 50 COMMON /BLOCRC/ NRC,RC(12600) XOM 60 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NXOM 70 1ARGS,VWXYZ(8),NERROR XOM 80 DIMENSION ARGS(100) XOM 90 EQUIVALENCE (ARGS(1),RC(12501)) XOM 100 COMMON /HEADER/ NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH XOM 110 COMMON/PKSWT/IHCNT,IHTP XOM 115 COMMON/FMAT/IFMTX(6),IOSWT,IFMTS(6),LHEAD(96) XOM 120 COMMON/BLOCKX/INDEX(6,8),LEVEL XOM 125 COMMON /SPRV/ NERCON,NERR,ISWERR XOM 130 COMMON/ABCDEF/L(48) XOM 140 COMMON/PCONST/JPC,P(40),N(40) XOM 150 C XOM 170 C IF LG IS NEG, FIRST CARD WAS NOT 'OMNITAB' CARD. IF LG= 0, FIRST XOM 180 C CARD = ,OMNITAB,. ELSE SUBSEQUENT 'OMNITAB' CARD FOUND. XOM 190 C XOM 200 IF (LG) 40,20,10 XOM 210 C XOM 220 C GO THROUGH 'STOP' SEQUENCE AND RETURN XOM 230 10 CALL XSTOP XOM 240 20 DO 30 I=1,80 XOM 250 30 NOCARD(I)=NEWCD(I) XOM 260 C XOM 270 C INITIALIZE SYSTEM XOM 280 C XOM 290 40 DO 50 I=1,60 XOM 300 DO 50 J=1,6 XOM 310 50 ITLE(I,J)=L(45) XOM 320 DO 60 I=1,6 XOM 330 60 IFMTX(I)=IFMTS(I) XOM 340 IOSWT=0 XOM 350 IHCNT=0 XOM 360 CALL PREPAK(3,IND,IND,IND,IND) XOM 370 MODE=1 XOM 400 NRMAX=0 XOM 410 NROW=201 XOM 420 NCOL=62 XOM 430 KRDEND=80 XOM 440 LLIST=3 XOM 450 NERROR=0 XOM 460 NSTMT=0 XOM 470 NSTMTH=0 XOM 480 NCOM=1 XOM 490 LCOM=2000 XOM 500 LEVEL=0 XOM 505 IOVFL=0 XOM 510 NPAGE=0 XOM 520 NRCC=NRC+100 XOM 530 DO 90 I=1,NRCC XOM 540 90 RC(I)=0. XOM 550 NERR=0 XOM 560 NERCON=100 XOM 570 ISWERR=0 XOM 580 DO 100 I=1,8 XOM 584 100 VWXYZ(I)=0.0 XOM 586 JPC=-1 XOM 588 CALL NOTEPR (0) XOM 600 RETURN XOM 605 END XOM 610 SUBROUTINE XPND (T,K,Y,KND) XPN 10 C VERSION 5.00 XPND 5/15/70 XPN 20 COMMON /BLOCRC/ NRC,RC(12600) XPN 30 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NXPN 40 1ARGS,VWXYZ(8),NERROR XPN 50 DIMENSION ARGS(100) XPN 60 EQUIVALENCE (ARGS(1),RC(12501)) XPN 70 DIMENSION T(2) XPN 80 C XPN 90 C THIS SUBROUTINE TAKE A ''STATEMENT'' REFERENCE AS STORED XPN 100 C AND EXPANDS IT INTO THE PROPER ARGUMENT WITH CHECKING. XPN 110 C XPN 120 C K IS RETURNED 0 IF ARG IN STATEMENT IS ONE WORD LONG XPN 130 C K IS RETURNED 1 IF ARG IN STATEMENT IS TWO WORDS LONG XPN 140 C K IS RETURNED -( ERROR NUMBER ) IF ERROR OCCURS. XPN 150 C XPN 160 IT=-T(1) XPN 170 IF (IT.LT.16) GO TO 40 XPN 180 C XPN 190 C ''ROW, COL'' ENTRY XPN 200 C XPN 210 IT=IT-8208 XPN 220 IF (IT.GT.0.AND.IT.LE.NROW) GO TO 10 XPN 230 K=-16 XPN 240 GO TO 20 XPN 250 10 IARGS(100)=ABS(T(2))-8192. XPN 260 KIND(100)=0 XPN 270 CALL ADRESS (100,J) XPN 280 IF (J.NE.0) GO TO 30 XPN 290 K=-11 XPN 300 20 RETURN XPN 310 30 J=J+IT XPN 320 KND=0 XPN 330 IF (T(2).LT.0.) KND=1 XPN 340 Y=RC(J-1) XPN 350 K=1 XPN 360 GO TO 20 XPN 370 C XPN 380 C NRMAX, V, W, X, Y, Z, REFERENCE. XPN 390 C XPN 400 40 IU=IT/2 XPN 410 KND=IT-2*IU XPN 420 K=0 XPN 430 IF (IU.LE.1) GO TO 50 XPN 440 Y=VWXYZ(IU-2) XPN 450 GO TO 20 XPN 460 50 Y=NRMAX XPN 470 GO TO 20 XPN 480 END XPN 490 SUBROUTINE XSTOP XST 10 C VERSION 5.00 XSTOP 5/15/70 XST 20 COMMON /BLOCKC/ KIO,INUNIT,ISCRAT,KBDOUT,KRDKNT,LLIST XST 30 COMMON /BLOCRC/ NRC,RC(12600) XST 40 COMMON /BLOCKD/ IARGS(100),KIND(100),ARGTAB(100),NRMAX,NROW,NCOL,NXST 50 1ARGS,VWXYZ(8),NERROR XST 60 DIMENSION ARGS(100) XST 70 EQUIVALENCE (ARGS(1),RC(12501)) XST 80 COMMON/HEADER/NOCARD(80),ITLE(60,6),LNCNT,IPRINT,NPAGE,IPUNCH XST 90 COMMON /SCRAT/ NS,NS2,A(13500) XST 100 DIMENSION ITEMP(84) XST 110 EQUIVALENCE (ITEMP(1),A(1)) XST 120 DATA IZ,IP,NO,KOMMA/1HZ,1H+,1H0,1H,/ XST 130 C XST 140 C THIS ROUTINE REWINDS THE SCRATCH UNIT AND PRINTS IT. XST 150 C XST 160 REWIND ISCRAT XST 170 LLIST=0 XST 180 IF (NERROR.EQ.0) LLIST=3 XST 190 10 CALL PAGE (0) XST 200 WRITE (IPRINT,90) XST 210 DO 40 J=1,50 XST 220 READ (ISCRAT,100) ITEMP XST 230 IF (ITEMP(1).EQ.IZ) GO TO 50 XST 240 IF (ITEMP(1).EQ.IP) GO TO 30 XST 250 IF (ITEMP(1).EQ.KOMMA) GO TO 20 XST 260 WRITE (IPRINT,110) ITEMP XST 270 GO TO 40 XST 280 20 LLIST=3 XST 290 IF (ITEMP(2).EQ.NO.AND.NERROR.EQ.0) LLIST=0 XST 300 GO TO 40 XST 310 30 WRITE (IPRINT,120) (ITEMP(I),I=2,84) XST 320 40 CONTINUE XST 330 GO TO 10 XST 340 50 REWIND ISCRAT XST 350 IF (NERROR-1) 80,60,70 XST 360 60 WRITE (IPRINT,130) XST 370 GO TO 80 XST 380 70 WRITE (IPRINT,140) NERROR XST 390 80 LLIST=3 XST 400 WRITE (IPRINT,150) XST 410 WRITE (IPRINT,160) XST 420 RETURN XST 430 C XST 440 90 FORMAT (//19X,39H LIST OF COMMANDS, DATA AND DIAGNOSTICS//) XST 450 100 FORMAT (84A1) XST 460 110 FORMAT (20X,84A1) XST 470 120 FORMAT (18X,3A1,3X,80A1) XST 480 130 FORMAT (///40X,20HONLY ONE FATAL ERROR) XST 490 140 FORMAT (///40X,I4,7H ERRORS) XST 500 150 FORMAT(1H0/33X,95H NATIONAL BUREAU OF STANDARDS, WASHINGTON, D. C.XST 510 1 20234, OMNITAB II VERSION 5.00 MAY 15, 1970 ) XST 520 160 FORMAT(1H1) XST 530 END XST 540 ~eor *DECK,GP0 OVERLAY (OMNITAB,0,0) PROGRAM OMNITAB (INPUT,OUTPUT,PUNCH,TAPE5=INPUT,TAPE6=OUTPUT,TAPE4 15,TAPE3=PUNCH) *END *COPY,OMS *ADD,17 COMMON/CDC/ ICDC,ICDCK,ICDCN,DBEJX,BES2 DOUBLE PRECISION DBEJX,BES2 *CANCEL,37 ICDC=2 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,73 50 ICDC=3 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,97 65 ICDCK=LETSGO ICDC=4 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) LETSGO=ICDCK *CANCEL,111 ICDC=5 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,131 ICDC=6 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,185 ICDC=8 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,321 ICDC=7 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,342 ICDC=9 ICDCK=J CALL OVERLAY(6HOMNITA,1,0,6HRECALL) J=ICDCK *EDIT,OMN *COPY,AAR *CANCEL,12,17 *CANCEL,25,26 *EDIT,INP *COPY,LOU *COPY,OUT *COPY,PAG *COPY,NNA *COPY,NON *COPY,OMC *DECK,PAX IDENT PACK ENTRY PACK TITLE PACK OR UNPACK CHARACTERS INTO A WORD. * SUBROUTINE PACK (NWORD,MWORD,NO,IP) * VERSION 5.00 PACK 5/15/70 * WRITTEN BY S PEAVY 9/17/69 * NWORD CONTAINS CHARACTERS TO BE PACKED OR UNPACKED * MWORD THE PACKED CHARACTERS IN CODED FORM (SEE BELOW) OR THE * UNPACKED CHARACTERS * NO NO OF CHARACTERS TO BE PACKED OR UNPACKED * IP IP=0 PACK * IP IP=1 UNPACK * * THE CHARACTERS ARE PACKED IN A CODED FORM. EACH CHARACTER HAS BEEN * ASSIGNED A VALUE IN OMCONV. THIS VALUE IS 1 LESS THAN THE * SUBSCRIPT OF L (IN LABELED COMMON ABCDEF) FOR THAT PARTICULAR * CHARACTER. THESE VALUES ARE STORED IN KARD. THE VALUES OF THE * CHARACTERS ARE PACKED 10 CHARACTERS PER WORD. PACK BSS 1 ENTRY/EXIT SPACE 1 USE /ABCDEF/ L EQU * USE 0 SA1 B4 GET TYPE SA2 B3 GET NUMBER. SB5 X2 SB7 1 SX2 77B NZ X1,UNPACK IP = 1 DO UNPACK. SB6 B5+B1 POINT TO LAST CHARACTER. SX4 45 LOAD TO BLANK. PACKA SX6 B0 SB5 10 SET CHARACTER COUNT. PACKB SA3 B1 GET WORD. LX6 6 MOVE PREVIOUS CHAR LEFT 6. SB1 B1+B7 BX3 X3*X2 SB5 B5-B7 BX6 X6+X3 EQ B1,B6,PACKC CHECK FOR FINISHED. NZ B5,PACKB SA6 B2 SAVE WORD. SB2 B2+B7 EQ PACKA PACKC LX6 6 BX6 X6+X4 SB5 B5-B7 NZ B5,PACKC SA6 B2 EQ PACK UNPACK SB6 B5+B2 UNPAKA SB5 10 SA3 B1 SB1 B1+B7 UNPAKB LX3 6 BX1 X3*X2 SA1 X1+L BX6 X1 SA6 B2 SB2 B2+B7 SB5 B5-B7 EQ B2,B6,PACK NZ B5,UNPAKB EQ UNPAKA END *END *DECK,PAH IDENT PACKH ENTRY PACKH TITLE PACK HIGH CHARACTERS INTO WORD * SUBROUTINE PACKH (NWORD,MWORD,NO) * VERSION 5.00 PACK 5/15/70 * WRITTEN BY S PEAVY 9/17/69 * NWORD CONTAINS CHARACTERS TO BE PACKED OR UNPACKED * MWORD THE PACKED CHARACTERS IN CODED FORM (SEE BELOW) OR THE * UNPACKED CHARACTERS * NO NO OF CHARACTERS TO BE PACKED OR UNPACKED * * THE CHARACTERS ARE PLACED INTO THE LEFT SIDE OF EACH WORD. * THE VALUES OF THE CHARACTERS ARE PACKED 10 CHARACTERS PER WORD. PACKH BSS 1 ENTRY/EXIT SPACE 1 SA1 B4 GET TYPE SA2 B3 GET NUMBER. SB5 X2 SB7 1 SX2 77B SB6 B5+B1 POINT TO LAST CHARACTER. SX4 55B LOAD TO BLANK. PACKA SX6 B0 SB5 10 SET CHARACTER COUNT. PACKB SA3 B1 GET WORD. LX6 6 MOVE PREVIOUS CHAR LEFT 6. SB1 B1+B7 LX3 6 BX3 X3*X2 SB5 B5-B7 BX6 X6+X3 EQ B1,B6,PACKC CHECK FOR FINISHED. NZ B5,PACKB SA6 B2 SAVE WORD. SB2 B2+B7 EQ PACKA PACKC LX6 6 BX6 X6+X4 SB5 B5-B7 NZ B5,PACKC SA6 B2 EQ PACKH END *END *CANCEL,45 DIMENSION IFMT(8,6), IHEAD(5,50) *CANCEL,52 DATA II/8/,LA/50/ *CANCEL,85,88 CALL PACKH(IAA,IAA,80) DO 55 I=1,8 55 IFMT(I,K-9)=IAA(I) *CANCEL,107,109 DO 122 I=2,3 C THE FOLLOWING CONSTANT IS 10 BLANKS 122 IHEAD (I,1)=55555555555555555555B *CANCEL,143 230 FORMAT (7A10,A2) *EDIT,PRE *CANCEL,6 DATA ADMAX /14.0/ *EDIT,ACC *COPY,ADR *COPY,AER *COPY,ARI *COPY,AST *COPY,BEG *COPY,CHK *COPY,CKI *COPY,DIM *COPY,ERR *COPY,EXD *COPY,FCO *COPY,FDC *COPY,FDE *COPY,FDL *COPY,FDQ *COPY,FDS *COPY,FDP *COPY,FEX *COPY,FX2 *COPY,FLE *COPY,FLT *COPY,FSI *COPY,FSQ *COPY,FTA *COPY,FUN *COPY,GEN *COPY,HEA *COPY,IFS *COPY,INF *COPY,LIS *COPY,LOC *CANCEL,28,29 IF ((IARGS(I)+IARGS(I+2)-1).GT.NROW) GO TO 30 IF ((IARGS(I+1)+IARGS(I+3)-1).GT.NCOL) GO TO 30 *EDIT,MCK *COPY,MXP *COPY,NOT *COPY,PHY *COPY,PRB *COPY,REQ *COPY,REX *COPY,REP *COPY,RES *ADD,28 L10P=10**(NSIGDS+1) L10=10**NSIGDS *CANCEL,42 20 NWMAX=MAX0((NSIGS+5),NX) *CANCEL,60,61 IF (LL.GE.L10P) MMIN=MMIN+1 IF (LL.LT.L10) MMIN=MMIN-1 *CANCEL,64,65 IF (LL.GE.L10P) MMAX=MMAX+1 IF (LL.LT.L10) MMAX=MMAX-1 *CANCEL,71,72 NDECS=MAX0(NDECS,(NSIGDS+2)) NDECS=MIN0(NDECS,(NWMAX-3)) *CANCEL,100 60 NWIDTH=MAX0(NW,(NSIGDS+2)) *CANCEL,133 IF (LL.LT.L10P) GO TO 120 *CANCEL,137 120 IF (LL.GE.L10) GO TO 130 *CANCEL,143,145 IF (M.LT.(NDIFF-2)) GO TO 150 IF ((M.EQ.(NDIFF-2)).AND.XVAL.GE.0.) GO TO 150 NSIGDS=MAX0(0,(NWIDTH-5)) *CANCEL,152 150 NSIGDS=MIN0(8,(NDECS+M+1)) *CANCEL,160 IF(((NDECS+1).EQ.(-M)).AND.LL.GT.10) ARRAY(NWMAX)=C(2) *CANCEL,163,164 IF ((M.GE.(NSIGDS-1-NDECS)).AND.(M.LT.(NDIFF-2))) GO TO 190 IF ((M.EQ.(NDIFF-2)).AND.XVAL.GT.0.) GO TO 190 *ADD,171 201 CONTINUE *CANCEL,174 IF (M.GE.0.AND.(M.LT.(NSIGDS-1))) NEND=NEND+1 *CANCEL,184 IF (NWIDTH.GE.(NSIGDS+5)) GO TO 210 *EDIT,RFO *COPY,RND *COPY,SET *COPY,SOM *COPY,SPA *COPY,SYM *COPY,VAR *COPY,VEC *ADD,2 C VERSION 5.00 CDC OVERLAY XECUTE *ADD,4 COMMON/CDC/ICDC,ICDCK,ICDCN,DBEJX,BES2 DOUBLE PRECISION DBEJX,BES2 *CANCEL,27 200 ICDC=13 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,30 300 ICDC=14 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,33 400 ICDC=11 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,39 600 ICDC=10 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,42 700 GO TO 400 *CANCEL,44,46 C 800 GO TO 200 C *CANCEL,72 1303 ICDC=12 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,77 1305 CALL OVERLAY (6HOMNITB,2,0,6HRECALL) *CANCEL,80 1306 GO TO 1305 C *CANCEL,102 1314 CALL OVERLAY (6HOMNITB,2,0,6HRECALL) *CANCEL,147 1500 CALL OVERLAY (6HOMNITC,3,0,6HRECALL) *CANCEL,150 1600 CALL OVERLAY (6HOMNITD,4,0,6HRECALL) *CANCEL,155 1701 CALL OVERLAY (6HOMNITC,3,0,6HRECALL) *CANCEL,158 1702 CALL OVERLAY (6HOMNITC,3,0,6HRECALL) *CANCEL,161 1703 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,164 1704 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,167 1705 CALL OVERLAY(6HOMNITE,5,0,6HRECALL) *CANCEL,172 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,175 1809 CALL OVERLAY(6HOMNITE,5,0,6HRECALL) *CANCEL,178 1900 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,181 2000 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,187 2101 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,192 2103 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,197 2105 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,204 2108 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,209 2110 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,212 2111 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,215 2112 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,218 2113 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,233 2118 CALL OVERLAY(6HOMNITB,2,0,6HRECALL) *CANCEL,239 2200 CALL OVERLAY(6HOMNITF,6,0,6HRECALL) *CANCEL,245 2301 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,256 2306 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,265 2310 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,276 2401 CALL OVERLAY(6HOMNITG,7,0,6HRECALL) *CANCEL,281 2403 CALL OVERLAY(6HOMNITH,10B,0,6HRECALL) *CANCEL,284 2404 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,287 2405 CALL OVERLAY(6HOMNITG,7,0,6HRECALL) *CANCEL,290 2406 CALL OVERLAY(6HOMNITI,11B,0,6HRECALL) *CANCEL,293,294 2407 GO TO 2406 C *CANCEL,296 2408 CALL OVERLAY(6HOMNITG,7,0,6HRECALL) *CANCEL,299,300 2409 GO TO 2408 C *CANCEL,302 2410 CALL OVERLAY(6HOMNITG,7,0,6HRECALL) *CANCEL,305 2411 CALL OVERLAY(6HOMNITH,10B,0,6HRECALL) *CANCEL,308,309 2412 GO TO 2411 C *CANCEL,311 2413 CALL OVERLAY(6HOMNITE,5,0,6HRECALL) *CANCEL,316 2415 CALL OVERLAY(6HOMNITB,2,0,6HRECALL) *CANCEL,320 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,322 2504 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,325 2600 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,328 2700 CALL OVERLAY(6HOMNITD,4,0,6HRECALL) *CANCEL,331 2800 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,334 2900 CALL OVERLAY(6HOMNITJ,12B,0,6HRECALL) *CANCEL,337 3000 CALL OVERLAY(6HOMNITL,14B,0,6HRECALL) *CANCEL,340 3100 CALL OVERLAY(6HOMNITB,2,0,6HRECALL) *CANCEL,343 3200 CALL OVERLAY(6HOMNITK,13B,0,6HRECALL) *CANCEL,372 4500 ICDC=15 CALL OVERLAY(6HOMNITA,1,0,6HRECALL) *CANCEL,386 5100 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,389 5200 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,392 5300 CALL OVERLAY(6HOMNITC,3,0,6HRECALL) *CANCEL,399 5402 CALL OVERLAY(6HOMNITM,15B,0,6HRECALL) *CANCEL,402 5403 CALL OVERLAY(6HOMNITM,15B,0,6HRECALL) *CANCEL,405 5404 CALL OVERLAY(6HOMNITM,15B,0,6HRECALL) *CANCEL,408 5405 CALL OVERLAY(6HOMNITM,15B,0,6HRECALL) *CANCEL,411 5406 CALL OVERLAY(6HOMNITM,15B,0,6HRECALL) *CANCEL,414 5407 CALL OVERLAY(6HOMNITM,15B,0,6HRECALL) *EDIT,XEC *COPY,LOT *COPY,BLO *COPY,PHC *CANCEL,40,42 DATA NBC/11/,NBM/96/,TRRTPI/1.128379167095512574D0/ DATA XTRIG/3.3E7/,XEXP/88.0 / DATA ER/1.E-14/,ISIGD/14/ *EDIT,LBC *COPY,XPN *COPY,XST *DECK,GP2 OVERLAY (OMNITA,1,0) PROGRAM OMNITA GP2 10 C VERSION 5.00 CDC OVERLAY GROUP 2 GP2 20 COMMON/CDC/ ICDC,ICDCK,ICDCN,DBEKX,BES2 GP2 50 DOUBLE PRECISION DBEJX,BES2 GP2 55 COMMON /BLOCKB/ NSTMT,NSTMTX,NSTMTH,NCOM,LCOM,IOVFL,COM(2000) GP2 60 GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,150),ICDC GP2 65 10 GO TO 1000 GP2 80 20 CALL SETUP GP2 90 30 CALL STMT(NSTMT) GP2 100 GO TO 1000 GP2 110 40 CALL XOMNIT(ICDCK) GP2 120 GO TO 1000 GP2 130 50 CALL XFORMT GP2 140 GO TO 1000 GP2 150 60 CALL XHEAD GP2 160 GO TO 1000 GP2 170 70 CALL SETQ GP2 180 GO TO 1000 GP2 190 80 CALL TAPOP GP2 200 GO TO 1000 GP2 210 90 CALL STORE (ICDCK) GP2 220 GO TO 1000 GP2 230 100 CALL ABRIDG GP2 240 GO TO 1000 GP2 250 110 CALL APRINT GP2 260 GO TO 1000 GP2 270 120 CALL FIXFLO GP2 280 GO TO 1000 GP2 290 130 CALL PRINTX GP2 300 GO TO 1000 GP2 310 140 CALL PUNCH GP2 320 GO TO 1000 GP2 330 150 CALL TAPOP2 GP2 340 1000 RETURN GP2 350 END GP2 360 *END *COPY,STP *COPY,STM *COPY,XOM *COPY,XFO *COPY,XHE *COPY,STQ *COPY,TAP *COPY,STO *COPY,ABR *COPY,APR *CANCEL,12,13 DIMENSION IB(2) DATA IB(1),IB(2)/2H8F,2H8E/ *ADD,37 IFMTX(3)=IB(1) *CANCEL,42,43 60 IFMTX(3)=IB(2) *EDIT,FIX *COPY,PRI *COPY,RPR *COPY,PUN *COPY,TP2 *DECK,GP3 OVERLAY(OMNITB,2,0) PROGRAM OMNITB GP3 10 C VERSION 5.00 CDC OVERLAY GROUP 3 GP3 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP3 30 IF(L1.EQ.31) GO TO 40 GP3 40 IF(L1.EQ.24.AND.L2.EQ.15) GO TO 30 GP3 50 IF(L1.EQ.21.AND.(L2.EQ.18.OR.L2.EQ.19)) GO TO 20 GP3 60 IF(L2.EQ.14) GO TO 10 GP3 70 CALL PLOT GP3 80 GO TO 50 GP3 90 10 CALL FNEIC GP3 100 GO TO 50 GP3 110 20 CALL FNEC GP3 120 GO TO 50 GP3 130 30 CALL FNKC GP3 140 GO TO 50 GP3 150 40 CALL THERMO GP3 160 50 RETURN GP3 170 END GP3 180 *END *CANCEL,369,373 950 FORMAT (1X,A1,E11.4,1H+,101A1,1H+) 960 FORMAT (1X,A1,E11.4,1HX,101A1,1HX) 970 FORMAT (1X,A1,11X,1HX,101A1,1HX) 980 FORMAT (1X,A1,E11.4,1HX,61A1,1HX) 990 FORMAT (1X,A1,E11.4,1H+,61A1,1H+) *CANCEL,377 1030 FORMAT (6(7X,E13.4)) *EDIT,PLO *COPY,FNE *COPY,FNC *COPY,FKC *CANCEL,237,238 850 DO 880 J=1,NROW IIG=IG+(NROW-J) *EDIT,THE *COPY,DHR *COPY,RNJ *COPY,ERT *DECK,GP4 OVERLAY(OMNITC,3,0) PROGRAM OMNITC GP4 10 C VERSION 5.00 CDC OVERLAY GROUP 4 GP4 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP4 30 IF (L1-52) 10,90,100 GP4 40 10 IF (L1.EQ.51) GO TO 80 GP4 50 IF (L1.EQ.26) GO TO 70 GP4 60 IF (L1.EQ.18) GO TO 60 GP4 70 IF (L1.EQ.17) GO TO (20,30,40,50),L2 GP4 80 CALL MOP GP4 90 GO TO 120 GP4 100 20 CALL MMULT GP4 110 GO TO 120 GP4 120 30 CALL MRAISE GP4 130 GO TO 120 GP4 140 40 CALL MKRON GP4 150 GO TO 120 GP4 160 50 CALL MTRIAN GP4 170 GO TO 120 GP4 180 60 CALL MATRIX GP4 190 GO TO 120 GP4 200 70 CALL EXPCON GP4 210 GO TO 120 GP4 220 80 CALL MXTX GP4 230 GO TO 120 GP4 240 90 CALL MDAMAD GP4 250 GO TO 120 GP4 260 100 CALL ARYVEC GP4 270 120 RETURN GP4 280 END GP4 290 *END *COPY,MOP *COPY,MMU *COPY,MRA *COPY,MKR *COPY,MAT *COPY,EXN *COPY,MXT *COPY,MDA *COPY,ARY *COPY,STT *COPY,MTR *COPY,TRA *DECK,GP5 OVERLAY(OMNITD,4,0) PROGRAM OMNITD GP5 10 C VERSION 5.00 CDC OVERLAY GROUP 5 GP5 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP5 30 IF(L1.EQ.27) GO TO 10 GP5 40 CALL INVERT GP5 50 GO TO 20 GP5 60 10 CALL MPROP GP5 70 20 RETURN GP5 80 END GP5 90 *END *COPY,INV *COPY,MPR *COPY,DET *COPY,ORV *ADD,54 WRITE(6,999) IND 999 FORMAT(6H IND= ,I4) *EDIT,INK *COPY,PRK *COPY,PVT *COPY,RCS *COPY,SKS *COPY,SPI *DECK,GP6 OVERLAY(OMNITE,5,0) PROGRAM OMNITE GP6 10 C VERSION 5.00 CDC OVERLAY GROUP 6 GP6 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP6 30 IF(L1.EQ.24) GO TO 20 GP6 40 IF(L1.EQ.18) GO TO 10 GP6 50 CALL MEIGEN GP6 60 GO TO 30 GP6 70 10 CALL COALES GP6 80 GO TO 30 GP6 90 20 CALL ONEWAY GP6 100 30 RETURN GP6 110 END GP6 120 *END *COPY,MEI *COPY,COA *CANCEL,365,369 530 FORMAT (17X,14HBETWEEN GROUPS,5X,I4,2E18.6,4X,F11.3,F10.3) 540 FORMAT (20X,5HSLOPE,14X,I4,2E18.6,3X,F11.3,F10.3) 550 FORMAT (20X,16HDEVS. ABOUT LINE,3X,I4,2E18.6,3X,F11.3,F10.3) 560 FORMAT (17X,13HWITHIN GROUPS,6X,I4,2E18.6) 570 FORMAT (17X,5HTOTAL,14X,I4,E18.6//) *CANCEL,375,382 600 FORMAT (1X,I4,I8,E14.5,A1,E13.5,A1,E13.5,2E14.5,F9.1,E13.5,3H TO, 1E12.5) 610 FORMAT (1X,I4,I8,E14.5,A1,3X,24H ESTIMATE NOT AVAILABLE ,2E14.5,F9 1.1,3X,25H********** TO ***********) 620 FORMAT (/,1X,5HTOTAL,I7,E14.5,28X,2E14.5/7X,20HFIXED EFFECTS MODEL 1 ,2E14.5,37X,E13.5,3H TO,E12.5/7X,20HRANDOM EFFECTS MODEL, 2E14.5, 237X,E13.5,3H TO,E12.5/7X,14HUNGROUPED DATA,6X,2E14.5,37X,E13.5,3H 3TO,E12.5/) *CANCEL,392 660 FORMAT (3X,9(E12.5,1H,)) *CANCEL,402 1 OF BETWEEN COMPONENT,E15.7) *EDIT,ONE *COPY,FPP *COPY,HDI *COPY,RKO *COPY,TPC *DECK,GP7 OVERLAY(OMNITF,6,0) PROGRAM OMNITF GP7 10 C VERSION 5.00 CDC OVERLAY GROUP 7 GP7 20 CALL ORTHO GP7 30 RETURN GP7 40 END GP7 50 *END *ADD,2 C VERSION 5.00 CDC OVERLAY ORTHO COMMON/CDCORT/N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX, IXA,ND7,MD1,IHC, 1IHT,YSUM,SU,ND9,FM,NSU,M1,ND18,ND17,IND19S,IND18S,IND7S,SS,SSOLD *ADD,57 L22=0 *CANCEL,727 CALL OVERLAY(6HOMNITF,6,4,6HRECALL) *CANCEL,732 1590 CALL OVERLAY(6HOMNITF,6,5,6HRECALL) *CANCEL,735 1610 CALL OVERLAY(6HOMNITF,6,3,6HRECALL) *CANCEL,737 CALL OVERLAY(6HOMNITF,6,1,6HRECALL) *CANCEL,762,763 1650 CALL OVERLAY(6HOMNITF,6,2,6HRECALL) C *EDIT,ORT *DECK,GP8 OVERLAY(OMNITF,6,1) PROGRAM GRP8 GP8 10 C VERSION 5.00 CDC OVERLAY GROUP 8 GP8 20 COMMON/CDCORT/N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX, IXA,ND7,MD1,IHC, GP8 30 1IHT,YSUM,SU,ND9,FM,NSU,M1,ND18,ND17,IND19S,IND18S,IND7S,SS,SSOLD GP8 40 DIMENSION B(120),IHC(4),IHT(8),IIRGS(100) GP8 50 DOUBLE PRECISION YSUM GP8 60 COMMON/KFMT/KFMT(100) GP8 70 EQUIVALENCE (IIRGS,KFMT) GP8 80 CALL OANOVA(YSUM,SU,ND9,FM,M,N,ND7,SSQ,IHC,NSU,B) GP8 90 RETURN GP8 100 END GP8 110 *END *COPY,OAN *DECK,GP9 OVERLAY(OMNITF,6,2) PROGRAM GRP9 GP9 10 C VERSION 5.00 CDC OVERLAY GROUP 9 GP9 20 COMMON/CDCORT/N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX, IXA,ND7,MD1,IHC, GP9 30 1IHT,YSUM,SU,ND9,FM,NSU,M1,ND18,ND17,IND19S,IND18S,IND7S,SS,SSOLD GP9 31 DIMENSION B(120),IHC(4),IHT(8),IIRGS(100) GP9 40 DOUBLE PRECISION YSUM GP9 50 COMMON/KFMT/KFMT(100) GP9 60 EQUIVALENCE (IIRGS,KFMT) GP9 70 CALL OCOEFF(M1,N,ND18,ND17,IND19S,IND18S,IHC,B,IND7S,NSU,SS,SSOLD,GP9 80 1YSUM) GP9 81 RETURN GP9 91 END GP9 95 *END *COPY,OCO *DECK,GP10 OVERLAY(OMNITF,6,3) PROGRAM GRP10 GP10 10 C VERSION 5.00 CDC OVERLAY GROUP 10 GP10 20 COMMON/CDCORT/N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX, IXA,ND7,MD1,IHC, GP10 30 1IHT,YSUM,SU,ND9,FM,NSU,M1,ND18,ND17,IND19S,IND18S,IND7S,SS,SSOLD GP10 31 DIMENSION B(120),IHC(4),IHT(8),IIRGS(100) GP10 40 DOUBLE PRECISION YSUM GP10 50 COMMON/KFMT/KFMT(100) GP10 60 EQUIVALENCE (IIRGS,KFMT) GP10 70 CALL OCOVAR(M,ND7,MD1,IHC,B,IHT) GP10 80 RETURN GP10 90 END GP10 95 *END *COPY,OCV *DECK,GP11 OVERLAY(OMNITF,6,4) PROGRAM GRP11 GP11 10 C VERSION 5.00 CDC OVERLAY GROUP 11 GP11 20 COMMON/CDCORT/N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX, IXA,ND7,MD1,IHC, GP11 30 1IHT,YSUM,SU,ND9,FM,NSU,M1,ND18,ND17,IND19S,IND18S,IND7S,SS,SSOLD GP11 31 DIMENSION B(120),IHC(4),IHT(8),IIRGS(100) GP11 40 DOUBLE PRECISION YSUM GP11 50 COMMON/KFMT/KFMT(100) GP11 60 EQUIVALENCE (IIRGS,KFMT) GP11 70 CALL OPONE(N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX) GP11 80 RETURN GP11 90 END GP11 95 *END *COPY,OPO *DECK,GP12 OVERLAY(OMNITF,6,5) PROGRAM GRP12 GP12 10 C VERSION 5.00 CDC OVERLAY GROUP 12 GP12 20 COMMON/CDCORT/N,M,MX,NX,ND2,ND3,ND19,B,SSQ,IX, IXA,ND7,MD1,IHC, GP12 30 1IHT,YSUM,SU,ND9,FM,NSU,M1,ND18,ND17,IND19S,IND18S,IND7S,SS,SSOLD GP12 31 DIMENSION B(120),IHC(4),IHT(8),IIRGS(100) GP12 40 DOUBLE PRECISION YSUM GP12 50 COMMON/KFMT/KFMT(100) GP12 60 EQUIVALENCE (IIRGS,KFMT),(B,IB) GP12 70 CALL ORTPLT(ND19,ND2,N,SSQ,ND3,IB,IIRGS(IXA),IIRGS(2)) GP12 80 RETURN GP12 90 END GP12 95 *END *CANCEL,123 20080 FORMAT(6X,3H1.0,18X,F9.4,16X,I5,2H.0 ,E15.4,E26.4,10X,E10.4) *CANCEL,145 21110 FORMAT(E13.4,14X, E12.4, 8X, E12.4,7X,4H-2.5,22X,3H0.0,22X, *EDIT,ORP *DECK,GP13 OVERLAY(OMNITG,7,0) PROGRAM OMNITG GP13 10 C VERSION 5.00 CDC OVERLAY GROUP 13 GP13 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP13 30 IF (L2.EQ.10) GO TO 30 GP13 40 IF (L2.EQ.8.OR.L2.EQ.9) GO TO 20 GP13 50 IF (L2.EQ.5) GO TO 10 GP13 60 CALL STATIS GP13 70 GO TO 40 GP13 80 10 CALL FPROB GP13 90 GO TO 40 GP13100 20 CALL HISTGM GP13110 GO TO 40 GP13120 30 CALL FRDIST GP13135 40 RETURN GP13140 END GP13150 *END *CANCEL,433 1 9X,26HUNWEIGHTED MEAN =, E15.7,20X, *CANCEL,446 1N IS E11.4,3H TO,E11.4,6H (2-2)/20X,50HA TWO-SIDED 95 PCT CONFIDE *CANCEL,449 1TISTICS//10X,5HSLOPE,20X,1H=, E15.7,20X,7HMINIMUM,18X,1H=,E15.7/1 *CANCEL,452,453 40X,35HPROB EXCEEDING ABS VALUE OF OBS T =, F6.3,20X,8HBETA TWO,17 5X,1H=, E15.7/71X,17HWTD SUM OF VALUES,8X,1H=,E15.7/71X,18HWTD SUM *CANCEL,457 1TE VALUES =, E15.7/10X,26HEXPECTED NO OF RUNS =, F7.1,28X, *CANCEL,458,460 226HWTD AVE ABSOLUTE VALUES =, E15.7/10X,26HS.D. OF NO OF RUNS 3 =, F8.2/10X,26HMEAN SQ SUCCESSIVE DIFF =, E16.7/10X,26HMEAN 4 SQ SUCC DIFF/VAR =, F9.3///10X,24HDEVIATIONS FROM WTD MEAN//1 *CANCEL,471,472 780 FORMAT (I10,E17.7,F9.1,E17.7,22X,I6,2E17.7) 790 FORMAT (I10,E17.7,F9.1,E17.7,E12.3,10X,I6,2E17.7) *EDIT,STA *COPY,FPR *COPY,HIS *COPY,FRD *COPY,FRE *DECK,GP14 OVERLAY(OMNITH,10,0) PROGRAM OMNITH GP14 10 C VERSION 5.00 CDC OVERLAY GROUP 14 GP14 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP14 30 IF (L2.EQ.11.OR.L2.EQ.12) GO TO 10 GP14 40 CALL RANKS GP14 50 GO TO 20 GP14 60 10 CALL CORREL GP14 70 20 RETURN GP14 80 END GP14 90 *END *COPY,RAS *COPY,COR *COPY,CSP *COPY,BJO *COPY,INC *COPY,MST *COPY,RAX *DECK,GP15 OVERLAY(OMNITI,11,0) PROGRAM OMNITI GP15 10 C VERSION 5.00 CDC OVERLAY GROUP 15 GP15 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP15 30 CALL TWOWAY(L2) GP15 40 RETURN GP15 50 END GP15 60 *END *COPY,TWO *DECK,GP16 OVERLAY (OMNITJ,12,0) PROGRAM OMNITJ GP16 10 C VERSION 5.00 CDC OVERLAY GROUP 16 GP16 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP16 30 IF(L1.EQ.29) GO TO 110 GP16 35 IF (L1.EQ.28) GO TO 100 GP16 40 IF(L1.EQ.25) IF(L2-3) 80,80,90 GP16 50 IF (L1.EQ.19) GO TO 70 GP16 60 IF(L2-2) 60,60,10 GP16 70 10 LL2=L2-7 GP16 80 GO TO (20,20,120,30,40,50,20),LL2 GP16 90 20 CALL SORDER GP16110 GO TO 120 GP16120 30 CALL EXCHNG GP16130 GO TO 120 GP16140 40 CALL FLIP GP16150 GO TO 120 GP16160 50 CALL CHANGE GP16170 GO TO 120 GP16180 60 CALL PROROW GP16190 GO TO 120 GP16200 70 CALL ALLSUB GP16210 GO TO 120 GP16220 80 CALL SELECT GP16230 GO TO 120 GP16240 90 IF(L2.EQ.5) GO TO 80 GP16245 CALL INTERP GP16250 GO TO 120 GP16260 100 CALL ITERAT GP16270 GO TO 120 GP16280 110 CALL CMSEPA GP16290 120 RETURN GP16300 END GP16310 GP16320 *END *COPY,SOD *COPY,EXC *COPY,FLI *COPY,CHA *COPY,ALL *COPY,SEL *COPY,INT *COPY,ITE *COPY,CMS *COPY,COX *COPY,CMP *COPY,INR *COPY,PRO *DECK,GP17 OVERLAY(OMNITK,13,0) PROGRAM OMNITK GP17 10 C VERSION 5.00 CDC OVERLAY GROUP 17 GP17 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP17 30 IF (L1.EQ.32) GO TO 100 GP17 40 IF (L1.EQ.24) GO TO 90 GP17 45 IF (L1.EQ.23) IF (L2-6) 70,80,60 GP17 50 IF (L1.EQ.21) IF (L2-3)110,30,20 GP17 70 IF(L1.EQ.20) GO TO 25 GP17 75 20 IF (L2-6) 40,40,50 GP17 80 25 CALL MSCROW GP17 90 GO TO 110 GP17100 30 CALL DEFINE GP17110 GO TO 110 GP17120 40 CALL EXTREM GP17130 GO TO 110 GP17140 50 CALL ERASE GP17150 GO TO 110 GP17160 60 CALL PDMOTE GP17170 GO TO 110 GP17180 70 CALL MISC2 GP17190 GO TO 110 GP17200 80 CALL MOVE GP17210 GO TO 110 GP17220 90 CALL GQUAD GP17230 GO TO 110 GP17240 100 CALL COMPLX GP17250 110 RETURN GP17260 END GP17270 *END *COPY,DEF *COPY,EXT *COPY,ERA *COPY,PDM *COPY,MIS *COPY,MOV *COPY,QUA *COPY,COX *COPY,MSC *DECK,GP18 OVERLAY(OMNITL,14,0) PROGRAM OMNITL GP18 10 C VERSION 5.00 CDC OVERLAY GROUP 18 GP18 20 CALL BESSEL GP18 30 RETURN GP18 40 END GP18 50 *END *ADD,2 C CDC VERSION 5.00 BESSEL *CANCEL,9 DOUBLE PRECISION X,Y,E,P,Q,S,T,Z,DXEX,XEX *ADD,19 COMMON/CDC/ICDC,ICDCK,ICDCN,DBEJX,BES2 DOUBLE PRECISION DBEJX,BES2 *ADD,54 ICDC=1 ICDCK=N ICDCN=M *CANCEL,90 40 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) R(J)=Y*DBEJX *CANCEL,116 90 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) X=Y*DBEJX *CANCEL,161 IF (M.NE.2) GO TO 145 ICDC=1 CALL OVERLAY(6HOMNITL,14B,2,6HRECALL) *CANCEL,169,170 145 IF (M.NE.1) GO TO 148 ICDC=2 CALL OVERLAY(6HOMNITL,14B,2,6HRECALL) 148 Z=X*FDCOS(Y) *CANCEL,234 ICDC=2 DBEJX=Z CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) R(J)=BES2 *CANCEL,244 ICDC=3 ICDCK=K CALL OVERLAY(6HOMNITL,14B,2,6HRECALL) R(J)=BES2 *CANCEL,257 330 DBEJX=Z IF (L2.NE.32) GO TO 335 ICDC=3 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) GO TO 338 *CANCEL,259,261 335 IF (L2.EQ.38) IF(L2-39)338,460,338 ICDC=4 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) 338 DO 340 N=1,K *CANCEL,277 ICDC=4 ICDCK=L CALL OVERLAY(6HOMNITL,14B,2,6HRECALL) *CANCEL,280 360 ICDC=5 ICDCK=L CALL OVERLAY(6HOMNITL,14B,2,6HRECALL) *CANCEL,305 ICDC=5 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) *CANCEL,308 R(J)=DBEJX *CANCEL,331 ICDCK=K ICDCN=L ICDC=6 CALL OVERLAY(6HOMNITL,14B,2,6HRECALL) *CANCEL,340,341 470 ICDC=1 ICDCK=0 ICDCN=7 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) AA(1)=DBEJX ICDCK=1 CALL OVERLAY(6HOMNITL,14B,1,6HRECALL) AA(2)=DBEJX *EDIT,BES *DECK,GP19 OVERLAY (OMNITL,14,1) PROGRAM GRP19 GP19 10 C VERSION 5.00 CDC OVERLAY GROUP 19 GP19 20 COMMON/ABEKI/X,Y,P,Q,S,T GP19 30 DOUBLE PRECISION X,Y,P,Q,S,T,DBEJ,DBEJX,BES2,BINTJ0 GP19 40 COMMON/CDC/ ICDC,ICDCK,ICDCN,DBEJX,BES2 GP19 50 COMMON/SCRAT/NS,NS2,A(13500) GP19 60 DOUBLE PRECISION W(100) GP19 70 EQUIVALENCE(A(4001),W) GP19 80 GO TO (10,20,30,40,50),ICDC GP19 90 10 DBEJX=DBEJ(X,ICDCK,ICDCN) GP19100 GO TO 60 GP19110 20 BES2=BINTJ0(X,W,DBEJX) GP19120 GO TO 60 GP19130 30 CALL BEJN(0,W,DBEJX) GP19140 GO TO 60 GP19150 40 CALL BEJN(1,W,DBEJX) GP19160 GO TO 60 GP19170 50 CALL STRUVE(X,Y,DBEJX,W) GP19180 60 RETURN GP19190 END GP19200 *END *COPY,DBE *COPY,BEJ *COPY,BIN *COPY,STR *DECK,GP20 OVERLAY(OMNITL,14,2) PROGRAM GRP20 GP20 10 C VERSION 5.00 CDC OVERLAY GROUP 20 GP20 20 COMMON/ABEKI/X,Y,P,Q,S,T GP20 30 DOUBLE PRECISION X,Y,P,Q,S,T,DBEJX,BES2,COMELL GP20 40 COMMON/CDC/ ICDC,ICDCK,ICDCN,DBEJX,BES2 GP20 50 COMMON/SCRAT/NS,NS2,A(13500) GP20 60 DOUBLE PRECISION AA(1000),B(1000) GP20 70 EQUIVALENCE (A(1),AA),(A(2001),B) GP20 80 GO TO (10,20,30,40,50,60),ICDC GP20 90 10 CALL CBEK GP20100 GO TO 70 GP20110 20 CALL CBEI GP20120 GO TO 70 GP20130 30 BES2=COMELL(X,ICDCK) GP20140 GO TO 70 GP20150 40 CALL BEZONE(AA,B,1,ICDCK) GP20160 GO TO 70 GP20170 50 CALL BEZERO(AA,B,1,ICDCK) GP20180 GO TO 70 GP20190 60 CALL FOURIA(AA,B(1),B(2),ICDCK,ICDCN) GP20200 70 RETURN GP20210 END GP20220 *END *COPY,CBK *COPY,CBI *CANCEL,33 50 IF (B.NE.0) GO TO 51 CALL ERROR (101) A = 0.D0 GO TO 52 51 A=FDLOG(4.0D0/B) 52 CONTINUE *EDIT,COM *COPY,BEQ *COPY,BEZ *COPY,FOU *DECK,GP21 OVERLAY(OMNITM,15,0) PROGRAM OMNITM GP21 10 C VERSION 5.00 CDC OVERLAY GROUP 21 GP21 20 COMMON/BLOCKE/ NAME(4),L1,L2,ISRFLG GP21 30 L2A=L2-1 GP21 40 GO TO (10,20,30,40,50,60),L2A GP21 45 10 CALL DUMMYA GP21 50 GO TO 70 GP21 60 20 CALL DUMMYB GP21 70 GO TO 70 GP21 80 30 CALL DUMMYC GP21 90 GO TO 70 GP21100 40 CALL DUMMYD GP21110 GO TO 70 GP21120 50 CALL DUMMYE GP21130 GO TO 70 GP21140 60 CALL DUMMYF GP21150 70 RETURN GP21160 END GP21170 *END *COPY,DMA *COPY,DMB *COPY,DMC *COPY,DMD *COPY,DME *COPY,DMF ~eor *COPY,*,* ~eor OMNITAB TEST 1 ROWSUM AND PRODUCT (PROROW) VERSION 5.00 6/19/70 GENERATE NOS. STARTING WITH 2. IN STEPS OF 1.987654 UP TO 20.0 STORE IN COL 1 ADD COLUMN 1 TO THE VALUE 2.0 AND STORE RESULTS IN COLUMN 2 MULTIPLY COLUMN 1 BY COLUMN 2 AND STORE PRODUCT IN COLUMN 3 ADD COLUMN 1 TO VALUES IN COLUMN 2 AND STORE SUM IN COL 4 ADD COL 1 TO COL 3 STORE IN COL 5 ROWSUM THE ENTIRE ARRAY ROW BY ROW STORE SUM IN COL 6 ROWSUM COLUMNS 1 THROUGH 5 AND STORE RESULT IN COLUMN 7 ADD COLUMN 1 TO COL 2 STORE IN COL 8 ADD COLUMN 8 TO COL 3 STORE IN COL 8 ADD COLUMN 8 TO COL 4 STORE IN COL 8 ADD COLUMN 8 TO COL 5 STORE IN COL 8 TITLE1COLUMNS 1 THROUGH 5 CONTAIN AN 11 BY 5 ARRAY DEFINED BY THE TITLE2COMMANDS GENERATE. ADD AND MULTIPLY. TITLE3COL 6 AND 7 CONTAIN ROW SUMS OF THE ARRAY PRODUCED BY THE RO TITLE4WSUM COMMAND. COL 8 CONTAINS ROW SUMS BY USING ADD COMMAND PRINT 1***8 SUBTRACT COL 6 FROM COL 7 STORE IN COLUMN 9 SUBTRACT COL 8 FROM COL 7 STORE IN COLUMN 10 SPACE NOTE ************************************************************************* SPACE NOTE COLUMNS 6 7 AND 8 SHOULD CONTAIN THE SAME VALUES. NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 1 OF COLUMNS 9 AND 10 SPACE NOTE ************************************************************************* PRODUCT OF COLUMNS 1 2 AND 3 ROW BY ROW AND STORE IN COL 10 MULT COL 1 BY COL 2 STORE IN COL 9 MULT COL 9 BY COL 3 STORE IN COL 9 TITLE1 COLUMNS 1 THROUGH 5 CONTAIN AN 11 BY 5 ARRAY DEFINED BY THE TITLE3COL 10 ROW BY ROW PRODUCT OF COLS 1 2 AND 3 CONTAINS USING TITLE4PRODUCT COMMAND. COL 9 CONTAINS PRODUCT USING MULT COMMAND SUBTRACT COL 9 FROM COLUMN 10 AND STORE COLUMN 11 SUM COL 11 STORE IN COLUMN 12 PRINT COLUMNS 1***3 10 9 SPACE NOTE ************************************************************************* SPACE NOTE COLUMNS 9 AND 10 SHOULD CONTAIN THE SAME VALUES. NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 1 OF COLUMN 12 SPACE NOTE ************************************************************************* OMNITAB TEST 2 EXCHANGE (EXCHNG) VERSION 5.00 6/19/70 READ THE FOLLOWING VALUES INTO COLUMNS 1***8 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. .16 20. 30 40 50 60 70 80 90 TITLE1 COLUMNS 1 THROUGH 8 WERE DEFINED BY THE READ COMMAND. PRINT COLUMNS 1***8 MOVE THE ARRAY STARTING IN ROW 1 COL 1 3X1 STORE ROW 1 COL 9 MOVE THE ARRAY START IN ROW 1 COL 3 3X1 STORE ROW 1 COL 10 MOVE THE ARRAY START IN ROW 1 COL 5 3X1 STORE ROW 1 COL 11 EXCHANGE COLUMN 1 WITH COLUMN 2 COLUMN 3 WITH 4 COLUMN 5 WITH COLUMN 6 SPACE NOTE THE FOLLOWING VALUES WERE PRINTED BY THE COMMAND NPRINT. NOTE COLUMN 1 WAS EXCHANGED WITH COLUMN 2, COLUMN 3 ITH COLUMN 4 AND NOTE COLUMN 5 WITH COLUMN 6. SPACE NPRINT COLUMNS 1***8 WITH NO HEADINGS SUBTRACT COL 2 FROM COL 9 STORE IN COL 12 SUBTRACT COL 4 FROM COL 10 STORE IN COL 13 SUBTRACT COL 6 FROM COL 11 STORE IN COL 14 SPACE NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO 0.0 SPACE ABRIDGE ROW 1 OF COLUMNS 12***14 SPACE NOTE ************************************************************************** OMNITAB TEST 3 ERASE (ERASE) VERSION 5.00 6/19/70 READ THE FOLLOWING VALUES INTO COLUMNS 1***8 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. .16 20. 30 40 50 60 70 80 90 TITLE1 COLUMNS 1 THROUGH 8 WERE DEFINED BY THE READ COMMAND. PRINT COLUMNS 1***8 ERASE THE VALUES IN COLUMNS 1 3 AND 8 SPACE NOTE THE FOLLOWING VALUES WHERE PRINTED BY THE COMMAND NPRINT. NOTE THE VALUES IN COLUMNS 1 3 AND 8 HAVE BEEN SET TO ZERO BY ERASE COMMAND. SPACE NPRINT COLUMNS 1***8 WITH NO HEADINGS SPACE NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE 0.0 SPACE ABRIDGE ROW 3 OF COLUMNS 1 AND 3 SPACE NOTE *************************************************************************** OMNITAB TEST 4 FLIP (FLIP) VERSION 5.00 6/19/70 SET THE FOLLOWING VALUES IN COLUMN 1 2.34567 2.14567 7.89456 2.456 8.121456 12.3 FLIP COLUMN 1 INTO COLUMN 2 COLUMN 2 INTO COLUMN 3 TITLE1 COLUMN 1 WAS DEFINED BY THE SET COMMAND TITLE3 COLUMNS 2 AND 3 WERE DEFINED BY FLIP COMMAND. PRINT COLUMNS 1 2 AND 3 SUBTRACT COLUMN 3 FROM COLUMN 1 AND STORE IN COLUMN 4 SPACE NOTE ********************************************************** SPACE NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 4 SPACE NOTE *********************************************************** OMNITAB TEST 5 MAXIMUM AND MINIMUM (EXTREM) VERSION 5.00 6/19/70 READ THE FOLLOWING VALUES INTO COLUMNS 1 AND 2 1.2345 5.46 4.56 7.89 213.45 0.0 21.4 5.6 4.5678 5.445 2.111 3.1121 MAXIMUM VALUE OF COLUMN 1 IS STORED IN COLUMN 3 MAX OF COL 2 STORE IN COL 4 STORE CORRESPONDING VALUE OF COL 1 INTO COL 5 MINIMUM VALUE OF COLUMN 1 IS STORED IN COLUMN 6 MIN OF COL 2 STORE IN COL 7 STORE CORRESPONDING VALUE OF COL 1 INTO COL 8 TITLE1 COLUMNS 1 AND 2 WERE DEFINED BY READ COMMAND. TITLE3 COLUMNS 3 THROUGH 8 WERE DEFINED BY THE MAXIMUM AND MINIMUM TITLE4 COMMANDS. PRINT THE VALUES IN COLUMNS 1***8 RESET 1 ROWSUM COLUMNS 3 4 5 6 7 AND 8 STORE IN 9 SPACE NOTE ************************************************************************ SPACE NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO 440.5845 SPACE ABRIDGE ROW 1 OF COLUMN 9 SPACE NOTE ************************************************************************ OMNITAB TEST 6 DEFINE (DEFINE) VERSION 5.00 6/19/70 SET THE FOLLOWING VALUES IN COLUMN 1 2.34567 2.14567 7.89456 2.456 8.121456 12.3 DEFINE THE VALUE IN ROW 2 OF COLUMN 1 INTO ROW 3 COLUMN 2 DEFINE THE CONSTANT 1023.67 INTO ROW 2 OF COLUMN 2 DEFINE THE VALUE IN ROW 4 OF COLUMN 1 INTO ALL OF COLUMN 3 TITLE1 COLUMN 1 WAS DEFINED BY THE SET COMMAND. TITLE3 ELEMENTS OF COLUMNS 2 AND 3 WERE DEFINED BY DEFINE COMMAND. PRINT COLUMNS 1 2 AND 3 SUM COLUMN 2 AND STORE RESULT IN COLUMN 4 SUB THE CONSTANT 1025.81567 FROM COLUMN 4 STORE RESULT IN COLUMN 4 SUBTRACT THE VALUE IN *4,1* FORM COL 3 AND STORE IN COL 5 SPACE NOTE ************************************************************************ SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO 0.0 SPACE ABRIDGE ROW 2 OF COLUMNS 4 AND 5 SPACE NOTE ************************************************************************ OMNITAB TEST 7 CHANGE (CHANGE) VERSION 5.00 6/19/70 READ THE FOLLOWING VALUES INTO COLUMNS 1***8 1. 2. 3. 4. 5. 6. 7. 8. 9. 10. 11. 12. 13. 14. 15. .16 20. 30 40 TITLE1 COLUMNS 1 THROUGH 8 WERE DEFINED BY THE READ COMMAND. PRINT COLUMNS 1***8 ROWSUM COLUMNS 2 3 AND 8 AND STORE IN COLUMN 9 CHANGE THE SIGNS OF THE VALUES IN COLUMNS 2 3 AND 8 ROWSUM COLUMNS 2 3 AND 8 AND STORE IN COLUMN 10 SPACE NOTE THE FOLLOWING VALUES WERE PRINTED BY THE COMMAND NPRINT. NOTE THE SIGNS OF THE VALUES IN COLUMNS 2,3 AND 8 HAVE BEEN CHANGED. SPACE NPRINT COLUMNS 1***8 WITH NO HEADINGS ADD COLUMN 9 TO COLUMN 10 STORE IN COLUMN 11 SPACE 2 NOTE ******************************************************************* SPACE NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 1 OF COLUMN 11 SPACE NOTE ******************************************************************* OMNITAB TEST 8 HIERARCHY, ORDER AND SORT (SORDER) VERSION 5.00 6/19/70 SET THE FOLLOWING VALUES INTO COLUMN 1 30.0 3.56 2.14 1. 0.0 5.78 8.9 9 123. .12 SET THE FOLLOWING VALUES INTO COLUMN 2 1.245 .44 7.58 23 56 45 78 96 2 HIERARCHY OF COLUMN 1 STORE LOCATION OF SMALLEST TO LARGEST INTO COL 3 AVERAGE OF COLUMN 1 AND STORE IN COLUMN 4 AVERAGE OF COLUMN 2 AND STORE IN COLUMN 5 AVERAGE OF COLUMN 3 AND STORE IN COLUMN 6 TITLE1 COLUMNS 1 AND 2 WERE DEFINED BY THE SET COMMAND. TITLE3 COLUMN 3 CONTAINS THE LOCATIONS OF THE SMALLEST TO LARGEST TITLE4VALUES IN COLUMN 1. PRINT THE VALUES IN COLUMNS 1***3 SORT COLUMN 2 AND CARRY ALONG THE CORRESPONDING VALUES OF COLUMNS 1 AND 3 AVERAGE OF COLUMN 1 STORE IN COL 7 AVERAGE OF COLUMN 2 STORE IN COL 8 SPACE AVERAGE OF COLUMN 3 STORE IN COL 9 NOTE THE VALUES BELOW RESULTED FROM SORTING COLUMN 2 ND CARRYING ALONG THE NOTE CORRESPONDING VALUES OF COLUMNS 1 AND 3. SPACE NPRINT COLUMNS 1***3 WITHOUT HEADINGS ORDER COLUMNS 1**3 AVERAGE OF COLUMN 1 STORE IN COLUMN 10 AVERAGE OF COLUMN 2 STORE IN COLUMN 11 AVERAGE OF COLUMN 3 STORE IN COLUMN 12 SPACE NOTE THE VALUES BELOW ARE THE SORTED VALUES OF THE ABOVE COLUMNS SPACE NPRINT COLUMNS 1***3 WITHOUT HEADINGS SUBTRACT COL 4 FROM COL 7 AND STORE IN COL 13 SUBTRACT COL 8 FROM COL 11 STORE IN COL 14 SUBTRACT COL 6 FROM COL 12 STORE IN COL 15 SPACE 2 NOTE *********************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 1 OF COLUMN 13 14 15 SPACE NOTE *********************************************************************** OMNITAB TEST 9 INTERP (INTERP) VERSION 5.00 6/19/70 GENERATE NOS. FROM 0. STEPS OF .15 THRU 2.4 STORE IN COL 1 SIN OF COL 1 STORE IN COL 2 GENERATE NOS. FROM -.15 IN STEPS OF .1 THRU 2.65 STORE IN COL 3 SIN OF COL 3 STORE IN COL 4 BEGIN COMMANDS TO BE REPEATED INTERP TABLE IN COLS 1 AND 2 LENGTH 17, FOR 29 VALUE OF X IN 3 ORDER 2 PUT IN 5 INCREMENT ABOVE COMMAND 1 WITH 0 0 0 -2 0 1 1 FINISH REPEAT COMMANDS REPEAT 1 THRU 2 5 TIMES INTERP WITH TABLE IN COLS 1 2 LENGTH 17, FOR 20 VALUES OF X IN 3 ORDER 9 10 HEAD COL1/ X-TABLE HEAD COL2/ Y-TABLE SIN HEAD COL3/X TO BE INTR HEAD COL4/ EXACT VALUE HEAD COL5/ ORDER 2 HEAD COL7/ ORDER 4 HEAD COL9/ ORDER 6 HEAD COL10/ ORDER 9 TITLE3 COL 1 COL 2 COL 3 COL 4 TITLE4 COL 5 COL 7 COL 9 COL 10 PRINT COLUMNS 1 2 3 4 5 7 9 AND 10 1/ RESET NRMAX TO 29 1.5/ INCREMENT COMMAND 1 BY -2 2/ ACCURATE DIGITS COL 5 VS COL 4 AND STORE IN COL 11 2.5/ AVERAGE COL 11 STORE IN COL 11 3/ INCREMENT COMMAND 2 BY 1 0 1 4/ INCREMENT COMMAND 2.5 BY 1 1 REPEAT COMMAND 1 THRU 4 6TIMES SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES INDICATE NUMBER OF SIGNIFICANT DIGITS FOR EACH ORDER NOTE OF INTERPOLATION. NOTE THE NUMBERS SHOULD BE EQUAL OR NEAR TO 4.2, 4.9, 5.8, 6.5, 7.1 AND 7.2 SPACE ABRIDGE ROW 1 COLS 11 *** 16 WITH 2.0 SIG. DIGITS SPACE NOTE *************************************************************************** OMNITAB TEST 10 SUM PARPRODUCT. PARSUM AND RMS (MSCROW) VERSION 5.00 6/19/70 READ THE FOLLOWING NUMBERS INTO COLUMN 1 1.0 2.0 3.0 5.0 7.0 0.0 AVERAGE COLUMN 1 AND STORE RESULT IN COLUMN 2 SUM COLUMN 1 AND STORE RESULT IN COLUMN 3 SUM COLUMN 1 ROWS 2 3 4 AND 5 STORE RESULT IN COLUMN 4 PARPRODUCT OF COLUMN 1 AND STORE RESULT IN COLUMN 5 PARSUM OF COLUMN 1 AND STORE RESULT IN COLUMN 6 RMS OF COLUMN 1 AND STORE RESULT IN COLUMN 7 SQUARE COLUMNS 1 AND STORE RESULT IN COLUMN 11 SUM COLUMN 11 AND STORE RESULT IN COLUMN 12 DIVIDE COLUMN 12 BY 6.0 STORE IN COLUMN 12 SQRT OF COLUMN 12 IN COLUMN 13 SUB COLUMN 7 FROM COLUMN 13 STORE IN COLUMN 8 TITLE1RESULTS OF AVERAGE,SUM,PARAPRODUCT,PARSUM AND RMS COMMANDS TITLE3COLUMN 1 WAS DEFINED BY READ COMMAND. PRINT COLUMNS 1 2 3 4 5 6 AND 7 SPACE 2 NOTE COLUMN 2 CONTAINS AVERAGE OF COLUMN 1. NOTE COLUMN 3 CONTAINS SUM OF COLUMN 1. NOTE COLUMN 4 CONTAINS SUM OF ROWS 2-5 OF COLUMN 1. NOTE COLUMN 5 CONTAINS PARTIAL PRODUCTS OF COLUMN 1. NOTE COLUMN 6 CONTAINS PARITAL SUM OF COLUMN 1. NOTE COL 7 CONTAINS THE ROOT MEAN SQUARE OF THE VALUES IN COL 1. SUB *6,3* FROM *6,6* STORE IN COLUMN 9 SUB 3.0 FROM COLUMN 2 AND STORE IN COLUMN 10 SPACE 2 NOTE *********************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 6 OF COLUMNS 8 9 10 AND 5 SPACE NOTE ************************************************************************ OMNITAB TEST 11 PDMOTE, DEMOTE AND PROMOTE (PDMOTE) VERSION 5.00 6/19/70 GENERATE STARTING WITH 1 IN STEPS OF 1 UP TO 10 AND STORE VALUES IN COLUMN 1 DEMOTE BY 2 ROWS COLUMN 1 INTO COLUMN 2 COLUMN 2 INTO COLUMN 3 PROMOTE BY 2 ROWS COLUMN 2 INTO COLUMN 4 COLUMN 3 INTO COLUMN 5 TITLE1 THE FOLLOWIN IS AN EXAMPLE OF PROMOTE AND DEMOTE. TITLE3 COLUMN 1 WAS DEFINED BY THE GENERATE COMMAND. COLUMNS 2. 3. TITLE4 4 AND 5 WERE DEFINED BY THE PROMOTE AND DEMOTE COMMANDS. PRINT COLUMNS 1***5 SPACE NOTE COLUMN 1 WAS MOVED DOWN BY 2 ROWS AND STORED IN COLUMN 2. NOTE COLUMN 2 WAS MOVED DOWN BY 2 ROWS AND STORED IN COLUMN 3. NOTE COLUMN 2 WAS MOVED UP BY 2 ROWS AND STORED IN COLUMN 4. NOTE COLUMN 4 WAS MOVED UP BY 2 ROWS AND STORED IN COLUMN 5. ASUB BEGIN ROW 3 COL 2 8X2 MINUS ROW 1 COL 4 8X2 STORE IN ROW 1 COL 6 SAPROP OF ARRAY IN ROW 1 COL 6 SIZE 8X2 STORE PROPERTIES IN COLUMN 9 NOTE ROW 11 OF COL 9 CONTAINS SUM OF TERMS OF THE 8X2 ARRY IN ROW 1 COL 6 SPACE 2 NOTE *********************************************************************** SPACE NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 11 OF COLUMN 9 SPACE NOTE *********************************************************************** OMNITAB TEST 12 HYPERBOLIC FUNCTIONS VERSION 5.00 6/19/70 GENERATE X STARTING WITH .25 IN STEPS OF .25 UP TO AND INCL 5. INTO 1 SINH OF X IN COL 1 STORE RESULTS IN COL 2 COSH OF X IN COL 1 STORE RESULTS IN COL 3 TANH OF X IN COL 1 STORE RESULTS IN COL 4 COTH OF X IN COL 1 STORE RESULTS IN COL 5 1/ SQUARE COL 2 STORE IN COL 6 2/ INCREMENT 1 BY 1 1 REPEAT STATEMENTS 1 AND 2 4 TIMES SUBTRACT COL 6 FROM COL 7 STORE IN 10 DIVIDE 1.0 BY COL 7 MULT BY 1.0 ADD TO 8 AND STORE IN 11 DIVIDE 1.0 BY COL 6 MULT BY -1.0 ADD TO 9 AND STORE IN 12 AVERAGE COL 10 STORE IN 10 AVERAGE COL 11 STORE IN 11 AVERAGE COL 12 STORE IN 12 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X SINH X COSH X TANH X COTH X SPACE NPRINT COLS 1***5 SPACE 2 NOTE *************************************************************************** SPACE NOTE (COSH(X))**2 - (SINH(X))**2=1 NOTE (TANH(X))**2 + (1/(COSH(X))**2)=1 NOTE (COTH(X))**2 - (1/(SINH(X))**2)=1 NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 1.0 SPACE ABRIDGE ROW 1 COLS 10 11 12 SPACE NOTE *************************************************************************** ASINH OF COL 2 STORE RESULTS IN COL 8 ACOSH OF COL 3 STORE RESULTS IN COL 9 ATANH OF COL 4 STORE RESULTS IN COL 10 ACOTH OF COL 5 STORE RESULTS IN COL 11 NEW PAGE NOTE COL 1 COL 8 COL 9 COL 10 COL 11 NOTE X ARCSINH X ARCCOSH X ARCTANH X ARCCOTH X SPACE NPRINT COLS 1 8***11 SPACE 2 1/ SUBTRACT COL 1 FROM COL 8 STORE RESULT IN 8 2/ AVERAGE COL 8 STORE IN 8 3/INCREMENT 1 BY 0 1 1 4/INCREMENT 2 BY 1 1 PERFORM STATEMENTS 1 THRU 4 4 TIMES NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COL 8***11 SPACE NOTE *************************************************************************** OMNITAB TEST 13 CENSOR, SELECT, AND SEARCH (SELECT) VERSION 5.00 6/19/70 GENERATE STARTING WITH 10 IN STEPS OF 10 UP TO 100 AND STORE VALUES IN COLUMN 1 CENSOR COLUMN 1 FOR VALUES LESS OR EQUAL TO 50. REPLACE 1.0 STORE IN COL 2 CENSOR COL 2 FOR VALUES EQUAL TO VALUES IN 1 REPLACE BY COL 1 PUT IN COL 3 MATCH COL 1 FOR VALUES EQUAL TO VALUES IN COL 3 REPLACE BY 1.0 PUT IN COLUMN 4 SUBTRACT COLUMN 1 FROM COLUMN 3 AND STORE IN COLUMN 20 AVERAGE COLUMN 20 AND STORE IN COLUMN 20 AVERAGE COLUMN 4 AND STORE IN COLUMNE 21 SUBTRACT 1.0 FROM COLUMN 21 AND STORE IN COL 21 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE CENSOR AND MATCH COMMAND TITLE2S. COLUMN 1 WAS SET UP BY THE GENERATE COMMAND. TITLE3 COLUMNS 2 AND 3 WERE DEFINED BY THE CENSOR COMMAND. TITLE4 COLUMN 4 WAS DEFINED BY THE MATCH COMMAND. PRINT COLUMNS 1 2 3 AND 4 SPACE 2 NOTE *************************************************************************** SPACE NOTE COLUMNS 1 AND 3 SHOULD CONTAIN THE SAME VALUES. NOTE COLUMN 4 SHOULD BE EQUAL TO 1.0 NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMNS 20 AND 21 NOTE *************************************************************************** SET THE FOLOWING VALUES IN COLUMN 4 5.0 10.0 10.0 12.0 15.0 1.0 2.0 10.0 10.0 84.0 SELECT IN COL 1 VALUES APPROXIMATING COL 2 TO TOLERANCE .5 STORE IN COL 5 SELECT COL 2 VALUES APPROXIMATING COL 4 TO 10.0 STORE IN 9 TO 11 FREQ IN 12 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE SELECT COMMAND. TITLE2 TITLE3 COLUMNS 9 10 11 AND 12 WERE DEFINED BY SELECT COMMAND TITLE4 PRINT COLUMNS 1 2 4 5 9 10 11 AND 12 ROWSUM COLUMNS 5 9 10 11 12 STORE IN 40 SET IN COLUMN 41 8. 8. 8. 0. 0. 68. 78. 88. 98. 272. SUBTRACT COLUMN 40 FROM COLUMN 41 STORE IN 40 AVERAGE COLUMN 40 STORE IN COLUMN 40 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 40 SPACE NOTE *************************************************************************** SEARCH IN COL 3 FOR NUMBERS IN COL 1 TRANSFER CORRESPONDING VALUES FOR 2 TO 13 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE SEARCH COMMAND. TITLE2 TITLE3 COLUMN 13 WAS DEFINED BY THE SEARCH COMMAND. TITLE4 PRINT COLUMNS 1 2 3 AND 13 SUBTRACT COL 2 FROM COLUMN 13 STORE IN 30 AVERAGE COL 30 AND STORE RESULT IN COL 30 SPACE 2 NOTE *************************************************************************** SPACE NOTE COLUMNS 2 AND 13 SHOULD CONTAIN THE SAME VALUES. NOTE THE FOLLOWING VALUES SHOULD BE CLOSE OR NEAR TO ZERO. SPACE ABRIDGE ROW 1 OF COLUMN 30 SPACE NOTE *************************************************************************** OMNITAB TEST 14 ISOLATE.ISETUP AND ITERATE (ITERATE) VERSION 5.00 6/19/70 GENERATE TRIAL VALUES OF X EQUAL TO 1(1)10 IN COLUMN 1 1/ SIN OF X IN COLUMN 1 PUT Y-SIN(X) IN COLUMN 2 2/ ISOLATE X IN COLUMN 1 FOR Y IN COLUMN 2=0.0 STORE IN COLUMN 3 AND 45 3/ INCREMENT 1 2 2 4/ INCREMENT 2 2 2 0.0 2 0 REPEAT 1 THROUGH 4 6 TIMES TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE ISOLATE COMAND. COLUMN TITLE21 WAS DEFINED BY THE GENERATE COMMAND. TITLE3 COLUMNS 2 4 6 8 10 AND 12 WERE DEFINED BY SIN COMMAND. COLU TITLE4UMNS 3 5 7 9 AND 11 WERE DEFINED BY THE ISOLATE COMMAND. PRINT COLUMNS 1 *** 8 SPACE NOTE COLUMN 9 COLUMN 10 COLUMN 11 COLUMN 12 NPRINT COLUMN 9 *** 12 RESET NRMAX TO 3 PRINT 45 SUM COLUMN 45 AND STORE IN COLUMN 46 SUBTRACT THE VALUE 18.8481445 FROM COLUMN 46 AND STORE IN COLUMN 46 AVERAGE COLUMN 46 AND STORE IN COLUMN 46 SPACE NOTE ********************************************************************* SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 46 SPACE NOTE ********************************************************************* RESET 0 ERASE GENERATE TRIAL VALUES OF X EQUAL TO 0(.1).6 IN COLUMN 1 GENERATE DESIRED Y EQUAL TO .3(.2).5 IN COLUMN 14 NOTE1 THE FOLLOWING IS THE RESULTS OF THE ITERATE COMMAND 1/ SIN X IN COLUMN 1 PUT Y-SIN(X) IN COLUMN 12 2/ ITERATE X IN COLUMN 1 Y IN COLUMN 12 DESIRED Y IN COLUMN 14 STORE IN 1 2.2/ SPACE 2.5/ PRINT NOTE 2.6/ SPACE 3/ NPRINT COLUMNS 1 12 2 3 AND 4 SIN X IN COLUMN 1 PUT Y-SIN(X) IN COLUMN 12 ISETUP X IN COL 1, Y-SIN(X) IN COL 12, DESIRED Y IN COL 14 STORE IN COL 1 TITLE1 TITLE2 TITLE3 TITLE4 NEW PAGE NOTE THE FOLLOWING IS AN EXAMPLE OF THE ISETUP AND ITERATE COMMANDS. SPACE NOTE X Y-SIN(X) BRACKETING X,S BRACKETING Y,S DESIRED. NPRINT COLUMNS 1 12 2 3 AND 4 REPEAT INSTRUCTIONS 1 THROUGH 3 5 TIMES SUM COLUMN 2 STORE IN COLUMN 45 SUM COLUMN 3 STORE IN COLUMN 46 SUBTRACT THE VALUE .82832027 FROM COL 45 AND STORE IN COL 45 SUBTRACT THE VALUE .80002881 FROM COL 46 AND STORE IN COLUMN 46 SPACE NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMNS 45 AND 46 SPACE NOTE ************************************************************************** OMNITAB TEST 15 SHORTEN AND EXPAND (MISC2) VERSION 5.00 6/19/70 GENERATE BEGIN WITH 1. IN STEPS OF 1. UP TO 10. STORE IN COLUMN 1 EXPAND VALUES IN COL 1 TO 6TH POWER IN INTERVALS OF 2 START STORING IN COLUMN 2 SHORTEN COLUMN 1 FOR COLUMNS 2=49. STORE SHORTENED COLUMNS IN 6 AND 7 RESET NRMAX TO 10 TITLE1THE FOLLOWING IS AN EXAMPLE OF SHORTEN AND EXPAND COMMANDS. TITLE2 COLUMN 1 WAS DEFINED BY THE EXPAND COMMAND. COLUMNS 5 AND 6 TITLE3 WERE DEFINED BY THE SHORTEN COMMAND. PRINT COLUMNS 1 2 3 4 5 6 7 SQRT OF COLUMN 2 AND STORE IN COLUMN 5 SUBTRACT COLUMN 5 FROM COLUMN 1 AND STORE IN COLUMN 11 MULTIPLY COL 2 BY COL 2 MULT BY -1.0 ADD TO 4 STORE IN 12 MULTIPLY COL 2 BY COL 3 MULT BY -1.0 ADD TO 4 STORE IN 13 SUM COLUMN 1 AND STORE IN COLUMN 1 SUM COLUMN 6 AND STORE IN COLUMN 6 SUBTRACT COLUMN 6 FROM COLUMN 1 AND STORE IN COLUMN 14 SUB THE VALUE 27.0 FROM COLUMN 14 AND STORE IN COLUMN 14 SUM COLUMN 2 AND STORE IN COLUMN 2 SUM COLUMN 7 AND STORE IN COLUMN 7 SUBTRACT COLUMN 7 FROM COLUMN 2 AND STORE IN COLUMN 15 SUB THE VALUE 245.0 FROM COLUMN 15 AND STORE IN COLUMN 15 SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMNS 11 12 13 14 AND 15 SPACE NOTE ************************************************************************** OMNITAB TEST 16 ELLIPTICAL INTEGRAL OF ORDERS 1 AND 2 (BESSEL) GENERATE 0 (.05) .5 IN COL 1 SUBTRACT 1 FROM 1.0 STORE IN 4 ELLIPTICAL FIRST ORDER OF COL 1 STORE IN COL 2 ELLIPTICAL SECOND ORDER OF COL 1 STORE IN COL 3 ELLIPTICAL FIRST ORDER OF COL 4 STORE IN COL 5 ELLIPTICAL SECOND ORDER OF COL 4 STORE IN COL 6 TITLE1 COL 1 COL 2 COL 3 COL 4 TITLE2 COL 5 COL 6 HEAD 1/ HEAD 2/ ELLIPT 1ST HEAD 3/ ELLIPT 2ND HEAD 4/ Y=1-X HEAD 5/ ELLIPT 1ST HEAD 6/ ELLIPT 2ND TITLE3 X K (X) E (X) Y TITLE4 K (Y) E (Y) PRINT 1***6 MULTIPLY COL 6 BY COL 2 STORE IN COL 7 SUBTRACT COL 2 FROM COL 3 MULTIPLY BY COL 5 ADD TO COL 7 AND STORE IN COL 7 AVERAGE COL 7 STORE IN 8 SPACE 2 NOTE *********************************************************************** SPACE NOTE LET Y=1-X, K(X) AND K(Y) ARE ELLIPTICAL INTEGRALS FO 1ST ORDER, NOTE AND E(X) AND E(Y) ARE ELLIPTICAL INTEGRALS OF 2ND ORDER, THEN NOTE E(X)*K(Y)+E(Y)*K(X)-(K(X)*K(Y)=PI/2 (HANDBOOK OF MATH. FUNC. AMS 55 PG 591) NOTE THEREFORE FOLLOWING VALUE MUST EQUAL OR BE NEAR 1.5707963 SPACE ABRIDGE ROW 1 COL 8 SPACE NOTE *************************************************************************** OMNITAB TEST 17 MATH FUNCTIONS (FUNCT) VERSION 5.00 6/19/70 SET FOLLOWING DATA IN COL 1 5,15,45,75,125,175,200,200,300,350 SIND OF COL 1 STORE RESULTS IN COL 2 COSD OF COL 1 STORE RESULTS IN COL 3 TAND OF COL 1 STORE RESULTS IN COL 4 COTD OF COL 1 STORE RESULTS IN COL 5 TITLE1 EVALUATE SINE, COSINE, TANGENT, AND COTANGENT OF X, X IN D TITLE2EGREES NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X DEGREES SIN X COS X TAN X COT X SPACE NPRINT COLS 1***5 1/SQUARE COL 2 STORE RESULT IN COL 10 2/INCREMENT COMMAND 1 BY 1 AND 1 REPEAT 1 THRU 2 4 TIMES ADD SIND(X) SQUARED IN COL 10 TO COSD(X) SQUARED IN COL 11 AND STORE IN 14 DIVIDE 1.0 BY COL 11 STORE IN 15 DIVIDE 1.0 BY COL 10 STORE IN 16 SUBTRACT COL 12 FROM COL 15 STORE IN 15 SUBTRACT COL 13 FROM COL 16 STORE IN 16 SPACE 2 NOTE FOLLOWING COLUMNS SHOULD CONTAIN VALUES EQUAL TO OR CLOSE TO 1.0 NOTE RELATIONAL EXPRESSIONS OF TRIGNOMETRIC FUNCTIONS SPACE NOTE COL 14 COL 15 COL 16 NOTE SIN**2+COS**2 SEC**2-TAN**2 COSEC**2-COT__2 SPACE NPRINT COLS 14 15 16 AVERAGE COL 14 STORE IN 14 AVERAGE COL 15 STORE IN 15 AVERAGE COL 16 STORE IN 16 SPACE NOTE ********************************************************************** SPACE NOTE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 1.0 SPACE ABRIDGE ROW 1 COLS 14 15 16 SPACE NOTE *********************************************************************** RESET NRMAX 0 GENERATE NOS FROM .1 STEPS .1 THRU 1.0 IN COL 1 ASIND OF X IN COL 1 STORE IN COL 2 ACOSD OF X IN COL 1 STORE IN COL 3 ATAND OF X IN COL 1 STORE IN COL 4 ACOTD OF X IN COL 1 STORE IN COL 5 TITLE1 EVALUATE IN DEGREES THE ARCSIN,ARCCOS,ARCTAN, AND ARCCOT TITLE2 OF X NEW PAGE FIXED 4 NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X ARCSIN X ARCCOS X ARCTAN X ARCCOT X SPACE NPRINT COLS 1***5 ADD COL 2 TO COL 3 STORE RESULTS IN COL 6 ADD COL 4 TO COL 5 STORE RESULTS IN COL 7 SPACE 2 NOTE THE VALUES IN THE FOLLOWING COLS SHOULD BE EQUAL TO OR NEAR 90. SPACE NOTE COL 6 COL 7 NOTE ARCSIN+ARCCOS ARCTAN+ARCCOT SPACE NPRINT COL 6 AND 7 AVERAGE COL 6 STORE IN COL 6 AVERAGE COL 7 STORE IN COL 7 SPACE 2 NOTE ********************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 90. SPACE ABRIDGE ROW 1 COLS 6 7 SPACE NOTE *********************************************************************** OMNITAB TEST 18 BESSEL FUNCTIONS (BESSEL) VERSION 5.00 6/19/70 GENERATE X FROM 1.0 IN STEPS OF .5 THRU 5.0 IN COL 1 BJZERO OF COL 1 STORE IN COL 2 BJONE OF COL 1 STORE IN COL 3 BYZERO OF COL 1 STORE IN COL 4 BYONE OF COL 1 STORE IN COL 5 TITLE1 BESSEL FUNCTIONS J AND Y FOR ORDERS 0 AND 1 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X J ZERO (X) J ONE (X) Y ZERO (X) Y ONE (X) SPACE NPRINT COLS 1***5 MULTIPLY COL 4 BY COL 3 STORE IN COL 6 MULTIPLY COL 5 BY COL 2 MULTIPLY -1.0 ADD TO COL 6 AND STORE IN COL 6 MULTIPLY COL 1 BY *PI* STORE IN COL 7 DIVIDE 2.0 BY COL 7 MULT -1.0 ADD TO COL 6 AND STORE IN COL 6 AVERAGE COL 6 STORE IN COL 6 SPACE 2 NOTE *************************************************************************** SPACE NOTE RELATIONAL EXPRESSION OF BESSEL FUNCTIONS NOTE LET Y0 =Y ZERO (X), YONE=Y ONE (X), NOTE J0 =J ZERO (X), JONE=J ONE (X), NOTE THEN Y0*JONE-YONE*J0-2/(PI*X)=0 NOTE HANDBOOK OF MATHEMATICAL FUNCTIONS AMS 55 PAGE 360 NOTE THEREFORE THE FOLLOWING VALUE MUST BE EQUAL OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COL 6 SPACE NOTE *************************************************************************** BIZERO OF COL 1 STORE IN COL 2 BIONE OF COL 1 STORE IN COL 3 BKZERO OF COL 1 STORE IN COL 4 BKONE OF COL 1 STORE IN COL 5 MULTIPLY COL 2 BY COL 5 STORE IN COL 6 MULTIPLY COL 3 BY COL 4 MULT BY 1.0 ADD COL 6 AND STORE IN COL 6 DIVIDE 1.0 BY COL 1 MULTIPLY BY -1.0 ADD TO COL 6 AND STORE IN COL 6 AVERAGE COL 6 STORE IN COL 6 TITLE1 BESSEL FUNCTIONS I AND K FOR ORDERS 0 AND 1 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X I ZERO (X) I ONE (X) K ZERO (X) K ONE (X) SPACE NPRINT COLS 1***5 EXIZERO OF COL 1 STORE IN COL 2 EXIONE OF COL 1 STORE IN COL 3 EXKZERO OF COL 1 STORE IN COL 4 EXKONE OF COL 1 STORE IN COL 5 MULTIPLY COL 2 BY COL 5 STORE IN COL 7 MULTIPLY COL 3 BY COL 4 MULT BY 1.0 ADD TO COL 7 AND STORE IN COL 7 DIVIDE 1.0 BY COL 1 MULTIPLY BY -1.0 ADD TO COL 7 AND STORE IN COL 7 AVERAGE COL 7 STORE IN COL 7 SPACE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X I ZERO (X) I ONE (X) K ZERO (X) K ONE (X) NOTE *EXP(-X) *EXP(-X) *EXP(-X) *EXP(X) SPACE NPRINT COLS 1***5 NOTE *************************************************************************** SPACE NOTE RELATION EXPRESSION OF BESSEL FUNCTIONS NOTE LET K0 =K ZERO (X), KONE=K ONE (X), NOTE I0 -I ZERO (X), IONE=I ONE (X), NOTE THEN K0*IONE+KONE*I0-1/X=0 NOTE HANDBOOK OF MATHEMATICAL FUNCTIONS AMS 55 PAGE 375 NOTE THEREFORE THE FOLLOWING VALUES MUST BE EQUAL OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLS 6 7 SPACE NOTE *************************************************************************** OMNITAB TEST 19 STRUVE AND INTEGRAL OF J ZERO (BESSEL) VERSION 5.00 6/19/70 GENERATE 0. (.5) 5.0 1 STRUVE ZERO OF VALUES IN COL 1 STORE IN 2 STRUVE ONE OF VALUES IN COL 1 STORE IN 3 INTJO OF COL 1 STORE IN COL 4 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 NOTE X H ZERO (X) H ONE (X) INTEGRAL OF J ZERO SPACE NPRINT COL 1 WITH 2. SIGNIFICANT DIGITS AND COLS 2,3,4 WITH 8.0 SIG DIGITS BJZERO OF COL 1 STORE IN COL 5 BJONE OF COL 1 STORE IN COL 6 MULTIPLY COL 3 BY COL 5 MULT -1.0 ADD TO COL 7 AND STORE IN COL 7 MULT COL 2 BY COL 6 MULT 1.0 ADD TO COL 7 AND STORE IN COL 7 DIVIDE COL 1 BY 2.0 STORE IN 8 MULT COL 1 BY COL 5 STORE IN COL 9 MULT COL 8 BY *PI* MULT BY COL 7 ADD COL 9 STORE IN 7 SUBTRACT COL 4 FROM COL 7 STORE IN 7 AVERAGE COL 7 STORE IN COL 7 SPACE 2 NOTE ************************************************************************ SPACE NOTE INTEGRAL OF J ZERO = X *J0+(PI*X/2)*(H0*J1-H1*J0) NOTE WHERE J1 = J ONE(X), H1 = H ONE(X) NOTE WHERE J0 = J ZERO (X), H0 = H ZERO (X) NOTE J1 = J ONE (X), H1 = H ONE (X) NOTE HANDBOOK MATHEMATICAL FUNCTIONS AMS 55 PAGE 480 NOTE THEREFORE FOLLOWING VALUE MUST BE NEAR OR EQUAL TO 0.0 SPACE ABRIDGE ROW 1 COL 7 SPACE NOTE ************************************************************************* OMNITAB TEST 20 CHEBYSHEV, HERMITE, LAGUERRE AND LENGENDRE POLYNOMALS (ALLSUB) $ VERSION 5.00 6/19/70 GENERATE X FROM .25 IN STEPS OF .25 THRU 2.0 AND STORE IN COL 1 TCHEBYSHEV POL OF ORDER 4 X IN 1 PUT IN 2 $ ORDERS 1 THRU 4 STORED IN COLS 2-5 UCHEBYSHEV POL 4TH ORDER X IN 1 PUT IN 12 NEW PAGE NOTE 4TH ORDER T CHEBYSHEV POLYNOMIAL SPACE NOTE COL 1 COL 3 COL 4 COL 5 COL 6 NOTE X ORDER 1 ORDER 2 ORDER 3 ORDER 4 SPACE NPRINT 1***5 SPACE NOTE 4TH ORDER V CHEBYSHEV POLYNOMIAL SPACE NOTE COL 1 COL 12 COL 13 COL 14 COL 15 NOTE X ORDER 1 ORDER 2 ORDER 3 ORDER 4 NPRINT 1 12***15 DEFINE 1.0 IN COL 11 BEGIN MULTIPLY COL 1 BY COL 11 MULT -1.0 ADD TO 12 STORE IN 6 SUBTRACT 6 FROM 2 STORE IN 6 AVERAGE 6 STORE IN COL 6 INCREMENT ST. 1 BY 0 1 0.0 1 1 INCREMENT ST. 2 BY 1 1 1 INCREMENT ST. 3 BY 1 1 FINISH PERFORM STATEMENTS 1 THRU 6 4 TIMES SPACE 2 NOTE *************************************************************************** SPACE NOTE LET TN = T (X) OF ORDER N, VN = U(X) ORDER N, AND VN1=U (X) ORDER N-1 NOTE WHERE T AND U ARE THE T AND U CHEBYSHEV POLYNOMAILS RESPECTIVELY NOTE THEN TN-VN-X*VN1=0 NOTE REFERENCE - HANDBOOK MATHEMATICAL FUNCTIONS AMS 55 PAGE 777 NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COLS 6 7 8 9 SPACE NOTE *************************************************************************** LAGUERRE POLYNOMIAL OF 3RD ORDER X IN COL 1 STORE STARTING IN COL 2 NORMLAGUERRE ORDER 5 X IN COL 1 STORE STARTING IN COL 12 DIVIDE COL 1 BY 2.0 STORE IN COL 6 LAGUERRE OF 3RD ORDER X IN 6 STORE IN COL 7 NORMLAGUERRE OF 3RD ORDER X IN COL 6 STORE IN COL 17 NEW PAGE NOTE 3RD ORDER LAGUERRE POLYNOMAIL SPACE NOTE COL 1 COL 2 COL 3 COL 4 NOTE X ORDER 1 ORDER 2 ORDER 3 SPACE NPRINT COLS 1***4 SPACE NOTE 3RD ORDER NORMALIZED LAGUERRE SPACE NOTE COL 1 COL 12 COL 13 COL 14 NOTE X ORDER 1 ORDER 2 ORDER 3 NPRINT COLS 1, 12,13,14 MULT COL 8 BY 2.0 STORE IN COL 10 SUB COL 7 FROM COL 10 MULT 6.0 ADD +1.0 STORE IN COL 10 MULT COL 9 BY 8.0 STORE IN 9 SUB COL 9 FROM COL 4 MULT BY 1.0 ADD COL 10 AND STORE IN 10 AVERAGE COL 10 STORE IN 10 SUB COL 17 FROM COL 18 MULT BY 36.0 ADD 6.0 STORE IN COL 11 RAISE 2.0 TO 3.0 MULT BY COL 19 ADD 0.0 STORE IN 20 SUB COL 20 FROM COL 14 MULT BY 1.0 ADD TO COL 11 AND STORE IN COL 11 AVERAGE 11 STORE IN 11 SPACE 2 NOTE *************************************************************************** SPACE NOTE LET Y = X/2 AND LX(N) = L OF ORDER N NOTE THEN LX(3)-8*LY(3)+12*LY(2)-6LY(1)+1.0=0. NOTE AND FOR NORMALIZED LAGUERRE NOTE LX(3)-8*L7(3)+36*LY(2)-36*LY(1)+6=0. NOTE REFERENCE - HANDBOOK MATHEMATICAL FUNCTIONS AMS 55 PAGE 785 NOTE THE FOLLOWING VALUES MUST BE EQUAL OR NEART TO 0.0 SPACE ABRIDGE ROW 1 COL 10 11 SPACE NOTE *************************************************************************** HERMITE POLYNOMIAL OF ORDER 4 X IN COL 1 START STORING IN COL 2 SQRT 2.0 MULT BY COL 6 ADD 0.0 STORE IN COL 6 HERMITE OF ORDER 4 X IN COL 6 START STORING IN COL 12 NEW PAGE SPACE NOTE 4TH ORDER HERMITE POLYNOMIAL SPACE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X ORDER 1 ORDER 2 ORDER 3 ORDER 4 SPACE NPRINT COLS 1 *** 5 SQUARE COL 13 MULT BY -1.5 ADD 0.0 AND STORE IN COL 10 MULT COL 12 BY COL 14 MULT BY -2.0 ADD TO COL 10 AND STORE IN COL 10 MULT COL 15 BY -.5 STORE IN 12 ADD COL 12 TO COL 5 MULT 1.0 ADD TO COL 10 AND STORE IN COL 10 AVERAGE COL 10 STORE IN 10 SPACE 2 NOTE *************************************************************************** SPACE NOTE LET Y=SQRT (2)*X/2, AND HX(N)=H OF ORDER N FOR EITHER X OR Y NOTE THEN HX(4)-.5*HY(4)-2*HY(1)*HY(3)-3*(HY(2))**2=0.0 NOTE REFERENCE - HANDBOOK MATHEMATICAL FUNCTIONS AMS 55 PAGE 785 NOTE FOLLOWING VALUE MUST BE EQUAL OR NEAR TO 0.0 SPACE ABRIDGE ROW 1 COL 10 SPACE NOTE *************************************************************************** LEGENDRE POL OF 3RD ORDER OF X IN 1 STORE IN 2 NEW PAGE NOTE 4TH ORDER LEGENDRE POLYNOMIAL SPACE NOTE COL 1 COL 2 COL 3 COL 4 NOTE X ORDER 1 ORDER 2 ORDER 3 NPRINT COL 1 *** 4 SUM COL 2 STORE IN 5 SUM COL 4 STORE IN 7 MULT COL 3 BY COL 1 STORE IN COL 3 SUM COL 3 STORE IN 3 RESET NRMAX TO 1 MULT COL 5 BY 2.0 STORE IN COL 5 MULT COL 3 BY 5.0 STORE IN COL 3 MULT COL 7 BY 3.0 STORE IN COL 7 SUBTRACT COL 5 FROM COL 3 MULT -1.0 ADD COL 7 STORE IN 7 SPACE 2 NOTE *************************************************************************** SPACE NOTE 3*(P ORDER 3(X)) - 5*X- (P ORDER 2 (X)) + 2* (P ORDER 1 (X)) = 0.0 NOTE REFERENCE - HANDBOOK MATHEMATICAL FUNCTIONS AMS 55 PAGE 334 NOTE FOLLOWING VALUE MUST BE EQUAL OR NEAR TO 0.0 SPACE NPRINT COL 7 SPACE NOTE *************************************************************************** OMNITAB TEST 21 POLYFIT (ORTHO) VERSION 5.00 6/19/70 TITLE1EXAMPLE FROM NBS HANDBOOK 91, PAGE 6-27 SET X IN COLUMN 1 10 20 30 40 50 60 70 SET Y IN COLUMN 2 3.4 11.7 37.2 80.1 151.4 253.2 392.6 POLYFIT Y IN COL 2 WTS 1. DEG 3 X IN 1 COEFFS 3 RES 4 SD PV 5 FC 6 VC (1,11) $ SD PV DENOTES STANDARD DEVIATIONS OF PREDICTED VALUES $ FC DENOTES FOURIER COEFFICIENTS $ C DENOTES VARIANCE COVARIANCE MATRIX HEAD 4/RESIDULES $$ HEAD 3/COEFFS. $ HEAD 5/SD OF PRED.Y HEAD 6/FOURIER $$$ NOTE NOTE NOTE *************************************************************************** SPACE NOTE THE CORRECT COEFFICIENTS (TO 8 SIGNIFICANT DIGITS) FOR A THIRD NOTE DEGREE POLYNOMIAL FIT TO THE GIVEN DATA ARE NOTE 3.4428571, -.29900794, .018547619 AND .00093055556 NOTE NOTE THE CORRECT RESIDUAL STANDARD DEVIATION IS .74764180 SPACE RESET NRMAX 1 SUBTRACT 3.4428571 FROM *1,3* STORE IN COL 20 SUBTRACT -.29900794 FROM *2,3* STORE IN COL 21 SUBTRACT .018547619 FROM *3,3* STORE IN COL 22 SUBTRACT .93055556-3 FROM *4,3* STORE IN COL 23 SUBTRACT .7476418 FROM *12,3* STORE IN COL 24 ABRIDGE ROW 1 COL 20 *** 24 SPACE NOTE *************************************************************************** NOTE NOTE THE DATA USED ABOVE ARE FROM N. B. S., HANDBOOK 91, 'EXPERIMENTAL NOTE STATISTICS', PAGE 6-27 NOTE NOTE THE RELATION OF THE FOURIER COEFFICIENTS TO LEAST SQUARES PROBLEMS IS NOTE GIVEN IN DAVIS AND RABINOWITZ'S 'ADVANCES IN ORTHONORMALIZING NOTE COMPUTATION', A CHAPTER IN 'ADVANCES IN COMPUTERS', EDITED BY NOTE FRANZ ALT, PUBLISHED BY ACADEMIC PRESS, 1961. GENERATE 1 IN STEPS OF 1 THRU 14 IN COL 20 RESET 14 HEAD 20/ N PRINT 20 WITH 2. SIG DIGIT 3***6 WITH 8.0 SIG DIGITS SPACE NOTE VARIANCE - COVARIANCE MATRIX, ETC $$$$ SPACE RESET NRMAX 7 NPRINT COL 20 1. SIG DIGIT 11***14 8.0 SIG DIGITS SPACE 2 NOTE ABOVE OUTPUT IS A PRINT OUT OF THE INFORMATION STORED IN COLS 3-6 , 11-14 SPACE NOTE $ N=1,...,4 COEFFICIENTS NOTE N=5,...,8 STANDARD DEVIATIONS OF THE COEFFICIENTS NOTE N=9 NUMBER OF NON-ZERO WEIGHTS NOTE N=10 DEGREE PLUS 1 NOTE N=11 DEGREES OF FREEDOM FROM RESIDUAL STANDARD DEV. NOTE N=12 RESIDUAL STANDARD DEV. NOTE N=13 RESIDUAL VARIANCE NOTE N=14 MULTIPLE CORRELATION COEFF. SQUARED SPACE NOTE $$ N=1,...,7 RESIDUALS: DEVS. OF PRED. VALUES FROM MEASUREMENTS SPACE NOTE $$$ N=1,....,4 SQUARED FOURIER COEFFICIENTS NOTE N=5,....,8 RESIDUAL SUM OF SQUARES NOTE N=6 TOTAL SUM OF SQUARES NOTE N=7,...,10 FOURIER COEFFICIENTS SPACE NOTE $$$$ ROWS 1-4, COLS 1-4 CONTAIN THE VARIANCE-COVARIANCE MATRIX NOTE ROW 5 (N=5) GRAM FACTORS NOTE ROW 6 (N=6) VECTOR NORMS NOTE ROW 7 (N=7) GRAM DETERMINANTS OMNITAB TEST 22 SIN COS TAN COT (FUNCT) VERSION 5.00 6/19/70 SET FOLLOWING DATA IN COL 1 -1.,-.8,-.6,-.4,-.2,.2,.4,.6,.8,1. SIN OF X IN COL 1 STORE RESULTS IN COL 2 COS OF X IN COL 1 STORE RESULTS IN COL 3 TAN OF X IN COL 1 STORE RESULTS IN COL 4 COT OF X IN COL 1 STORE RESULTS IN COL 5 ASIN OF X IN COL 2 STORE RESULTS IN COL 6 ACOS OF X IN COL 3 STORE RESULTS IN COL 7 ATAN OF X IN COL 4 STORE RESULTS IN COL 8 ACOT OF X IN COL 5 STORE RESULTS IN COL 9 SQUARE SIN X IN COL 2 AND STORE RESULTS IN 10 SQUARE COS X IN COL 3 MULT BY 1.0 ADD TO COL 10 AND STORE IN COL 12 DIVIDE COL 2 BY COL 3 MULT BY -1.0 ADD TO COL 4 STORE IN 13 DIVIDE COL 3 BY COL 2 MULT BY -1.0 ADD TO COL 5 STORE IN 14 AVERAGE COL 12 STORE IN COL 12 AVERAGE COL 13 STORE IN COL 13 AVERAGE COL 14 STORE IN COL 14 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X SIN X COS X TAN X COT X SPACE NPRINT COLS 1 *** 5 SPACE 2 NOTE ************************************************************************** SPACE NOTE (SIN(X))**2+(COS(X))**2=1.0 NOTE TAN(X)-(SIN(X)/COS(X))=0 NOTE COT(X)-(COS(X)/SIN(X))=0 NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 1.0, 0.0 AND 0.0 SPACE ABRIDGE ROW 1 COLS 12 13 14 SPACE NOTE ************************************************************************** ADD COL 1 TO 0.0 STORE IN COL 5 1/ABSOLUTE COL 5 STORE IN 5 2/ACCURACY OF COL 5 VS COL 5 STORE IN COL 10 3/AVERAGE COL 10 STORE IN COL 10 4/INCREMENT STATEMENT 1 BY 1 1 5/INCREMENT STATEMENT 2 BY 0 1 1 6/INCREMENT STATEMENT 3 BY 1 1 REPEAT STATEMENTS 1 THRU 6 5 TIMES NEW PAGE NOTE COL 1 COL 6 COL 7 COL 8 COL 9 NOTE X ARCSIN X ARCCOS X ARCTAN X ARCCOT X SPACE NPRINT COLS 1 6***9 SPACE 2 NOTE *************************************************************************** NOTE NOTE THE FOLLOWING VALUES ARE NUMBER OF SIGNIFICANT DIGITS FOR THE NOTE ABSOLUTE VALUES OF X, ARCSIN, ARCCOS, ARCTAN, AND ARCCOT. NOTE (THE VALUE FOR NUMBER OF SIGNIFICANT DIGITS IS 8.0 FOR NBS COMPUTER) SPACE ABRIDGE ROW 1 COLS 10***14 SPACE NOTE *************************************************************************** GENERATE X FROM 0.1 IN STEPS OF .1 THRU 1.6 IN COL 1 SIN OF COL 1 STORE IN 2 COS OF COL 1 STORE IN 3 TAN OF COL 1 STORE IN 4 COT OF COL 1 STORE IN 5 TITLEY SIN X AND COS X TITLEX X PLOT COLS 2 AND 3 (SIN AND COS X) VS. X IN COL 1 TITLEX X TITLEY TAN X AND COT X PAGE PLOT COLS 4 AND 5 (TAN AND COT) Y FROM 0.0 TO 14.2 VS. COL 1 FROM .1 TO 1.5 OMNITAB TEST 23 MATRIX OPERATIONS M(XX') AND M(X'X) (MXTX) VERSION 5.00 6/12/7 READ THE FOLLOWING DATA INTO COLUMNS 1***5 1.0 2.0 3. 4. 1. 0.0 4.0 5. 6. 7. -14.0 2.0 5. 6. 2. -2.0 3.0 -2. 3. 6. M(XX') MATRIX X IN ROW 2 COLUMN 3 SIZE=3X3 STORE IN ROW 1 COLUMN 37 M(X'X) MATRIX X IN ROW 2 COLUMN 1 SIZE=2X3 STORE IN ROW 2 COLUMN 40 NEW PAGE NOTE THE FOLLOWING IS AN EXAMPLE OF M(XX') AND M(X'X) SPACE 2 NOTE MATRIX X SPACE MPRINT MATRIX X IN ROW 2 COLUMN 3 SIZE=3X3 SPACE 2 NOTE MATRIX XX' MPRINT MATRIX IN ROW 1 COLUMN 37 SIZE=3X3 SPACE 2 NOTE MATRIX Y SPACE MPRINT MATRIX Y IN ROW 2 COLUMN 1 SIZE=2X3 SPACE NOTE MATRIX Y'Y SPACE MPRINT MATRIX IN ROW 2 COLUMN 40 SIZE=3X3 ROWSUM COLUMNS 37***42 AND STORE IN COLUMN 43 AVERAGE COLUMN 43 AND STORE IN COLUMN 43 SUBTRACT THE VALUE 161. FROM COLUMN 43 AND STORE IN COLUMN 43 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 43 NOTE *************************************************************************** OMNITAB TEST 24 BRANCHING AND MATH FUNCTIONS (FUNCT) VERSION 5.00 6/12/70 GENERATE X FROM .25 IN INTERVALS OF .25 THRU 4. IN COL 1 EXP OF COL 1 STORE IN COL 2 NEGEXPONENT OF COL 1 STORE IN COL 3 DIVIDE COL 2 BY COL 3 STORE IN COL 21 LOGE COL 1 STORE IN COL 4 LOGTEN COL 1 STORE IN COL 5 ANTILOG OF COL 5 STORE IN COL 22 INTEGER PART OF COL 2 STORE IN COL 6 FRACTIONAL PART OF COL 2 STORE IN COL 7 SUBTRACT COL 6 FROM COL 2 MULT BY -1.0 ADD TO COL 7 STORE IN COL 23 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE X EXP(X) EXP(-X) NATURAL LOG(X) LOG BASE 10 SPACE NPRINT COLS 1 *** 5 SPACE 2 NOTE COL 2 COL 6 COL 7 NOTE EXP(X) INTEGRAL PART FRACTIONAL PART NOTE OF EXP(X) OF EXP(X) SPACE NPRINT COLS 2 6 7 DEFINE 0.0 IN COL 17 SQUARE COL 2 STORE IN 18 DEFINE COL 1 IN COL 19 ADD 1.0 TO 0.0 STORE IN COL 15 1/ SUBTRACT COL 21 FROM COL 18 STORE IN COL 21 3/ ABS COL 21 STORE IN 21 4/ IFNE 0.0 NOT EQUAL TO 21 WITHIN A TOLERANCE OF 1.0E-5 5/ INCREMENT 1 BY 1 1 AND 1 6/ INCREMENT 3 BY 1 AND 1 7/ INCREMENT 4 BY 0.0 1 AND 0.0 7.5/ IFEQ COL 15 IS EQ TO 2.0 8/ REPEAT COMANDS 1 THRU 7.5 2 TIMES 10/RESTORE 1 AS 23 17 23 11/ ADD 1.0 TO COL 15 STORE IN 15 REPEAT COMMANDS 8 THRU 11 2 TIMES SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 21 22 23 SPACE NOTE *************************************************************************** OMNITAB TEST 25 CORRELATION AND SCORRELATION (CORREL) VERSION 5.00 6/12/70 READ DATA INTO COLS 1***8 83.0 234289 2356 1590 107608 1947 347873.0 60343 88.5 259426 2325 1456 108632 1948 373875.5 61122 88.2 258054 3682 1616 109773 1949 375162.2 60171 96.2 328975 2099 3099 112075 1951 448295.2 63221 89.5 284599 3351 1650 110929 1950 402568.5 61187 98.1 346999 1932 3594 113270 1952 467845.1 63639 99.0 365385 1870 3547 115094 1953 487948.0 64989 100.0 363112 3578 3350 116219 1954 488313.0 63761 101.2 397469 2904 3048 117388 1955 522865.2 66019 104.6 419180 2822 2857 118734 1956 545653.6 67857 108.4 442769 2936 2798 120445 1957 571013.4 68169 110.8 444546 4681 2637 121950 1958 575882.8 66513 112.6 482704 3813 2552 123366 1959 614506.6 68655 114.2 502601 3931 2514 125368 1960 636488.2 69564 115.7 518173 4806 2572 127852 1961 655479.7 69331 116.9 554894 4007 2827 130081 1962 693887.9 70551 CORRELATION 7 VARIABLES IN COLS 1***6, 8, STORE IN 1,9, 8, 9 SCORRELATION 7 VARIABLES IN COLS 1***6,8 STORE IN ROW 1 COL 19 AND ROW 8 COL 19 RESET NRMAX TO 14 NEW PAGE NOTE1 ************************************************************************** NOTE2 ************************************************************************** PRINT NOTE SPACE NOTE THE OUTPUT ON THE PREVIOUS PAGE IS THE AUTOMATIC PRINT OUT OF CORRELATION NOTE THE DATA USED IN THIS PROBLEM WERE TAKEN FROM AN ARTICLE BY NOTE JAMES W. LONGLEY IN ''JOURNAL OF THE AMERICAN STATISTICAL NOTE ASSOCIATION'', VOL. 62, (1967), PAGES 819-841. SPACE PRINT NOTE 1/SUBTRACT COL 9 FROM COL 19 STORE IN 19 2/AVERAGE COL 19 STORE IN COL 19 3/INCREMENT 1 BY 1 1 AND 1 4/ INCREMENT 2 BY 1 AND 1 REPEAT 1 THRU 4 7 TIMES SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COLS 19 *** 25 SPACE NOTE *************************************************************************** OMNITAB TEST 26 ACOALESCE AND AAVERAGE (COALES) VERSION 5.00 6/12/70 DIMENSION NO. OF ROWS=5 NO. OF COLUMNS=16 READ THE FOLLOWING DATA INTO COLUMNS 1***4 1 0 1 2 0 2 1 3 1 2 0 1 0 1 2 0 2 1 3 1 ACOALESCE ON FIRST COL OF ARRAY A IN R=1 C=1 SIZE=5X4 PUT ARRAY B IN R=1 C=5 AAVERAGE ON FIRST COL OF ARRAY A IN R=1 C=1 SIZE=5X4 PUT ARRAY C IN R=1 C=9 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE ACOALESCE AND AAVERAGE C TITLE2OMANDS. ARRAY A IS THE ORIGINAL ARRAY. TITLE3 ARRAY B CONTAINS THE RESULTS OF ACOALESCE. ARRAY C CONTAINS TITLE4 THE RESULTS OF AAVERAGE. NEW PAGE SPACE NOTE ARRAY A ARRAY B SPACE NPRINT COLUMNS 1***8 SPACE 2 NOTE ARRAY C SPACE NPRINT COLUMNS 13***16 AND 9***12 ROWSUM THE ENTIRE WORKSHEET AND STORE SUM IN COLUMN 13 SET THE FOLLOWING VALUES IN COLUMN 14 -15.0 -19.5 -18.0 -3.0 -7.0 ADD COLUMN 13 TO COLUMN 14 AND STORE IN COLUMN 14 AVERAGE COLUMN 14 AND STORE AVERAGE IN COLUMN 14 SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 14 SPACE NOTE ************************************************************************** OMNITAB TEST 27 ONEWAY (ONEWAY) VERSION 5.00 6/19/70 SET 1 40,51,42,47,45,57,47,58,48,45 49,60,58,45,63,55,64,65,54,52 56,71,58,61,69,61,68,70,64,57 SET 2 1,1,1,1,1,2,2,2,2,2,3,3,3,3,3 4,4,4,4,4,5,5,5,5,5,6,6,6,6,6 TITLE1 AUTOMATIC OUTPUT FORM THE COMMAND ONEWAY ONEWAY ANALYSIS FOR DATA IN COL 1, TAG IN 2, PUT STATISTICS IN 11***14 SONEWAY 1 2 21***24 1/SUB COL 11 FROM 21 STORE IN 21 2/AVERAGE COL 21 STORE IN COL 21 3/INCREMENT 1 1 1 1 4/INCREMENT 2 1 1 REPEAT 1 THRU 4 4 TIMES TITLE1 NEW PAGE SPACE 2 NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE 1 21***24 SPACE 1 NOTE ************************************************************************* OMNITAB TEST 28 MTRIAN AND MRAISE (MTRIAN AND MRAISE) VERSION 5.00 6/19/70 READ THE FOLLOWING DATA INTO COLUMNS 2***5 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 4.0 6.0 8.0 10.0 6.0 25.0 20.0 27.0 8.0 20.0 36.0 30.0 10.0 27.0 30.0 36.0 MTRIAN MATRIX IN R=3 C=2 SIZE=4X4 PUT TRIANGULAR IN R=3 C=7 INVERSE IN R=3 C=11 MPRINT MATRIX B IN R=3 C=7 SIZE=4X4 MINVERT MATRIX IN R=3 C=7 SIZE4X4 PUT INVERSE IN R=3 C=15 MSUB MATRIX IN R=3 C=11 SIZE 4X4 MINUS MATRIX IN R=3 C=15 4X4 PUT IN R=3 C=19 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE MTRIAN COMMAND. NEW PAGE SPACE NOTE MATRIX A IS THE ORIGINAL MATRIX. FIXED 4 MPRINT MATRIX A IN R=3 C=2 SIZE=4X4 SPACE NOTE MATRIX B IS THE TRIANGULAR OF MATRIX A (B TIMES B-TRANSPOSE EQUALS A) MPRINT MATRIX B IN R=3 C=7 SIZE=4X4 SPACE NOTE MATRIX C IS THE INVERSE OF MATRIX B MPRINT MATRIX C IN R=3 C=11 SIZE=4X4 ROWSUM COLUMNS 7***10 PUT IN COLUMN 23 ROWSUM COLUMNS 19***22 PUT IN COLUMN 24 AVERAGE COLUMN 23 AND STORE IN COLUMN 23 SUBTRACT 4.8333333 FORM COLUMN 23 AND STORE IN COLUMN 23 AVERAGE COLUMN 24 AND STORE IN COLUMN 24 FLOATING 6 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMNS 23 AND 24 SPACE NOTE *************************************************************************** MRAISE MATRIX A IN R=3 C=7 SIZE=4X4 TO 2ND POWER STORE IN R=3 C=25 MMULT MATRIX A IN R=3 C=7 SIZE=4X4 BY MATRIX IN R=3 C=7 4X4 PUT IN R=3 C=29 MSUB MATRIX IN R=3 C=25 SIZE=4X4 FROM MATRIX IN R=3 C=29 4X4 PUT IN R=3 C=33 ROWSUM COLUMNS 33***36 AND STORE IN COLUMN 37 AVERAGE COLUMN 37 AND PUT IN COLUMN 37 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE MRAISE COMMAND. NEW PAGE SPACE FIXED 2 NOTE MATRIX A IS THE ORIGINAL MATRIX. MPRINT MATRIX A IN R=3 C=7 SIZE=4X4 SPACE NOTE MATRIX B IS MATRIX A RAISED TO THE SECOND POWER. MPRINT MATRIX IN R=3 C=25 SIZE=4X4 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 37 SPACE NOTE *************************************************************************** OMNITAB TEST 29 GAUSS QUADRATURE (GQUAD) VERSION 5.00 6/19/70 GAUSS QUADRATURE 4 PTS. A= 0.0 AND B=1.0 STORE X IN COL 1 WTS. IN COL 2 GENERATE 1 STEPS OF 1 THRU 4 IN COL 3 NEW PAGE NOTE COL 3 COL 1 COL 2 NOTE POINTS N X WEIGHTS SPACE NPRINT COLS 3 WITH 1. SIGNIFICANT DIGS 1 2 WITH 8. SIG DIGITS GAUSS QUADRATURE 8 PTS. A=0.0 AND B=1.0 STORE X IN COL 4 WTS IN COL 5 GENERATE 1 IN STEPS OF 1 THRU 8 IN COL 6 SPACE 2 NOTE COL 6 COL 4 COL 5 NOTE POINTS N X WEIGHTS SPACE NPRINT COL 6 WITH 1.0 SIG DIG. AND COLS 4 5 WITH 8. SIG DIG. MULTIPLY COL 1 BY 2 STORE IN COL 7 MULTIPLY COL 4 BY 5 STORE IN COL 8 SUM 7 STORE IN 7 SUM 8 STORE IN 8 SUBTRACT 8 FROM 7 STORE IN 9 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 9 SPACE NOTE *************************************************************************** OMNITAB TEST 30 BESSEL FUNCTIONS OF COMPLEX ARGUMENTS(BESSEL) VERS 5.00 6/12/70 GENERATE 1.0 1.0 10 COL 1 KBIZERO VALUES IN COL 1 RESULTS COL 2 REAL COL 3 COMPLEX KBKZERO OF COL 1 STORE REAL VALUES IN COL 4, COMPLEXT IN 5 TITLE1 BESSEL FUNCTIONS COMPLEXT ARGUMENTS OF ORDER 0, PHI=PI/4 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE I(Z*EXP(I*PI/4)) K(Z*EXP(I*PI/4)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT COLS 1***5 KBIONE OF COL 1 RESULTS COL 6 REAL COL 7 COMPLEX KBKONE OF COL 1 RESULTS- REAL IN 8 COMPLEX IN 9 SPACE NOTE BESSEL FUNCTIONS COMPLEX ARGUMENTS OF ORDER 1, PHI=PI/4 SPACE NOTE COL 1 COL 6 COL 7 COL 8 COL 9 NOTE I(Z*EXP(I*PI/4)) K(Z*EXP(I*PI/4)) NOTE Z REAL PART IMAGIANRY REAL PART IMAGINARY SPACE NPRINT 1 COLS 6***9 MULT COL 2 BY COL 8 STORE IN COL 11 MULT COL 3 BY COL 9 MULT BY -1. ADD TO COL 11 STORE IN 11 MULT COL 6 BY COL 4 MULT 1.0 ADD TO COL 11 AND STORE IN 11 MULT COL 7 BY COL 5 MULT -1.0 ADD TO COL 11 AND STORE IN COL 11 SQRT 2.0 STORE IN 10 DIVIDE COL 10 BY COL 1 MULT .5 ADD 0.0 STORE IN COL 10 SUBTRACT COL 10 FROM COL 11 STORE IN 11 MULT COL 2 BY COL 9 MULT BY 1.0 ADD TO COL 10 STORE IN 12 MULT COL 3 BY COL 8 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 6 BY COL 5 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 7 BY COL 4 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO NEAR TO 0.0 SPACE AVERAGE COL 11 STORE IN COL 11 AVERAGE COL 12 STORE IN COL 12 ABRIDGE ROW 1 COLS 11 12 SPACE NOTE *************************************************************************** KEXIZERO VALUES IN COL 1 RESULTS COL 2 REAL COL 3 COMPLEXT KEXKZERO OF COL 1 STORE REAL NOS. IN 4 COMPLEX IN 5 KEXIONE OF COL 1 RESULTS COL 6 REAL COL 7 COMPLEX KEXKONE OF COL 1 RESULTS- IN COL 8 COMPLEX IN COL 9 NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE EXP(-Z/SQRT(2))* EXP(Z/SQRT(2))* NOTE I(Z*EXP(I*PI/4)) K(Z*EXP(I*PI/4)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT COLS 1***5 SPACE NOTE BESSEL FUNCTIONS COMPLEX ARGUMENTS OF ORDER 1, PHI=PI/4 SPACE NOTE COL 1 COL 6 COL 7 COL 8 COL 9 NOTE EXP(-Z/SQRT(2))* EXP(Z/SQRT(2))* NOTE I(Z*EXP(I*PI/4)) K(Z*EXP(I*PI/4)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT 1 COLS 6***9 MULT COL 2 BY COL 8 STORE IN COL 11 MULT COL 3 BY COL 9 MULT BY -1. ADD TO COL 11 STORE IN 11 MULT COL 6 BY COL 4 MULT 1.0 ADD TO COL 11 AND STORE IN 11 MULT COL 7 BY COL 5 MULT -1.0 ADD TO COL 11 AND STORE IN COL 11 SQRT 2.0 STORE IN 10 DIVIDE COL 10 BY COL 1 MULT .5 ADD 0.0 STORE IN COL 10 SUBTRACT COL 10 FROM COL 11 STORE IN 11 MULT COL 2 BY COL 9 MULT BY 1.0 ADD TO COL 10 STORE IN 12 MULT COL 3 BY COL 8 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 6 BY COL 5 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 7 BY COL 4 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 AVERAGE COL 11 STORE IN COL 11 AVERAGE COL 12 STORE IN COL 12 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO NEAR TO 0.0 SPACE ABRIDGE ROW 1 COLS 11 12 SPACE NOTE *************************************************************************** RESET V .523598775 CIZERO OF COL 1 PHI=*V* STORE REAL VALUES IN 2, COMPLEX IN 3 CKZERO OF COL 1 PHI=*V* STORE RESULTS- REAL IN 4 COMPLEX IN 5 TITLE1 BESSEL FUNCTIONS COMPLEX ARGUMENTS OF ORDER 0 PHI TITLE2=30 DEGREES OR .523598775 RADIANS NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE I(Z*EXP(I*PHI)) K(Z*EXP(I*PHI)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT COLS 1***5 CIONE OF COL 1 PHI=*V* RESULTS OF COL 6 REAL COL 7 COMPLEX CKONE OF COL 1 PHI=*V* REAL RESULTS IN 8 COMPLEX IN 9 SPACE NOTE BESSEL FUNCTIONS COMPLEX ARGUMENTS OF ORDER 1 PHI=30 DEGREES SPACE NOTE COL 1 COL 6 COL 7 COL 8 COL 9 NOTE I(Z*EXP(I*PHI)) K(Z*EXP(I*PHI)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT 1 COLS 6***9 MULT COL 2 BY COL 8 STORE IN COL 11 MULT COL 3 BY COL 9 MULT BY -1. ADD TO COL 11 STORE IN 11 MULT COL 6 BY COL 4 MULT 1.0 ADD TO COL 11 AND STORE IN 11 MULT COL 7 BY COL 5 MULT -1.0 ADD TO COL 11 AND STORE IN COL 11 COS *V* STORE IN COL 10 DIVIDE COL 10 BY COL 1 STORE IN COL 10 SUBTRACT COL 10 FROM COL 11 STORE IN 11 SIN *V* STORE IN COL 10 DIVIDE COL 10 BY COL 1 STORE IN COL 10 MULT COL 2 BY COL 9 MULT BY 1.0 ADD TO COL 10 STORE IN 12 MULT COL 3 BY COL 8 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 6 BY COL 5 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 7 BY COL 4 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO NEAR TO 0.0 SPACE AVERAGE COL 11 STORE IN COL 11 AVERAGE COL 12 STORE IN COL 12 ABRIDGE ROW 1 COLS 11 12 SPACE NOTE *************************************************************************** RESET V .785398163 RADIANS CEIZERO OF COL 1 PHI=*V* REAL RESULTS IN 2, COMPLEX IN COL 3 CEKZERO OF COL 1 PHI=*V* RESULTS- REAL IN COL 4 COMPLEX IN COL 5 CEIONE OF COL 1 PHI=*V* RESULTS REAL IN COL 6 COMPLEX IN 7 CEKONE OF COL 1 PHI=*V* REAL RESULTS IN 8 COMPLEX IN 9 TITLE2=45 DEGREES OF .785398163 RADIANS NEW PAGE NOTE COL 1 COL 2 COL 3 COL 4 COL 5 NOTE EXP(-Z*COS(PHI)) EXP(Z*COS(PHI))* NOTE I(Z*EXP(I*PHI)) K(Z*EXP(I*PHI)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT 1 COLS 6***9 SPACE NOTE BESSEL FUNCTIONS COMPLEX ARGUMENTS OF ORDER 1, PHI=45 DEGREES SPACE NOTE COL 1 COL 6 COL 7 COL 8 COL 9 NOTE EXP(-Z*COS(PHI))* EXP(Z*COS(PHI))* NOTE I(Z*EXP(I*PHI)) K(Z*EXP(I*PHI)) NOTE Z REAL PART IMAGINARY REAL PART IMAGINARY SPACE NPRINT 1 COLS 6***9 MULT COL 2 BY COL 8 STORE IN COL 11 MULT COL 3 BY COL 9 MULT BY -1. ADD TO COL 11 STORE IN 11 MULT COL 6 BY COL 4 MULT 1.0 ADD TO COL 11 AND STORE IN 11 MULT COL 7 BY COL 5 MULT -1.0 ADD TO COL 11 AND STORE IN COL 11 COS *V* STORE IN COL 10 DIVIDE COL 10 BY COL 1 STORE IN COL 10 SUBTRACT COL 10 FROM COL 11 STORE IN 11 SIN *V* STORE IN COL 10 DIVIDE COL 10 BY COL 1 STORE IN COL 10 MULT COL 2 BY COL 9 MULT BY 1.0 ADD TO COL 10 STORE IN 12 MULT COL 3 BY COL 8 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 6 BY COL 5 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 MULT COL 7 BY COL 4 MULT BY 1.0 ADD TO COL 12 AND STORE IN COL 12 AVERAGE COL 11 STORE IN COL 11 AVERAGE COL 12 STORE IN COL 12 NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO NEAR TO 0.0 SPACE ABRIDGE ROW 1 COLS 11 12 SPACE NOTE ************************************************************************** OMNITAB TEST 31 MOVE (MOVE) VERSION 5.00 6/19/70 READ THE FOLLOWING VALUES INTO COLUMNS 1 2 3 AND 4 1. 6. 11. 16. 2. 7. 12. 17. 3. 8. 13. 18. 4. 9. 14. 19. 5. 10. 15. 20. MOVE THE ARRAY BEGINNING IN ROW 2 COLUMN 2 5 ROWS 3 COLS STORE IN ROW 3 COL 5 TITLE1 COLUMNS 1 THROUGH 4 HAVE BEEN DEFINED BY READ COMMAND. THE TITLE2VALUES OF ROWS 2 THROUGH 6 OF COLUMNS 2 THROUGH 4 HAVE BEEN TITLE3MOVED TO A NEW LOCATION BEGINNING IN ROW 3 OF COL 5. FIVE RO TITLE4WS AND 3 COLUMNS WERE MOVED. RESET NRMAX TO 7 PRINT COLUMNS 1***7 ASUB BEGIN ROW 2 COL 2 5X3 FROM BEGIN ROW 3 COL 5 5X3 STORE IN ROW 2 COL 20 SMPROP BEGIN ROW 2 COL 20 5X3 STORE PROPERTIES IN COL 30 SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 11 OF COLUMN 30 SPACE AMOVE ARRAY BEGINNING IN ROW 3 OF COL 6 R=4 C=2 STORE IN ROW 2 OF COLUMN 10 MMOVE MATRIX BEGINNING IN R=2 C=3 4 ROWS 2 COLUMNS STORE AT R=2 C=12 SPACE NOTE ARRAYS A AND B HAVE BEEN FORMED BY AMOVE AND MMOVE COMMANDS NOTE THEIR ELEMENTS SHOULD ALL BE EQUAL. SPACE NOTE ARRAY A ARRAY B SPACE NPRINT COLUMNS 10***13 SUB COL 11 FROM COL 13 STORE IN 15 AVERAGE COL 15 STORE IN COL 15 SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 1 OF COLUMN 15 SPACE NOTE ************************************************************************** OMNITAB TEST 32 INSERT, MAXMIN AND SEPARATE (CMSEPA) VERSION 5.00 6/12/70 GENERATE STARTING WITH 1 IN STEPS OF 1 UP TO 20 AND STORE VALUES IN COL 1 SEPARATE FROM COLUMN 1 EVERY 2ND ROW START WITH ROW 2 STORE IN COLUMN 2 SEPARATE FROM COL 1 EVERY 2ND ROW START WITH ROW 1 AND STORE IN COL 3 INSERT IN COLUMN 3 FROM COLUMN 2 EVERY 2ND ROW STARTING AT 2ND ROW STORE IN 4 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE INSERT SEPARATE COMM TITLE2ANDS. TITLE3 COLUMN 1 WAS DEFINED BY THE GENERATE COMMAND. COLUMNS 2 AND TITLE4 3 WERE DEFINED BY SEPARATE AND COLUMN 4 BY INSERT. RESET 20 PRINT COLUMNS 1 2 3 AND 4 SUB COL 1 FROM COL 4 AND STORE IN COL 5 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO. ABRIDGE ROW 1 OF COLUMN 5 SPACE NOTE *************************************************************************** RESET 0 GENERATE STARTING WITH -10 IN STEPS OF 10 UP TO 370 AND STORE VALUES IN VOLUMN 4 COSD OF COLUMN 4 AND STORE IN COLUMN 5 MAXMIN X IN COL 4 Y IN COL 5 STORE MAXIMA IN COLS 6 AND 7 MINIMA IN COLS 8 AND 9 TITLE1 THE FOLLOWING IS AN EXAMPLE OF THE MAXMIN COMMAND. X WAS D TITLE2EFINED BY THE GENERATE COMMAND. Y=COSD(X). TITLE3 COLUMNS 6 AND 7 CONTAIN MAXIMA VALUES OF FUNCTION Y TITLE4 COLUMNS 8 AND 9 CONTAIN MINIMA VALUES OF FUNCTION Y HEAD COL 4/ X HEAD COL 5/ Y PRINT COLUMNS 4***9 RESET 2 ROWSUM COL 6***9 STORE IN COLUMN 10 SET IN COL 11 180.0 361.0 SUB COL 10 FROM COL 11 STORE IN 12 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE NPRINT COLUMN 12 SPACE NOTE *************************************************************************** OMNITAB TEST 33 STATISTICAL ANALYSIS (STATIS) VERSION 5.00 6/12/70 SET IN COL 2 THE FOLLOWING DATA 7.884, 7.864, 7.879, 7.872, 7.878, 7.890, 7.874, 7.869, 7.883, 7.852 7.886, 7.882, 7.876, 7.884, 7.883, 7.876, 7.879, 7.885, 7.884, 7.879 7.861, 7.881, 7.871, 7.898, 7.877, 7.867, 7.864, 7.886, 7.882, 7.880 7.884, 7.889, 7.879 STATISTICAL ANALYSIS OF COL 2 SSTATISTICAL ANALYSIS OF COL 2 STORE RESULTS IN 3 4 5 6 RANKS OF COL 2 STORE RESULTS IN COL 10 SUBTRACT COL 10 FROM COL 4 STORE IN COL 11 AVERAGE COL 11 STORE IN COL 11 AVERAGE 3 STORE IN 4 AVERAGE 5 STORE IN 5 AVERAGE 6 STORE IN 6 SPACE 2 NOTE *************************************************************************** SPACE NOTE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 7.580526, 7.87812, 0.0 NOTE AND 0.0 RESPECTIVELY SPACE ABRIDGE 1 4 5 6 11 SPACE NOTE *************************************************************************** FREQUENCY DIST. OF COL 2 USE 10 CELLS LOWER BOUND 21 UPPER IN 22 FREQ 23 MOVE 51,3 SIZE 10X1 TO 1X24 SUM COL 24 STORE IN COL 24 SUM COL 23 STORE IN COL 25 SUBTRACT COL 25 FROM COL 24 STORE IN 25 NEW PAGE NOTE COL 21 COL 22 COL 23 SPACE NOTE LOWER BOUNDARY UPPER BOUNDARY FREQUENCY SPACE NPRINT 21 22 23 ADD COL 21 TO COL 22 MULT .5 ADD 0.0 AND STORE IN COL 26 RESET NRMAX TO 1 SUBTRACT 1.0 FROM VALUE IN *2,3* STORE IN 30 SQUARE VALUE IN *21,3* STORE IN COL 31 F PROBABILITY OF 1.0 AND COL 30 DEG OF FREEDOM IN COL 31 STORE IN COL 32 SUBTRACT VALUE IN *22,3* WITH COL 32 STORE IN COL 32 SPACE NOTE1 THE RESULTS IN ABOVE COL 23 ARE DIFFERENET FROM THE FREQUEN NOTE2CIES IN THE STATISTICAL ANALYSIS PRINT OUT BECAUSE PRINT NOTE NOTE DIFFERENT METHODS FOR COMPUTING WERE USED. SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 25 32 SPACE NOTE *************************************************************************** RESET NRMAX TO 10 HISTOGRAM MID PTS IN COL 26 FREQ. IN COL 23 SPACE 5 NOTE ABOVE PRINT OUT IS FROM HISTOGRAM COMMAND OMNITAB TEST 34 BESSEL COMMANDS (BESSEL) VERSION 5.00 6/12/70 TITLE1 ZEROS OF J ORDER 0 AND 1 AND THEIR DERIVATIONS RESET NRMAX TO 30 ZEROS BJZERO OF J N ZERO FOR N FROM ZERO THRU TWENTY-NINE PUT IN 1 DERIV 2 ZEROS BJONE OF J N ZERO FOR N FROM ZERO THRU TWENTY-NINE PUT IN 3 DERIV 4 SQUARE COL 1 STORE IN COL 6 SQUARE COL 6 STORE IN COL 6 DIV 1.0 BY COL 6 STORE IN 6 SUM COL 6 STORE IN COL 6 BJZERO OF COL 3 STORE IN COL 7 SUBTRACT COL 7 FROM COL 4 STORE IN COL 7 AVERAGE COL 7 STORE IN COL 7 GENERATE 0.0 IN STEPS OF 1.0 THRU 29 STORE IN 8 NEW PAGE NOTE COL 8 COL 1 COL 2 COL 3 COL 4 NOTE N ZEROS J 0 DERIV J 0 ZEROS J ONE DERIV J ONE NPRINT COL 8 WITH 2.0 SIG. DIGITS AND COLS 1 *** 4 WITH 8.0 SIG DIGITS SPACE 2 NOTE *************************************************************************** SPACE NOTE SUM 1/(X**4)-.03125 FOR J ZERO (X)= 0 NOTE THE FOLLOWING VALUES MUST BE EQUAL OR NEAR .03125 AND 0.0 RESPECTIVELY SPACE ABRIDGE ROW 1 COLS 6 7 SPACE NOTE *************************************************************************** TITLE1 RESULTS OF J N (X), I N (X), K N (X) FOR N=0 (1) 29 BESJN OF X= 5.0 STORE RESULTS IN COL 1 BESIN OF X= 2.0 STORE RESULTS IN COL 2 BESKN OF X= 1.0 STORE RESULTS IN COL 3 NEW PAGE NOTE N J N (5) I N (2) K N (1) NOTE COL 8 COL 1 COL 2 COL 3 NPRINT COL 8 WITH 2.0 SIG. DIGITS COLS 1,2,3 WITH 8.0 SIGNIFICANT DIGITS SQUARE COL 1 STORE IN 1 1/MULT COL 1 BY 2. STORE IN 10 2/SUM COL 10 STORE IN 10 3/SUBTRACT *1,1* FROM 10 STORE IN 10 4/INCREMENT 1 BY 1 0. 1 5/INCREMENT 2 BY 1 1 6/INCREMENT 3 BY *0,1* 1 1 EXECUTE 1 THRU 6 2 TIMES DIV 1.0 BY COL 3 STORE IN COL 12 AVERAGE COL 12 STORE IN COL 12 RESET NRMAX 1 SUB .16061621 FROM COL 12 STORE IN COL 12 EXPONENTIAL OF 2. STORE IN COL 4 SUBTRACT COL 4 FROM COL 11 STORE IN 11 SPACE 2 NOTE *************************************************************************** SPACE NOTE1 (SUM OF (J N (X))**2)*2.+(J ZERO (X))**2=1. FOR N=1 THRU NOTE2INFINITY. (IN THIS EXAMPLE N=0,...,29) PRINT NOTE NOTE1 (SUM OF ( I N (X))**2. +I ZOER (X) - EXP(X)=0. FOR N=1 THR NOTE2U INFINITY. (IN THIS EXAMPLE N=0,...,29) PRINT NOTE NOTE NOTE HANDBOOK OF MATHEMATICAL FUNCTIONS AMS 55 PAGE 363 AND 376 NOTE THE FOLLOWING VALUES MUST BE EQUAL OR NEAR 1.0, 0.0 AND 0.0 RESPECTIVELY SPACE PRINT COLS 10,11,12 SPACE NOTE *************************************************************************** OMNITAB TEST 35 MATRIX AND ARRAY COMMANDS (MPROP EXPCON) VERSION 5.00 6/12/70 MIDENT MATRIX A BEGIN IN ROW 2 COLUMN 1 SIZE IS 4X4 MPROPERTIES OF A BEGIN IN ROW 2 COLUMN 1 SIZE IS 4X4 STORE PROPERTIES IN COL 30 SMPROP OF MATRIX A BEGIN IN ROW 2 COLUMN 1 SIZE IS 4X4 STORE PROPERTIES IN 31 RESET NRMAX EQUAL TO 4 NOTE *************************************************************************** SPACE NOTE THE ABOVE IS AN EXAMPLE OF THE AUTOMATIC PRINTOUT FROM MPROPERTIES SPACE NOTE *************************************************************************** SUBTRACT COLUMN 30 FROM COLUMN 31 STORE IN 31 AVERAGE COLUMN 31 STORE IN COLUMN 31 MVECDIAG MATRIX A IN ROW 2 COLUMN 1 SIZE IS 4X4 INTO ROW 2 COLUMN 5 MVECMAT MATRIX A IN ROW 2 COL 1 SIZE 4X4 INTO COLUMN 6 BY ROWS MMATVEC COLUMN 6 INTO MATRIX B ROW 2 COL 7 SIZE 4X4 MDIAGONAL OF C IN ROW 2 COLUMN 11 SIZE IS 4X4 VALUE EQUALS 1.0 APROPERTIES OF C BEGIN IN ROW 2 COLUMN 11 SIZE IS 4X4 STORE PROPERTIES IN 32 NOTE *************************************************************************** SPACE NOTE THE ABOVE IS AN EXAMPLE OF THE AUTOMATIC PRINTOUT FROM APROPERTIES. SPACE NOTE *************************************************************************** MVECDIAGONAL OF C IN ROW 2 COLUMN 11 SIZE IS 4X4 INTO ROW 2 COLUMN 15 MVECMATRIX OF C IN ROW 2 COLUMN 15 SIZE IS 4X4 INOT COLUMN 16 BY ROWS. MMATVECTOR OF 16 INTO MATRIX D ROW 2 COLUMN 17 SIZE IS 4X4 ASUBTRACT B R=2 C=7 SIZE 4X4 FROM MATRIX D R=2 C=17 SIZE=4X4 STORE IN R=1 C=33 ROW SUM COLS 33***36 STORE IN COLUMN 37 AVERAGE COLUMN 37 AND STORE IN COLUMN 37 TITLE1 MATRIX A WAS DEFINED BY THE MIDENT COMMAND, COLUMN 5 BY THE TITLE2 MVECDIAG COMMAND AND COLUMN 6 BY THE MVECMAT COMMAND. RESET NRMAX TO 16 HEAD COL 1/ MATRIX A HEAD COL 2/ HEAD COL 3/ HEAD COL 4/ PRINT COLUMNS 1***6 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 37 SPACE NOTE *************************************************************************** READ THE FOLLOWING DATA INTO COLUMNS 12 13 14 AND 15 4 4 -2 -6 -2 -6 4 4 -6 -2 4 4 4 4 -6 -2 ATRANSPOSE MATRIX B IN ROW 1 COLUMN 12 SIZE 4X4 STORE IN MATRIX C R=1 C=16 MMULT MATRIX C IN R=1 C=16 SIZE 4X4 BY MATRIX B R=1 C=12 4X4 STORE R=9 C=12 MEIGEN MATRIX D IN R=9 C=12 SIZE 4X4 STORE VALUES IN COLUMN 20 VECTORS IN 1 21 TITLE1 THE FOLLOWING IS AN EXAMPLE OF MTRANSPOSE, MMULT AND MEIGEN TITLE2. TITLE3 MATRIX A WAS DEFINED BY THE READ COMMAND. MATRIX B IS THE T TITLE4RANSPOSE OF MATRIX A. HEAD COL 12/ MATRIX A HEAD COL 13/ HEAD COL 14/ HEAD COL 15/ HEAD COL 16/ MATRIX B=A' HEAD COL 17/ HEAD COL 18/ HEAD COL 19/ RESET NRMAX TO 4 PRINT COLUMNS 12***19 SPACE 2 NOTE MATRIX C EQUALS MATRIX A TIMES MATRIX B. SPACE APRINT MATRIX C BEGIN ROW 9 COLUMN 12 SIZE IS 4X4 SPACE 2 NOTE THE FOLLOWING RESULTS ARE FROM THE MEIGEN COMMAND. SPACE NOTE E-VALUES VECTOR 1 VECTOR 2 VECTOR 3 VECTOR SPACE NPRINT COLUMNS 20***24 ROWSUM COLUMNS 20***24 STORE IN COLUMN 25 AVERAGE COLUMN 25 AND STORE IN COLUMN 25 SUBTRACT THE VALUE 72.5 FROM COLUMN 25 STORE IN COLUMN 25 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 25 SPACE NOTE *************************************************************************** MERASE MATRIX BEGINNING IN ROW 1 COLUMN 20 SIZE IS 4X2 MZERO MATRIX BEGINNING IN ROW 1 COLUMN 22 SIZE IS 4X2 AZERO MATRIX BEGINNING IN ROW 1 COLUMN 24 SIZE IS 4X2 ROWSUM COLUMNS 20***24 STORE IN COLUMN 26 AVERAGE COLUMN 26 AND STORE IN COLUMN 26 SPACE NOTE THE COMMANDS MERASE, MZERO AND AZERO HAVE BEEN EXECUTED. NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMNS 25 AND 26 SPACE NOTE *************************************************************************** OMNITAB TEST 36 UNIFORM RANDOM (FNKC) VERSION 5.00 6/12/70 RESET 20 UNIFORM RANDOM NUMBERS STARTING WITH 1.0 PUT IN COLUMN 1 UNIFORM RANDOM NUMBERS STARTING WITH *20,1* PUT IN COLUMN 2 RESET 40 UNIFORM RANDOM NUMBERS, STARTING WITH INTEGER 1, PUT IN COLUMN 3 MOVE 21,3 SIZE 20X1 TO 1,4 RESET NRMAX 20 SUBTRACT 2,4,5 TITLE1 UNIFORM RANDOM NUMBERS STARTING VALUE TITLE3 1.0 3473.0 NO IN COL 1 3473.0 PRINT COLUMNS 1 *** 4 AVERAGE COL 4 STORE IN COL 4 SPACE 2 NOTE FIRST TWENTY SECOND TWENTY FIRST FORTY SPACE 2 NOTE ************************************************************************ SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 5 SPACE NOTE ************************************************************************ OMNITAB TEST 37 CADD CSUBTRACT CMULTIPLY CDIVIDE (COMPLX) VERS 5.00 6/19/70 SET REAL PART OF X IN COLUMN 51 0. 0. 0. 1. 1. 1. 1. 0. 0. 3. 1. 1. 10. 10. 1.2345678 SET IMAGINARY PART OF X IN COLUMN 52 0. 1. 1. 0. 0. 1. 1. 0. 0. 1. 1. -1. 2. 1. 10. -1.2345678 SET REAL PART OF Y IN COLUMN 61 0. 0. 1. 1. 1. 1. 0. 3. 1. 1. -2. 1. 10. -1.2345678 SET IMAGINARY PART OF Y IN COLUMN 62 0. 1. 0. 1. 0. 1. 0. 0. 1. -1. -1. -1. 1. 10. 10. -1.2345678 CADD X 51,52 TO Y 61,62 PUT IN COLUMNS 1,2 CSUBTRACT X 51,52 FROM Y 61,62 PUT IN 11,12 TITLE1 X Y TITLE2 X+Y Y-X TITLE3 REAL IMAGINARY REAL IMAGINARY TITLE4 REAL IMAGINARY REAL IMAGINARY PRINT 51,52 61,62 1,2 11,12 CADD 1,2 TO 11,12 BUT IN COLS 41,42 CSUBTRACT 11,12 FROM 1,2 PUT IN COLS 43,44 CDIVIDE 41,42 BY 2.0,0.0 PUT IN COLS 45,46 CDIVIDE COLS 43,44 BY 2.0,0.0 PUT IN COLS 47,48 SUBTRACT COL 45 FROM COL 61 STORE IN COL 31 SUBTRACT COL 46 FROM 62 STORE IN COL 32 SUBTRACT 47,51,33 SUBTRACT 48,52,34 AVERAGE 31 35 AVERAGE 32 36 AVERAGE 33 37 AVERAGE 34 38 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLS 35 *** 38 SPACE 1 NOTE *************************************************************************** CMULTIPLY 51,52 BY 3.5,1.0 PUT IN COLUMNS 21,22 CDIVIDE 21,22 BY 3.5,1.0 PUT IN COLUMNS 31,32 TITLE1 X X*(3.5+1.0I) TITLE2 X*(3.5+1.0I)/(3.5+1.0I) TITLE4 REAL IMAGINARY PRINT 51,52 21,22 31,32 SUBTRACT 31,51,33 SUBTRACT 32,52,34 AVERAGE 33 35 AVERAGE 34 36 SPACE 2 NOTE *************************************************************************** NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE 1 ABRIDGE ROW 1 OF COLS 35 AND 36 SPACE 1 NOTE *************************************************************************** CPOLAR 51,52 PUT IN COLS 53,54 CRECTANGULAR 53,54 PUT IN COLS 55,56 SUBTRACT 55 51 57 SUBTRACT 56 52 58 AVERAGE COL 57 STORE IN COL 57 AVERAGE COL 58 STORE IN COL 58 TITLE1 X POLAR COORDINATES (X) TITLE2 CHANGE BACK TO RECTANGULAR COORDS. TITLE3 REAL IMAGINARY THETA(ANGLE) RHO(RADIUS) TITLE4 REAL IMAGINARY PRINT 51***56 SPACE 2 NOTE *************************************************************************** SPACE 1 NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COLUMNS 57,58 SPACE NOTE *************************************************************************** OMNITAB TEST 38 TWOWAY AND STWOWAY (TWOWAY) VERSION 5.00 6/12/70 SET DATA IN COLUMN 11 8 2 1 3 2 1 0 4 4 0 3 1 TWOWAY ANALYSIS FOR 3 BY 4 TABLE, DATA IN COL 11, STORE IN 31 AND SUCC. COLS SFIT 11 1.0 6 31***36 41****44 1,45 RESET 40 1/SUBTRACT COL 38 FROM COL 42 IN COL 51 2/ INCREMENT 1 BY 1 1 1 3/AVERAGE COL 51 STORE IN COL 51 4/INCREMENT 3 BY 1,1 PERFORM 1 THRU 4 3 TIMES SPACE 2 NOTE OUTPUT OF THE 2 PREVIOUS PAGES IS FROM THE COMMAND TWOWAY SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COLS 51 52 53 MOVE 1,37 30X4 TO 1,41 RESET 12 STWOWAY 3,4,11,31 RESET 40 1/SUBTRACT COL 38 FROM COL 42 IN COL 51 3/AVERAGE COL 51 STORE IN COL 51 PERFORM 1 THRU 4 3 TIMES ABRIDGE ROW 1 COLS 51 52 53 SPACE NOTE *************************************************************************** OMNITAB TEST 39 ROUND (FNEIC) VERSION 5.00 6/19/70 SET IN COLUMN 21 DATA 7.2444443+01 6.4748596+00 1.6718015+00 2.0000000+01 5.2533334+00 4.1923807+01 9.0262909+00 6.8147674+01 -8.2094830-01 4.2543463-01 1.0000000+01 1.3563949-01 1.952560+00 1.0760000+03 7.7772000+04 DEFINE COLUMN 21 INTO COLUMN 1 SUBTRACT COLUMN 21 FROM 1 PUT IN COL 41 5/ ROUND 21 TO 7 SIGNIFICANT DIGITS AND STORE IN COL 22 6/ INCREMENT 5 BY 1,-1,1 7/ROUND COL 1 TO 7 SIG. DIGITS SOTRE IN COL 2 8/INCREMENT 7 BY 0 -1 1 9/SUBTRACT COL 2 FROM COL 22 STORE IN COL 32 10/INCREMENT 9 BY 1,1,1 11/AVERAGE COL 32 STORE IN COL 42 12/INCREMENT 11 BY 1 1 PERFORM 5 THRU 12, 7 TIMES TITLE1 NUMBER OF SIGNIFICANT DIGITS PER COLUMN. TITLE3 8 7 6 5 TITLE4 4 3 2 1 PRINT 21 *** 28 SPACE 2 NOTE NUMBER OF SIGNIFICANT DIGITS PER COLUMN. NOTE2 4 3 2 1 NOTE1 8 7 6 5 SPACE 2 PRINT NOTE SPACE 2 NPRINT 1 *** 8 NOTE1 ************************************************************************* NOTE2 ************************************************************************* PRINT NOTE SPACE NOTE THE FOLLOWING VALUES SHOULD BE EQUAL TO OR NEAR 0.0 NOTE THEY ARE NOT EXACTLY ZERO DUE TO USING TWO DIFFERENT METHODS OF ROUNDING SPACE ABRIDGE ROW 1 COL 41***48 SPACE PRINT NOTE OMNITAB TEST 40 ERROR AND CREF (FNEC) VERSION 5.00 6/12/70 GENERATE 0(1)20 IN COLUMN 1 $ 21 VALUES DIVIDE COLUMN 1 BY 10.0 AND PUT IN COLUMN 1 SET IN COLUMN 11 $ AMS 55, 310-311 VALUES OF ERF 0.00000000 0.11246292 0.22270259 0.32862676 0.42839236 0.52049988 0.60385609 0.67780119 0.74210096 0.79690821 0.84270079 0.88020507 0.91031398 0.93400794 0.95228512 0.96610515 0.97634838 0.98379046 0.98908050 0.99279043 0.99532226 SUBTRACT COLUMN 11 FROM 1.0 AND PUT CREF IN COLUMN 12 ERROR OF COLUMN 1 PUT IN COLUMN 21 CERF OF COLUMN 1 PUT IN COLUMN 22 ADD COLUMN 21 TO COLUMN 22 AND PUT IN COLUMN 23 SUBTRACT COLUMN 23 FROM 1. PUT IN COLUMN 33 AVERAGE COLUMN 33 PUT IN COLUMN 43 TITLE1 EXACT COMPUTED EXACT TITLE2 COMPUTED TITLE3 X ERF(X) ERF(X) ERFC(X) TITLE4 ERFC(X) PRINT COLUMNS 1,11,21,12,22 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE 1 ABRIDGE ROW 1 OF COLUMN 43 SPACE NOTE *************************************************************************** OMNITAB TEST 41 THERMODYNAMIC FUNC (THERMO) VERSION 5.00 6/19/70 GENERATE 1.05 .05 1.5 1 ADD 0. TO 1.43879 PUT IN COL 2 EINSTEIN OF TEMPS IN COL 2, WAVE NOS. IN 1, PUT TABLE IN 11 ND SUCC. COLS. TITLE1 EINSTEIN FUNCTION TITLE3 X -(F-E)/RT (H-E)-RT S/R TITLE4 C/R (H-E)/R PRINT 11,13***17 ERASE RESET NRMAX TO 10 SPACE 2 NOTE *************************************************************************** NOTE MOLECULAR WEIGHTS OF NOTE WATER PROPANAL TETRATOMIC PHOSP URANIUM OXIDE MOLWT 1 2 8 1 1 MOLWT 6 3 1 8 8 1 2 $ C3 H7 OH MOLWT 15 4 3 $ P4 MOLWT 92 3 8 8 4 $ U3 O8 SPACE ABRIDGE ROW 1 COL 1***4 SPACE NOTE *************************************************************************** RESET NRMAX 0 GENERATE 100. 100. 1500. 61 ADD 1.98717 0. 28 PFTRANSLATIONAL COL 61 *1, 1 * 4 TITLE1 TRANSLATIONAL CONTRIBUTIONS OF TITLE2 WATER TITLE3 TEMPERATURE -(F-E)/RT (H-E)/RT S/R TITLE4 C/R (H-E)/R PRINT 4***9 MULTIPLY 5 28 10 MULTIPLY 7 28 11 MULTIPLY 8 28 12 LOG 61 IN 21 LOGE *1, 1* STORE IN COL 22 ADD 2.5 0. 23 MULTIPLY 23 21 24 MULTIPLY 1.5 22 25 ADD 0. -3.66495 26 ROWSUM 24***26 TO 31 ADD 23 31 32 MULTIPLY 31 28 33 MULTIPLY 32 28 34 SUBTRACT 5 31 31 SUB 7 32 32 SUB 10 33 33 SUB 11 34 34 1/ AVERAGE COL 31 STORE IN 31 2/ INCREMENT 1 BY 1 1 EXECUTE 1 THRU 2 4 TIMES SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 31***34 SPACE NOTE ************************************************************************** ERASE TITLE1 PTATMOIC OF ATOMIC TITLE2OXYGEN GENERATE 1000. 500. 8000. 1 SET INTO COL 2 78. 15868. 33792. SET INTO COL 3 9. 5. 1. PFATOMIC 1 31.9988 2 3 41 PFTRANS 1 31.9988 31 1/SUBTRACT COL 41 FROM 31 STORE IN 31 2/AVERAGE COL 31 STORE IN 31 3/INCREMENT 1 BY 1,1,1 4/INCREMENT 2 BY 1,1 REPEAT 1 THRU 4 6 TIMESS PRINT 41***46 SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COLS 31***36 SPACE NOTE ************************************************************************** PARTFUNCTION 1 2 3 11 TITLE1 PARTFUNCTION OF ATOMIC OX TITLE2YGEN TITLE2 TITLE3 TEMPERATURE WAVE NO. G Q(0) TITLE4 Q(1) Q(2) PRINT 1,2,3,11,12,13 BOLDISTRIBUTION POPULATIONS OF STATES 1 2 3 21 ROWSUM 21***23 INTO 24 SUBTRACT COL 24 FROM 1.0 STORE IN COL 24 TITLE1 BOLDISTRIBUTION POPULATION OF TITLE2 STATES TITLE3 TEMPERATURE WAVE NO. G ************ TITLE4*** RESULTS **************** PRINT 1,2,3,21,22,23 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE SHOULD BE CLOSE TO OR EQUAL TO ZERO. SPACE ABRIDGE ROW 1 COL 24 SPACE NOTE *************************************************************************** OMNITAB TEST F1 HARMONIC ANALYSIS (BESSEL) VERSION 5.00 6/12/70 SET 1 149 137 128 126 128 135 159 178 189 191 189 187 178 170 177 183 181 179 179 185 182 176 166 160 HARMONIC OF POINTS IN COL 1 24 POINTS RESULT IN 2 GENERATE 0. (15.) 345. 3 HEAD 3/ DEGREE HEAD 1/ POINTS HEAD 2/ COEF PRINT 3 1 2 SPACE NOTE ABOVE PROBLEM IS EXAMPLE FROM J.B. SCARBOROUGH NOTE NUMERICAL MATHEMATICAL ANALYSUS (2ND ED.,1950) PAGES 490-491 $ READ FOLLOWING DATA INTO COL 11 DATA WILL NOT BE LISTED NO LIST READ 5 CARDS INTO 1 167.1667 -19.983114 -3.4098820 5.4706860 -1.2916667 .24975992 .74999999 .30921159 .45833333 -.30401935 -.090117976 -.24252388 -.0833333 -12.779232 -16.62457 -.32322330 1.51554444 1.4616939 -2.583333 .32216583 -.21650635 .67677669 -.45876290 -.63970397 LIST SUBTRACT 11 FROM 2 STORE IN 11 AVERAGE 1S STORE IN 11 SPACE 2 NOTE ********************************************************************* SPACE NOTE VALUE IN THE NEXT ROW MUST BE CLOSE TO OR EQUAL ZERO SPACE FORMAT A (30X,1PE15.6) ABRIDGE A ROW 1 COL 11 SPACE NOTE ********************************************************************** OMNITAB TEST F2 BRANCHING COMMANDS (IFS) VERSION 5.00 6/19/70 GENERATE X FROM 0.0 IN STEPS OF 10.0 THRU 50. IN COL 1 ADD COL 1 TO 0.0 STORE IN COL 2 FORMAT F (50H THE FOLLOWING VALUE MUST BE NEAR OR EQUAL TO 25./10X,F5.1) 1/AVERAGE COL 2 STORE IN COL 10 2/IFGT IF COL 10 IS GREATER THAN 27.0 STOP REPEAT MODE 3/NULL OTHERWISE CONTINUE 4/ABRIDGE F ROW 1 COL 10 5/ADD 10.0 TO COL 2 STORE IN 2 10/ ADD 0.0 TO COL 1 STORE IN COL 2 NEW PAGE NOTE THIS IS A TEST OF THE BRANCH COMMANDS. NOTE THUS THE OUPUT MUST BE AS FOLLOWS SPACE 2 NOTE ************************************************************************** SPACE NOTE BECAUSE THE IFGT CONDITION IS TRUE, REPEAT MODE IS TERMINATED NOTE AND THE FOLLOWING STATEMENT IS PRINTED ONLY ONCE. REPEAT COMMAND 10 THRU 10 1 TIME REPEAT COMMANDS 1 THRU 5 3 TIMES. SPACE NOTE ************************************************************************** SPACE 2 NOTE ************************************************************************** SPACE NOTE BECAUSE THE IFGE CONDITION IS TRUE, REPEAT MODE IS TERMINATED NOTE AND THE FOLLOWING STATEMENT IS PRINTED ONLY ONCE. 2/IFGE IF COL 10 IS GREATER THAN OR EQUAL TO 30.0 STOP REPEAT MODE REPEAT COMMAND 10 THRU 10 1 TIME REPEAT COMMANDS 1 THRU 5 3 TIMES SPACE NOTE *************************************************************************** SPACE 2 NOTE *************************************************************************** SPACE NOTE BECUASE THE IFLT CONDITION IS TRUE, REPEAT MODE IS TERMINATED NOTE AND THE FOLLOWING STATEMENT IS PRINTED ONLY ONCE. 2/IFLT IF 27.0 IS LESS THEN ALL VALUES OF COL 10 STOP REPEAT MODE REPEAT COMMAND 10 THRU 10 1 TIME REPEAT COMMANDS 1 THRU 5 3 TIMES SPACE NOTE *************************************************************************** SPACE 2 NOTE *************************************************************************** SPACE NOTE BECAUSE THE IFLE CONDITION IS TRUE. REPEAT MODE IS TERMINATED NOTE AND THE FOLLOWING STATEMENT IS PRINTED ONLY ONCE. 2/IFLE IF 30.0 IS LESS THAN OR EQUAL TO ALL VALUES IN COL 10 STOP REPEAT MODE REPEAT COMMAND 10 THRU 10 1 TIME REPEAT COMMANDS 1 THRU 5 3 TIMES NOTE *************************************************************************** SPACE 2 NOTE *************************************************************************** SPACE NOTE BECAUSE THE COMPARE CONDITION IS TRUE, REPEAT MODE IS TERMINATED NOTE AND THE FOLLOWING STATEMENT IS PRINTED ONLY ONCE. 2/ COMPARE COL 10 WITH VALUE 35. RELATIVE ERROR OF 91E-3 REPEAT COMMAND 10 THRU 10 1 TIMES REPEAT COMMANDS 1 THRU 5 3 TIMES SPACE NOTE *************************************************************************** OMNITAB TEST F3 ADD SUBTRACT MULTIPLY DIVIDE (ARITH) VERSION 5.00 6/19/70 GENERATE NOS FROM 1.0 IN STEP OF .5 UP TO AND INCLUDING 5. IN COL 1 GENERATE NOS FROM -.8 IN STEPS OF .1234565 THRU .18 IN COL 20 ADD COL 1 TO COL 20 STORE RESULTS IN COL 2 SUBTRACT COL 20 FROM COL 1 STORE IN COL 3 MULTIPLY COL 1 BY COL 20 STORE IN 4 DIVIDE COL 1 BY COL 20 AND STORE IN COL 5 TITLE1 RESULTS FROM ADD, SUBTRACT, MULTIPLY, AND DIVIDE COMMANDS SUBTRACT COL 20 FROM COL 2 STORE IN COL 6 ADD COL 20 TO COL 3 STORE IN COL 7 DIVIDE COL 4 BY COL 20 AND STORE IN 8 MULTIPLY COL 5 BY COL 20 AND STORE IN COL 9 2/AVERAGE COL 6 STORE IN 15 4/INCREMENT COMMAND 2 WITH 1 1 REPEAT 2 THRU 4 4 TIMES FORMAT A (18A4) READ A 1 31***49 COL 1 COL 20 COL 2 COL 3 COL 4 COL 9 NEW PAGE FORMAT B(8X,18A4) ABRIDGE B 1 31**49 SPACE READ A 1 31***49 X Y X+Y X-Y X*Y X/Y ABRIDGE B 1 31***49 SPACE NPRINT COLS 1 20 2 3 4 5 NOTE NOTE ALL THE COLUMNS BELOW SHOULD BE THE SAME AS X (FIRST COL) NOTE NOTE COL 1 COL 6 COL 7 COL 8 COL 9 SPACE NOTE X (X+Y)-Y (X-Y)+Y (X*Y)/Y (X/Y)*Y SPACE NPRINT COLS 1 6***9 AVERAGE COL 1 STORE IN COL 14 SPACE NOTE ********************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE EQUAL TO OR NEAR 3.0 SPACE ABRIDGE 1 14***18 SPACE ADD 1.0 0.0 STORE IN 2 ADD COL 1 TO .5 MULT BY COL 1 ADD TO COL 2 AND STORE IN COL 2 DEFINE 0.0 IN COL 3 SUB COL .5 FROM COL 1 MULT 2.0 ADD TO COL 3 AND STORE IN COL 3 DIVIDE 1.0 BY COL 1 STORE IN 10 SUBTRACT 1.0 FROM COL 2 MULT BY COL 10 ADD -.5 STORE IN 4 DIVIDE COL 3 BY 2.0 MULT BY 1.0 ADD .5 STORE IN 5 SUBTRACT COL 4 FROM COL 1 STORE IN 6 SUBTRACT COL 5 FROM COL 1 STORE IN 7 NEW PAGE NOTE COL 1 COL 2 COL 3 NOTE X (X+.5)X+1 2(X-.5) SPACE NPRINT 1 2 3 AVERAGE 6 INTO COL 6 AVERAGE 7 INTO COL 7 SPACE 2 NOTE ********************************************************************* SPACE NOTE FOLLOWING VALUES MUST BE EQUAL OR BE NEAR ZERO. SPACE ABRIDGE 1 6 7 SPACE NOTE ********************************************************************** OMNITAB TEST F4 USE OF FIT, SFIT, AND SPOLYFIT (ORTHO) VERSION 5.00 6/19/70 SCAN 55 THIS WILL IGNORE ALL NUMERICS IN CARD COLS 56 AND BEYOND CARD 1 SET X IN COL 11 CARD 2 35,45,55,65,75 CARD 3 SET Y IN COL 37 CARD 4 114,124,143,158,166 CARD 5 DEFINE 1.0 AND STORE IN COLUMN 10 CARD 6 SQUARE COL 11 AND STORE IN COL 12 CARD 7 MULTIPLY COL 11 BY COL 12 AND STORE IN 13 CARD 8 SPOLYFIT Y COL 37 WT=1. DEG 1 X IN 11 STORE 20***23,1,24 CARD 9 FIT Y IN 37 WT IN 10 FUNC2 X IN 10,11 STORE 40***43,1,44 CARD 10 SUBTRACT COL 41 FROM COL 21 STORE IN 41 CARD 11 SUBTRACT COL 42 FROM COL 22 STORE IN 42 CARD 12 AVERAGE COL 41 STORE IN COL 41 CARD 13 AVERAGE COL 42 STORE IN COL 42 CARD 14 RESET NRMAX TO 16 CARD 15 SUBTRACT COL 20 FROM COL 40 STORE IN 40 CARD 16 AVERAGE COL 40 STORE IN COL 40 CARD 17 RESET NRMAX TO 12 CARD 18 SUBTRACT COL 43 FROM COL 23 PUT IN COL 43 CARD 19 AVERAGE COL 43 STORE IN 43 CARD 20 RESET NRMAX TO 8 CARD 21 SUBTRACT COL 44 FROM COL 24 PUT IN COL 44 CARD 22 AVERAGE COL 44 PUT IN COL 44 CARD 23 SUBTRACT COL 45 FROM COL 25 PUT IN COL 45 CARD 24 AVERAGE COL 45 PUT IN COL 45 CARD 25 FORMAT D(1X,1P6E13.5) CARD 26 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE EXAMPLE GIVEN ABOVE IS FROM G. W. SNEDECOR'S 'STATISTICAL METHODS' NOTE (5TH ED. 1956), PAGES 122-126 SPACE NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 ABRIDGE D ROW 1 OF COLS 40***45 SPACE NOTE *************************************************************************** SCAN ALL 80 COLUMNS OF EACH CARD RESET NRMAX TO 5 SFIT Y IN 37 WT=1.0 FUNC. OF 2 X IN 10,11 STORE 50***53,1,54 MORTHO ROW 1 COL 10 SIZE 5X2 WTS=1.0 STORE ORTHO VEC IN 1,20 AND A IN 1,25 NEW PAGE NOTE RESULTS FROM MORTHO SPACE NOTE ORTHONORMAL VECTORS SPACE MPRINT MATRIX IN ROW 1 COL 20 SIZE 5X2 SPACE 2 NOTE TRANSFORMATION MATRIX SPACE MPRINT MATRIX IN ROW 1 COL 25 SIZE 2X2 MSUB MATRIX IN ROW 3 COL 25 SIZE 3X2 AND MATRIX 3,54 3X2 STORE IN 1,20 RESET NRMAX 3 AVERAGE COL 20 STORE IN 20 AVERAGE COL 21 STORE IN 21 SPACE 2 NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 20,21 SPACE NOTE ************************************************************************* OMNITAB TEST F5 INVERT MATRIX SOLVE LINEAR EQUATIONS (ORTHO) VERS 5.00 6/12/70 READ 1 2 3 4 5 6 7 8 9 10 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. -1. 0. 0. 0. 0. 0. 0. 0. 0. -1. 2. MINVERT MATRIX A IN ROW 1 COL 1 SIZE 10X10 STORE B IN ROW 1 COL 11 NEW PAGE FORMAT D (10F12.0) NOTE MATRIX TO BE INVERTED SPACE MPRINT D MATRIX A IN ROW 1 COL 1 SIZE 10X10 SPACE 2 NOTE INVERSE OF MATRIX SPACE FORMAT B (10F12.8) MPRINT B MATRIX B IN ROW 1 COL 11 SIZE 10X10 MMULT A IN ROW 1 COL 1 10X10 WITH B ROW 1 COL 11 10X10 STORE IN ROW 1 COL 21 1/SUM COL 21 STORE IN COL 21 2/ INCREMENT 1 BY 1 1 REPEAT 1 THRU 2 10 TIMES SPACE 2 NOTE ************************************************************************ SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 1.0 SPACE FORMAT C (5X,10F10.2) ABRIDGE C ROW 1 COLS 21***30 SPACE NOTE ************************************************************************* SOLVE A IN ROW 1 COL 1 SIZE 10X10 Y IN COL 12 STORE X IN COL 11 GENERATE Y FROM .5 IN STEPS OF .5 THRU 5. IN COL 12 NEW PAGE NOTE SOLVE A X = Y SPACE NOTE MATRIX A X Y SPACE FORMAT A(10F5.0,1PE15.7,0PF5.1) APRINT A STARTING ROW 1 COL 1 10X12 ARRAY M(AV) MULT MATRIX A IN ROW 1 COL 1 SIZE 10X10 WITH X IN COL 11 STORE IN COL 13 SUBTRACT COL 13 FROM COL 12 STORE IN 13 AVERAGE COL 13 STORE IN 13 SPACE 2 NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 10 SPACE NOTE ************************************************************************** RESET NRMAX TO 0 READ 2 3 4 5 6 7 27720. 13860. 9240. 6930. 5544. 4620. 13860. 9240. 6930. 5544. 4620. 3960. 9240. 6930. 5544. 4620. 3960. 3465. 6930. 5544. 4620. 3960. 3465. 3080. 5544. 4620. 3960. 3465. 3080. 2772. 4620. 3960. 3465. 3080. 2772. 2520. INVERT MATRIX A IN ROW 1 COL 2 SIZE 6X6 STORE IN MATRIX B IN ROW 7 COL 2 SET IN COL 9 THE FOLLOWING DATA 1. 2. 3. 4. 5. 6. NEW PAGE FIXED 1 NOTE MATRIX TO BE INVERTED SPACE MPRINT MATRIX A IN ROW 1 COL 2 SIZE 6X6 SPACE 2 NOTE THE ABOVE MATRIX IS 27720.0 TIMES THE HILBERT MATRIX OF ORDER 6 SPACE 2 NOTE INVERSE OF MATRIX SPACE FLEXIBLE MPRINT MATRIX B IN ROW 7 COL 2 SIZE 6X6 MMULT MATRIX A IN ROW 1 COL 2 6X6 BY MATRIX B ROW 7 COL 2 6X6 STORE IN 1,15 1/ SUM COL 15 STORE IN COL 15 2/ INCREMENT 1 BY 1 1 REPEAT 1 THRU 2 6 TIMES SPACE 2 NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 1.0 NOTE HOWEVER IN INVERTING THE MATRIX A, SOME SIGNIFICANCE IS LOST. NOTE IF DONE IN DOUBLE PRECISION OR ON MACHINES WHICH HAS MORE THAN 8 NOTE SIGNIFICANT DIGITS, BETTER RESULTS WILL BE OBTAINED. SPACE ABRIDGE ROW 1 COL 15 *** 20 SPACE NOTE ************************************************************************* SOLVE A IN ROW 1 COL 2 SIZE 6X6 Y INB COL 9 STORE X IN COL 8 NEW PAGE NOTE SPACE NOTE MATRIX A X Y SPACE FORMAT E(6F7.0,1PE15.7,0PF5.0) APRINT E STARTING ROW 1 COL 2 6X8 ARRAY M(AV) MULT MATRIX A IN ROW 1 COL 2 SIZE 6X6 WITH X IN COL 8 STORE IN COL 10 SUBTRACT COL 10 FROM COL 9 STORE IN 10 AVERAGE COL 10 STORE IN 10 SPACE 2 NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 NOTE HOWEVER IN INVERTING THE MATRIX A, SOME SIGNIFICANCE IS LOST. NOTE IF DONE IN DOUBLE PRECISION OR ON MACHINE WHICH HAS MORE THEN 8 NOTE SIGNIFICANT DIGITS, BETTER RESULTS WILL BE OBTAINED. SPACE ABRIDGE ROW 1 COL 10 SPACE NOTE ************************************************************************ OMNITAB TEST F6 MATRIX AND ARRAY COMMANDS (MKRON) VERSION 5.00 6/19/70 MDEFINE MATRIX A IN ROW 1 COLUMN 1 SIZE IS 2X2 VALUE=2.0 MDIAGONAAL OF B IN ROW 1 COLUMN 3 SIZE IS 2X2 VALUE=1.0 MADD MATRIX A IN R=1 C=1 SIZE IS 2X2 TO MATRIX B R=1 C=3 SIZE 2X2 STORE 1 3 AERASE MARTIX B IN R=2 C=4 SIZE IS 1X1 MKRONECKER OF A R=1 C=1 SIZE=2X2 BY MATRIX B R=1 C=3 SIZE=2X2 INTO MATRIX C 1 5 RESET NRMAX TO 4 TITLE1 THE FOLLOWING IS AN EXAMPPLE OF THE MKRONECKER COMMAND. MATR TITLE2IX A WAS DEFINED BY MDEFINE. MATRIX B WAS DEFINED BY THE TITLE3 MDIAGONAL, MADD, AND AERASE COMMANDS. MATRIX C WAS DEFINED TITLE4BY THE MKRONECKER COMMAND HEAD COL 1/ MATRIX A HEAD COL 2/ HEAD COL 3/ MATRIX B HEAD COL 4/ HEAD COL 5/ MATRIX C HEAD COL 7/ HEAD COL 8/ PRINT 1***8 AMULT MATRIX A R=1 C=1 SIZE=2X2 TIMES MATRIX B R=1 C=3 STORE IN ROW 1 COLUMN 9 MSCALAR MATRIX B R=1 C=3 SIZE=2X2 TIMES THE VALUE-2.0 STORE IN ROW 1 COLUMN 11 AADD MATRIX IN R=1 C=9 SIZE IS 2X2 TO MATRIX IN R=1 C=11 SIZE IS 2X2 INTO 1,13 ARAISE MATRIX N R=1 C=1 SIZE IS 2X2 TO POWER 2.0 STORE IN R=1 C=15 MSCALAR MATRIX IN R=1 C=1 SIZE IS 2X2 TIMES VALUE -2.0 STORE IN R=1 C=17 ADIVIDE MATRIX IN R=1 C=15 SIZE IS 2X2 BY MATRIX IN R=1 C=17 STORE IN R=1 C=19 AMULTIPLY B R=1 C=3 SIZE=2X2 TIMES THE VALUE 2.0 STORE IN ROW 1 COLUMN 21 ADEFINE MATRIX J IN R=1 COLUMN 23 SIZE=2X2 VALUE=1.0 ADIV MATRIX E R=1 C=11 SIZE 2X2 BY MATRIX J R=1 C=21 STORE IN R=1 C=25 SPACE 2 RESET NRMAX EQUAL TPP 2 NOTE ARRAYS SPACE NOTE A B D=A*B E=-2*B SPACE FORMAT C (8F10.2) NPRINT C COLUMNS 1 2 3 4 9 10 11 12 SPACE 2 NOTE ARRAYS SPACE NOTE F=D+E G=A**2 H=-2*A I=G/H SPACE FORMAT B (8F10.2) NPRINT B COLUMNS 13***20 ROWSUM COLUMNS 13***26 AND STORE IN COLUMN 27 SET THE FOLLOWING VALUES IN COLUMN 28 8.0 3.0 SUBTRACT COLUMN 27 FROM COLUMN 28 AND STORE IN COLUMN 28 AVERAGE COLUMN 28 AND STORE IN COLUMN 27 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COLUMN 27 SPACE NOTE ************************************************************************** OMNITAB TEST F7 DUPLICATE CLOSE UP COUNT (MISC2) VERSION 5.00 6/12/70 GENERATE NOS. START WITH 1.23456789 IN STEPS OF 1.0 UP TO 15. STORE IN COL 3 SET THE FOLLOWING NUMBERS IN COLUMN 4 20.0 14.0 -24.0 4. 5. 14. 12. 0.0 0.0 0.0 30. 5. 7. 8. -25.0 ADD THE CONSTANT 10. TO COLUMN 4 AND STORE RESULT IN COL 5 DUPLICATE 2 TIMES THE ARRAY IN ROW 2 OF COL 3 N=5 M=3 START STORING ROW 2 COL 6 TITLE1 RESULTS FROM DUPLICATING 2 TIMES THE VALUES IN A 5X3 ARRAY TITLE2BEGINNING IN ROW 2 COL 3. RESULTS ARE STORED BEGINNING IN TITLE3ROW 2 COL 6. COLS 3-5 WERE DEFINED BY GENERATE. SET AND ADD TITLE4COMMANDS. COLS 6-8 WERE DEFINED BY DUPLICATE COMMAND. PRINT COLUMNS 3 4 5 6 7 8 MSUB MATRIX A BEGIN IN ROW 2 COL 3 5X3 MINUS MATRIX B BEGIN IN 2 6 5X3 STORE 2 9 MSUBTRACT A BEGIN IN 7 6 5X3 MINUS MATRIX B BEGIN IN ROW 2 COL 3 5X3 PUT 2 12 SMPROPERTIES OF MATRIX BEGIN IN ROW 2 COL 9 5X6 STORE PROPERTIES IN COL 15 SPACE NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE CLOSE TO OR EQUAL TO ZERO SPACE ABRIDGE ROW 11 OF COLUMN 15 SPACE NOTE *************************************************************************** COUNT THE LENGTH OF COLUMN 4 AND VECTORIZE COUNT IN COLUMN 9 COUNT THE LENGTH OF COLUMN 6 AND VECTORIZE COUNT IN COLUMN 10 TITLE1 RESULTS FROM COUNT COMMAND. COL 9 CONTAINS NO. OF VALUES IN TITLE2 COL 4. COL 10 CONTAINS THE NO. OF VALUES OF COL 6. TITLE3 THE COUNT BEGINS AT THE FIRST NON-ZERO VALUE STARTING AT NR TITLE4MAX AND GOING TO ROW 1. PRINT COLUMNS 4 6 9 10 SPACE NOTE *************************************************************************** SPACE NOTE THE FOLLOWING TWO NUMBERS SHOULD BE 15 AND 11 SPACE ABRIDGE ROW 1 OF COLUMNS 9 AND 10 SPACE NOTE *************************************************************************** MOVE THE VECTOR START IN ROW 1 OF COL 4 WHICH IS 15 BY 1 STORE IN ROW 1 COL 11 MOVE THE VECTOR START IN ROW 1 OF COL 5 WHICH IS 15 BY 1 STORE IN ROW 1 COL 12 MOVE THE VECTOR START IN ROW 1 OF COL 9 WHICH IS 15 BY 1 STORE IN ROW 1 COL 13 CLOSE UP ROWS HAVING THE VALUE 14.0 IN COLUMN 4 CLOSE UP ROWS HAVING THE VALUE 30.0 IN COLUMNS 4 AND 5 CLOSE UP ROWS HAVING THE VALUE 15.0 IN COLUMN 9 NEW PAGE NOTE RESULTS FROM CLOSE UP COMMAND. THE VALUE 14.0 IS REMOVED FROM COL 4. NOTE THE VALUE 30.0 IS REMOVED FROM COLUMNS 4 AND 5, AND 15. FROM COLUMN 9, SPACE NOTE FORMAT C (27A2) NOTE READ C 1 23***50 NOTE OLD COL 4NEW COL 4OLD COL 5NEW COL 5OLD COL 9NEW COL 9 NOTE FORMAT D (4X,A2,6X,A2,7X,A2,5X,A2,7X,A2,6X,A2) RESET 1 NOTE NPRINT D 23***30 RESET 15 SPACE NPRINT COLUMNS 11 4 12 5 13 AND 9 SUM COLUMN 11 STORE IN COLUMN 14 SUM COLUMN 12 STORE IN COLUMN 15 SUM COLUMN 13 STORE IN COLUMN 16 SUM COLUMN 4 STORE IN COLUMN 17 SUM COLUMN 5 STORE IN COLUMN 18 SUM COLUMN 6 STORE IN COLUMN 19 SUBTRACT COLUMN 17 FROM COLUMN 14 STORE IN COLUMN 20 SUBTRACT COLUMN 18 FROM COLUMN 15 STORE IN COLUMN 21 SUBTRACT COLUMN 19 FROM COLUMN 16 STORE IN COLUMN 22 SPACE NOTE ************************************************************************** SPACE NOTE THE FOLLOWING VALUES SHOULD BE 58. 30. AND 225.0 SPACE ABRIDGE ROW 1 OF COLUMNS 20 21 AND 22 SPACE NOTE *************************************************************************** OMNITAB TEST F8 PHYSICAL CONSTANTS (PHYCON) VERSION 5.00 6/12/70 CGS USE PHYSICAL CONSTANTS IN CGS SYSTEM RESET NRMAX TO 1 ADD *PI* TO 0.0 STORE IN 3 ADD *E* TO 0.0 STORE IN 4 ADD *C* TO 0.0 STORE IN 5 ADD *Q* TO 0.0 STORE IN 6 ADD *N* TO 0.0 STORE IN 7 ADD *ME* TO 0.0 STORE IN 8 ADD *MP* TO 0.0 STORE IN 9 ADD *F* TO 0.0 STORE IN 10 ADD *H* TO 0.0 STORE IN 11 ADD *ALPHA* TO 0.0 STORE IN 12 ADD *QME* TO 0.0 STORE IN 13 ADD *RINF* TO 0.0 STORE IN 14 ADD *GAMMA* TO 0.0 STORE IN 15 ADD *MUB* TO 0.0 STORE IN 16 ADD *R* TO 0.0 STORE IN 17 ADD *K* TO 0.0 STORE IN 18 ADD *CONE* TO 0.0 STORE IN 19 ADD *CTWO* TO 0.0 STORE IN 20 ADD *SIGMA* TO 0.0 STORE IN 21 ADD *G* TO 0.0 STORE IN 22 MTRANSPOSE VECTORE IN 1,3 SIZE 1 X 20 STORE IN 1,1 SI USE PHYSICAL CONSTANTS IN MKSA SYSTEM ADD *PI* TO 0.0 STORE IN 3 ADD *E* TO 0.0 STORE IN 4 ADD *C* TO 0.0 STORE IN 5 ADD *Q* TO 0.0 STORE IN 6 ADD *N* TO 0.0 STORE IN 7 ADD *ME* TO 0.0 STORE IN 8 ADD *MP* TO 0.0 STORE IN 9 ADD *F* TO 0.0 STORE IN 10 ADD *H* TO 0.0 STORE IN 11 ADD *ALPHA* TO 0.0 STORE IN 12 ADD *QME* TO 0.0 STORE IN 13 ADD *RINF* TO 0.0 STORE IN 14 ADD *GAMMA* TO 0.0 STORE IN 15 ADD *MUB* TO 0.0 STORE IN 16 ADD *R* TO 0.0 STORE IN 17 ADD *K* TO 0.0 STORE IN 18 ADD *CONE* TO 0.0 STORE IN 19 ADD *CTWO* TO 0.0 STORE IN 20 ADD *SIGMA* TO 0.0 STORE IN 21 ADD *G* TO 0.0 STORE IN 22 MTRANSPOSE VECTORE IN 1,3 SIZE 1 X 20 STORE IN 1,2 FORMAT F (2A3,4X,16A3) READ F 20 CARDS INTO COL 3 *** 20 PI PI E BASE OF NATURAL LOGS C SPEED OF LIGHT IN VACUUM Q ELEMENTARY CHARGE N AVOGADRO CONSTANT ME ELECTRON REST MASS MP PROTON REST MASS F FARADAY CONSTANT H PLANCK CONSTANT ALPHA FIND STRUCTURE CONSTANT QME CHARGE TO MASS RATIO FOR ELECTRON RINF RYDBERG CONSTANT GAMMA GYROMAGNETIC RATIO OF PROTON (CORRECTED FOR H2O) MUB BOHR MAGNETON R GAS CONSTANT K BOLTZMANN CONSTANT CONE FIRST RADIATION CONSTANT CTWO SECOND RADIATION CONSTANT SIGMA STEPHAN-BOLTZMANN CONSTANT G GRAVITATIONAL CONSTANT FORMAT B (5X,2A3,2X,1P2E15.6,5X,16A3) TITLE1 CENTIMETER-GRAM-SEC SYSTEME-INTERNATIONALE TITLE2 PHYSICAL CONSTANTS TITLE3 CGS SI PRINT B COLS 3,4 1,2 5***20 OMNITAB TEST F9 M(XAX') AND M(X'AX) (MXTX) VERSION 5.00 6/19/70 DIM NUMBER OF ROWS=3 NUMBER OF COLUMNS=26 READ MATRIX A INTO COLUMNS 13 14 MATRIX X INTO 15***17 X TRANSPOSE IN 18***20 1.0 3.0 -2.0 0.0 -2.0 -2.0 -1.0 3.0 2.0 -4.0 -1.0 5.0 0.0 0.0 5.0 1.0 0.0 0.0 3.0 1.0 0.0 -2.0 0.0 0.0 M(XAX') A MATRIX IN 1,13 SIZE=2X2 X MATRIX IN 1,15 SIZE=3X2 STORE IN R=1 C=1 M(X'AX) A MATRIX IN 1,13 SIZE=2X2 X MATRIX IN 1,15 SIZE=2X3 STORE IN R=1 C=4 MMULT MATRIX X IN R=1 C=15 SIZE=3X2 BY MATRIX A R=1 C=13 2X2 STORE IN R=1 C=21 MMULT MATRIX XA IN R=1 C=21 SIZE=3X2 BY MATRIX X' R=1 C=18 2X3 STORE IN R=1 C=21 MMULT TRANSPOSE OF X IN R=1 C=18 3X2 TIMES A IN R=1 C=13 2X2 STORE IN R=1 C=24 MMULT MATRIX X'A IN R=1 C=24 SIZE=3X2 TIMES X IN R=1 C=15 SIZE=2X3 PUT R=1 C=24 MSCALAR THE ARRAY IN R=1 C=21 SIZE=3X6 BY -1.0 PUT ARRAY IN R=1 C=7 TITLE1 THE FOLLOWING IS AN EXAMPLE OF M(XAX') AND M(X'AX) NEW PAGE SPACE NOTE MATRIX A MATRIX X MATRIX X' SPACE FORMAT D (8F8.2) NPRINT D COLUMNS 13***20 SPACE NOTE MATRIX B=XAX' MATRIX C=X'AX NOTE (X IS 3 BY 2, A IS 2 BY 2) (X IS 2 BY 3, A IS 2 BY 2) SPACE 2 NPRINT COLUMNS 1***6 DIMENSION NROW=3 NCOL=12 ROWSUM THE ENTIRE WORKSHEET AND PUT IN COLUMN 1 AVERAGE COLUMN 1 AND STORE IN COLUMN 1 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 1 SPACE NOTE *************************************************************************** OMNITAB TEST F10 CTOF FTOC ATOMIC (THERMO) GENERATE FROM -10. IN STEPS OF 5. THRU 50. AND STEPS OF 10. THRU 100. IN COL 1 CTOF OF COL 1 STORE IN COLUMN 11 CONVERT TO FAHRENHEIT FTOC OF COL 11 STORE IN COLUMN 12 CONVERT TO CENTIGRADE SUBTRACT COL 1 FROM 12 STORE IN COLUMN 13 MULTIPLY COL 1 BY 1.8 MULT BY 1.0 ADD 32. STORE IN COL 14 DIV 5. BY 9. STORE IN COLUMN 8 SUBTRACT 32.0 FROM COL 11 MULT BY COL 8 ADD 0.0 STORE IN COL 24 SUBTRACT 1 FROM 24 STORE IN COLUMN 25 TITLE1 CENTIGRADE FAHRENHEIT FAHR TO CENT CONVERS TITLE2ION FORMULAS PRINT 1,11,12,14,24 SUBTRACT COL 11 FROM COL 14 STORE IN COL 15 AVERAGE COL 15 STORE IN COL 15 AVERAGE COL 13 STORE IN COL 13 AVERAGE COL 25 STORE IN COL 25 SPACE 2 NOTE ************************************************************************* SPACE NOTE THE FOLLOWING VALUES MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 COL 13 15 25 SPACE NOTE ************************************************************************* ERASE ATOMIC MASSES STORE RESULTS IN COL 61 GENERATE FROM 1. IN STEPS OF 1. THRU *NRMAX* COL 2 SEPARATE COL 61 EVERY 5TH ROW START WITH ROW 5 STORE IN 3 SEPARATE COL 2 EVERY 5TH ROW START WITH ROW 5 STORE IN 4 RESET NRMAX TO 20 FORMAT E (3A4) READ E 20 COLS 5,6,7 BORON NEON PHOSPHORUS CALCIUM MAGANESE ZINC BROMINE ZIRCONIUM RHODIUM TIN CESIUM NEODYMIUM TEBIUM YTTERBIUM RHENIUM MERCURY ASTATINE THORIUM AMERICIUM FERMIUM TITLE1 TITLE2 NEW PAGE NOTE ELEM. NO ATOMIC WT: ELEMENT SPACE FORMAT D (F5.0,3X,F12.5,5X,3A4) NPRINT D COLS 4 3 5 6 7 OMNITAB TEST F11 M(AD), M(DA) AND M(V'A) (MDAMAD) VERSION 5.00 6/12/70 READ THE FOLLOWING DATA INTO COLUMNS 1***7 1.0 6.0 3.0 3.0 0.0 0.0 3.0 2.0 3.0 2.0 0.0 -2.0 0.0 -2.0 3.0 -1.0 1.0 0.0 0.0 1.0 1.0 M(AD) MATRIX A IN R=1 C=1 SIZE=3X3 TIMES MATRIX COL 7 IN DIAGONAL PUT IN R=1 C=8 M(DA) MATRIX A IN R=1 C=1 SIZE=3X3 PREMULT BY MAT WITH DIAGONAL C=7 PUT R=1 C=11 TITLE1 THE FOLLOWING IS AN EXAMPLE OF M(AD) M(DA) AND M(V'A) NEW PAGE SPACE NOTE MATRIX A FIXED 2 MPRINT MATRIX IN R=1 C=1 SIZE 3X3 SPACE 2 NOTE MATRIX B DIAGONAL OF MATRIX B MPRINT MATRIX IN R=1 C=4 SIZE=3X4 SPACE 2 NOTE MATRIX C=MATRIX A TIMES THE DIAGNONAL OF MATRIX B. COMMAND IS M(AD). MPRINT MATRIX C IN R=1 C=8 SIZE=3X3 SPACE 2 NOTE MATRIX D=DIAGONAL OF MATRIX B TIMES MATRIX A. COMMAND IS M(DA). MPRINT MATRIX D IN R=1 C=11 SIZE=3X3 MMULT MATRIX A IN R=1 C=1 SIZE=3X3 TIMES MATRIX IN R=1 C=4 SIZE=3X3 IN R=1 C=14 MMULTIPLY B IN R=1 C=4 SIZE=3X3 BY MATRIX IN R=1 C=1 SIZE=3X3 PUT IN R=1 C=17 MSUB MATRIX IN R=1 C=8 SIZE=3X3 FROM MATRIX IN R=1 C=14 SIZE=3X3 INTO R=1 C=20 MSUB MATRIX IN R=1 C=11 SIZE=3X3 FORM MATRIX IN R=1 C=17 SIZE=3X3 INTO R=1 C=23 ROWSUM COLUMNS 20***25 AND STORE IN COLUMNS 26 AVERAGE COLUMN 26 AND STORE IN COLUMN 26 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 26 SPACE NOTE *************************************************************************** SET THE FOLLOWING VALUES IN COLUMN 27 1.0 -1.0 0.0 M(V'A) MATRIX IN R=1 C=1 SIZE=3X3 VECTOR IN COLUMN 27 PUT IN R=1 C=28 SPACE NOTE VECTOR V MATRIX A VECTOR V TIMES MATRIX A FORMAT C (F8.2,6F8.2) NPRINT C COLUMNS 27 1 2 3 28 29 30 SPACE ROWSUM COLUMNS 28 29 AND 30 AND STORE IN COLUMN 31 SUB 3.0 FORM COLUMN 31 AND STORE IN COLUMN 32 SPACE 2 NOTE *************************************************************************** SPACE NOTE THE FOLLOWING VALUE MUST BE EQUAL TO OR NEAR 0.0 SPACE ABRIDGE ROW 1 OF COLUMN 32 SPACE NOTE *************************************************************************** STOP ~eor ~eoi 7 6 5 4 3 2 1 0 CON 2221201716151413 A-G CON 3231302726252423 H-O CON 4241403736353433 P-W CON 0504030201454443 X-Z,0-4 CON 0504031211100706 56789 CON 5760545346525051 +-*/()$= CON 0000000061475556 BLANK ,.