Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - 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