FUNCTION BCDW(INTGER) C RETURNS INTEGER AS RIGHT-JUSTIFIED EBCDIC 4 CHARACTER ACSII WORD C FIFTH CHARACTER BLANK DIMENSION ITEN(4), ICNVRT(5) DATA ITEN/256,32768,4194304,536870912/ DATA ICNVRT/' 0', ' 0', ' 00', ' 000', '0000'/ EQUIVALENCE (KDUM, DUM) KDUM = 0 INT = IABS(INTGER) IF (9999-INT) 10, 20, 20 10 INT = 9999 20 DO 40 J=1,4 IF (INT) 50, 50, 30 30 KDUM = KDUM + MOD(INT,10)*ITEN(J) 40 INT = INT/10 J = 5 50 KDUM = KDUM + ICNVRT(J) BCDW = DUM RETURN END SUBROUTINE CMSREQ (LCM, LNO, LTG, KNO, KLNO) CCMSREQ SUBROUTINE TO PROCESS CMS REQUESTS 0020 C ************************* COMMON COMMON ************************** 0030 COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2) DIMENSION ZMAP(2000) NBOD0110 DIMENSION REMARK(500) DIMENSION OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2), NBOD0120 1 LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100), NBOD0130 2 WGT(100) NBOD0140 DIMENSION PARA(1000),NPARA(1000),SNAME(1000),NAME(1000) DIMENSION HEAD(11), NBRNCH(10) NBOD0170 DIMENSION HTABLE(7,100) NBOD0180 DIMENSION NC(48), KTABLE(7,100) 0090 EQUIVALENCE (MAP,ZMAP) NBOD0340 EQUIVALENCE (REMARK,MAP(1001)) EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)), NBOD0350 1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)), NBOD0360 2 (WGT,MAP(1631)) NBOD0370 EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)), NBOD0380 1 (NTAPE,MAP(1988)), (EINC,MAP(1998)), NBOD0390 2 (PINC,MAP(1999)), (BINC,MAP(2000)) NBOD0400 EQUIVALENCE (PARA,NPARA,PARS),(SNAME,NAME,MAP(1)) EQUIVALENCE (PI, MISC), (RADIAN, MISC(2)), (NIT, MISC(3)), NBOD0490 1 (NOT, MISC(4)), (HEAD, MISC(5)), (NBRNCH, MISC(16)), NBOD0500 2 (NPAGE, MISC(26)), (NORD, MISC(27)) NBOD0510 EQUIVALENCE (HTABLE,MAP) EQUIVALENCE (NC,MAP(1731)), (KTABLE,MAP) 0290 C ************************* END OF C, D, E STATEMENTS ************** 0270 C 0300 450 IF (LCM) 475, 475, 455 0310 455 IF ( LCM- 20) 460, 460, 475 0320 460 KTABLE(1,KNO) = KTABLE(1,KNO) + 10 KLIST(KLNO) = KLIST(KLNO) + 1 0360 IF ( LCM - 1 ) 475, 461, 463 0370 C KLIST ( LNO ) = +1 INDICATES VERTEX A 461 KLIST ( LNO ) = +1 GO TO 464 0400 463 IV = ITABLE ( 3,LCM) 0410 IP = ITABLE (4,LCM) 0420 KLIST ( LNO) = ITABLE ( 2, IV ) + IP 0430 464 LNO = LNO + 1 0440 IF ( LTG ) 475, 475, 465 0450 465 KTABLE (1, KNO ) = KTABLE ( 1, KNO) + 10 0460 475 RETURN 0470 END 0480 SUBROUTINE CONDIT (LNO, KCNO, NERR, LENGTH) C SUBROUTINE TO PROCESS CONDITIONAL REQUESTS C CONDIT*2 -- LONGER CALLING SEQUENCE FOR EXTENDED CARD PARAMETERS CDT30020 C ************************* COMMON COMMON **************************CDT30040 COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2) CDT30050 COMMON /LIMIT/LIMMNO,LIMLNO,LIMKNO,LIMEX DIMENSION HLIST(500) CDT30060 DIMENSION NC(48) CDT30070 DIMENSION OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2), CDT30080 1 LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100), CDT30090 2 WGT(100) CDT30100 EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)), CDT30220 1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)), CDT30230 2 (WGT,MAP(1631)) CDT30240 EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)), CDT30250 1 (NTAPE,MAP(1988)), (EINC,MAP(1998)), CDT30260 2 (PINC,MAP(1999)), (BINC,MAP(2000)) CDT30270 EQUIVALENCE (NC,MAP(1731)) CDT30290 EQUIVALENCE (HLIST,KLIST) CDT30300 C ************************* END OF C, D, E STATEMENTS **************CDT30280 C CDT30320 DO 10 K = 1,LENGTH CDT30330 IF (NC(K) - 27) 10, 20, 10 CDT30340 10 CONTINUE CDT30350 KCNO = 0 CDT30360 GO TO 500 CDT30370 C CDT30380 20 NSL = K CDT30390 NNC = K + 1 CDT30400 KCNO = LNO CDT30410 C CDT30420 DO 100 N = NNC,LENGTH,2 CDT30430 NA = NC(N) CDT30440 NB = NC(N + 1) CDT30450 IF (N - NNC) 25, 25, 30 CDT30460 C READ OUT FUNCTION NUMBER CDT30470 25 NFN = 10*NA + NB CDT30480 IF (NFN - 10) 490, 27, 27 CDT30490 27 KLIST(LNO) = NFN CDT30500 LNONE = LNO + 1 CDT30510 LNO = LNO + 2 CDT30520 GO TO 100 CDT30530 C CDT30540 30 IF (NA) 400, 400, 32 CDT30550 32 IF (NA - 28) 40, 34, 40 CDT30560 C THE COMMA CDT30570 34 KCNO = -(1000*KCNO + KLIST(LNONE) + 1) CALL ECP(N, LENGTH, LNONE, LNO) 01/03/68 368 GO TO 400 CDT31250 C CDT31260 40 NENT = NOTABL (NA, NB) CDT31270 IF (NENT) 490, 490, 45 CDT31280 45 KLIST(LNO) = NENT CDT31290 KLIST(LNONE) = KLIST(LNONE) + 1 CDT31300 LNO = LNO + 1 CDT31310 100 CONTINUE CDT31320 C CDT31330 400 DO 410 N = NSL,48 CDT31340 410 NC(N) = 0 CDT31350 LENGTH = NSL - 1 CDT31360 GO TO 500 CDT31370 490 NERR = 19 CDT31380 500 RETURN CDT31390 END CDT31400 SUBROUTINE CROSS (V1,V2,V3) DIMENSION V1(3), V2(3), V3(3), VINT(3) DO 5 I=1,3 I1=MOD(I,3) + 1 I2=MOD(I1,3) + 1 5 VINT(I) = V1(I1)*V2(I2) - V1(I2)*V2(I1) DO 10 I=1,3 10 V3(I) = VINT(I) RETURN END FUNCTION DOT(V1,V2) DIMENSION V1(3), V2(3) PROD = 0. DO 5 I=1,3 5 PROD = PROD + V1(I)*V2(I) DOT = PROD RETURN END FUNCTION DELSQ(KB, KE) C DEL**2 IN KLIST BETWEEN KB AND KE * SEE FUNC11 0020 C DEL**2= (EINC-E(K))**2-(PINC-P(K))**2 0030 C WHERE E(K) IS SUM OVER ALL E(K) IN LIST 0040 C AND P(K) ARE VECTORS 0050 C ****************** COMMON COMMON *************************** 0060 COMMON MAP(2000),PARS(1000),MISC(27),KLIST(500),MTABLE(2) COMMON /LIMIT/LIMMNO,LIMLNO,LIMKNO,LIMEX DIMENSION ZMAP(2000) DIMENSION REMARK(500) DIMENSION OTABLE(7,50), JTABLE(7,50), RTABLE(9,20,2), 1 LTABLE(9,20,2), ITABLE(6,20), VAL(100), IVAL(100), 2 WGT(100) DIMENSION PARA(1000),NPARA(1000),SNAME(1000),NAME(1000) DIMENSION DIRINC(3) DIMENSION HEAD(11), NBRNCH(10) DIMENSION HTABLE(7,100) EQUIVALENCE (MAP,ZMAP) EQUIVALENCE (REMARK,MAP(1001)) EQUIVALENCE (OTABLE,JTABLE,MAP(701)), (RTABLE,LTABLE,MAP(1051)), 1 (ITABLE,MAP(1411)), (VAL,IVAL,MAP(1531)), 2 (WGT,MAP(1631)) EQUIVALENCE (NCFLAG,MAP(1869)), (WEIGHT,MAP(1978)), 1 (NTAPE,MAP(1988)), (EINC,MAP(1998)), 2 (PINC,MAP(1999)), (BINC,MAP(2000)) EQUIVALENCE (PARA,NPARA,PARS),(SNAME,NAME,MAP(1)) EQUIVALENCE (PI, MISC), (RADIAN, MISC(2)), (NIT, MISC(3)), 1 (NOT, MISC(4)), (HEAD, MISC(5)), (NBRNCH, MISC(16)), 2 (NPAGE, MISC(26)), (NORD, MISC(27)) EQUIVALENCE (LTAPE,NBRNCH(9)), (LINK,NBRNCH(10)), (HTABLE,MAP) EQUIVALENCE (DIRINC,PARA(95)) C *************** END COMMON COMMON ************************* 0280 DIMENSION SUM(4) C 0350 DO 20 J=1,4 0370 20 SUM(J)=0.0 0380 DO 30 K=KB,KE 0390 L = KLIST(K) 0400 DO 25 J=1,3 0410 25 SUM(J)=SUM(J)+OTABLE(J,L)*OTABLE(4,L) 0420 30 SUM(4)=SUM(4)+OTABLE(5,L) 0430 SUM(4)=EINC-SUM(4) 0440 DO 40 J=1,3 0450 40 SUM(J)=PINC*DIRINC(J)-SUM(J) 0460 V =SUM(4)**2 0470 DO 50 J=1,3 0480 50 V = V -SUM(J)**2 0490 DELSQ = V 0500 RETURN 0510 END 0520 SUBROUTINE DVCHK(I) C DUMMY ROUTINE I = 2 RETURN END SUBROUTINE ECP(N, LENGTH, KLNO, LNO) C EXTRA CARD PARAMETER DECODING FACILITY COMMON MAP(2000), PARS(1000), MISC(27), KLIST(500) DIMENSION NC(48), HLIST(500) EQUIVALENCE (NC,MAP(1731)), (EPARA,IPARA), (HLIST,KLIST) C IKOUNT = N + 1 IF (IKOUNT - LENGTH) 5, 5, 200 5 DO 10 K = IKOUNT, LENGTH 10 NC(K) = IABS(NC(K)) 20 IPARA = 0 NSIGN = 1 C C NEGATIVE TEST IF (NC(IKOUNT) - 30) 50, 40, 50 40 NSIGN = -1 IKOUNT = IKOUNT + 1 IF (IKOUNT - LENGTH) 50, 50, 200 C C FIXED POINT LOOP 50 DO 60 K = IKOUNT, LENGTH IF (NC(K) - 9) 60, 60, 55 55 IF (NC(K) - 29) 65, 70, 65 60 IPARA = IPARA*10 + NC(K) 65 KLIST(LNO) = IPARA*NSIGN GO TO 100 C C FLOATING POINT LOOP 70 EPARA = IPARA IKOUNT = K + 1 IF (IKOUNT - LENGTH) 75, 75, 85 75 DO 80 K = IKOUNT, LENGTH IF (NC(K) - 9) 80, 80, 85 80 EPARA = EPARA + FLOAT(NC(K))/10.0**(K - IKOUNT + 1) 85 HLIST(LNO) = EPARA*NSIGN C C END OF LOOP 100 IKOUNT = K + 1 LNO = LNO + 1 KLIST(KLNO) = KLIST(KLNO) + 1 IF (IKOUNT - LENGTH) 120, 120, 200 120 IF (NC(K) - 28) 200, 20, 200 200 RETURN END SUBROUTINE GETMS (MSNO, VAL) C MSNO IS MASS NUMBER AND VAL IS SELECTED MASS VALUE 0090 COMMON MAP(2000), PARS(1000) DIMENSION TBLMS(30), RBANK(10) EQUIVALENCE (TBLMS,MAP(2001)), (RBANK,MAP(1842)) 0080 IF (MSNO - 20) 10, 20, 20 0100 10 VAL = TBLMS(MSNO) 0110 GO TO 100 0120 20 K = MSNO - 19 0130 VAL = RBANK(K) 0140 100 RETURN 0150 END 0160 SUBROUTINE HISTO (X, N, NHST, M, A, B ) C SUBROUTINE FOR MAKING HISTOGRAM OF ARRAY X(N) INTO NHST(M+2) C DIMENSION X(2),NHST(2) DO 120 J = 1,N IF (X(J) - B) 104, 102, 102 11/14/64 102 NHST(M+1) = NHST(M+1) + 1 11/14/64 GO TO 120 11/14/64 104 IF (X(J) - A) 106, 108, 108 11/14/64 106 NHST(M+2) = NHST(M+2) + 1 11/14/64 GO TO 120 11/14/64 108 EM = M 11/14/64 L = (((X(J)-A) * EM) /(B-A)) + 1.00001 11/14/64 NHST(L) = NHST(L) + 1 11/14/64 120 CONTINUE 11/14/64 RETURN 11/14/64 END 11/14/64 SUBROUTINE HISTOI ( XIN ,NUM,NHST,GHST,INT,VMIN,VMAX,SIGMA,DUM) DIMENSION NHST(2), GHST(2) , XIN(2), SIGMA(2) DEC 26 DO 100 N = 1, NUM JAN 2 VALUE = XIN(N) JAN 2 IF (VALUE - VMAX) 10, 20, 20 DEC 26 10 IF (VMIN - VALUE) 40, 40, 30 DEC 26 20 NHST (INT + 1) = NHST (INT + 1) + 1 DEC 26 GHST (INT + 1) = GHST (INT + 1) + 1.0 DEC 26 GO TO 100 DEC 26 30 NHST (INT + 2) = NHST (INT + 2) + 1 DEC 26 GHST (INT + 2) = GHST (INT + 2) + 1.0 DEC 26 GO TO 100 DEC 26 40 CONTINUE DEC 26 FLINT = INT DEC 27 DX = (VMAX - VMIN) / FLINT DEC 27 C HISTOGRAM VALUE DEC 26 IBOX = (VALUE - VMIN) / DX DEC 26 IBOX = IBOX + 1 DEC 26 NHST (IBOX) = NHST (IBOX) + 1 DEC 26 SIG = SIGMA(N) DEC 26 IF (SIG - 0.1 * DX) 42, 45, 45 JAN 2 42 SIG = 0.1 * DX DEC 26 45 CONTINUE DEC 26 H = 0.7071066 / SIG DEC 26 H2 = H * H DEC 26 C CALCULATE NORMALIZATION FACTOR DEC 26 SUM = 0.0 DEC 28 X = VMIN - 0.5*DX DEC 26 DO 50 K = 1, INT DEC 26 X = X + DX DEC 26 SUM = SUM + EXP(-H2 * (X - VALUE) **2) DEC 28 50 CONTINUE DEC 26 CORR = 1.0 / SUM DEC 28 C STORE VALUEIN IDEOGRAM DEC 26 X = VMIN - 0.5*DX DEC 26 DO 70 K = 1, INT DEC 26 X = X + DX GHST(K) = GHST(K) + CORR * EXP (-H2 * (X - VALUE)**2) 70 CONTINUE DEC 26 100 CONTINUE DEC 26 DX = DUM RETURN DEC 26 END DEC 26 SUBROUTINE HISTOW(X,N,NHST,HST,M,A,B,P,ERROR) C SUBROUTINE FOR MAKING HISTOGRAM OF ARRAY X(N) INTO NHST(M+2) C DIMENSION X(2),NHST(2),HST(2),P(2),ERROR(2) DO 130 J=1,N IF (X(J) - B) 104, 102, 102 11/14/64 102 LL=M+1 GO TO 120 11/14/64 104 IF (X(J) - A) 106, 108, 108 11/14/64 106 LL=M+2 GO TO 120 11/14/64 108 EM = M 11/14/64 L = (((X(J)-A) * EM) /(B-A)) + 1.00001 11/14/64 LL=L 120 NHST(LL)=NHST(LL) + 1 HST(LL)=HST(LL) + P(J) ERROR(LL) = ERROR(LL) + P(J)**2 130 CONTINUE RETURN 11/14/64 END 11/14/64