Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0009/nvmis1.for
There is 1 other file named nvmis1.for in the archive. Click here to see a list.
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