Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0009/nvset.for
There is 1 other file named nvset.for in the archive. Click here to see a list.
      SUBROUTINE SETUP ( NERR )
CSETUP*2  SUBROUTINE TO READ IN AN EVENT -- EXTENDED CARD PARAMETER DECK
C     ************************* COMMON COMMON **************************
      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    HEAD(11), NBRNCH(10)
      DIMENSION    HLIST(500), TITLE(48), KTABLE(7,100), NC(48),
     1             HTABLE(7,100), TBLMS(30)
      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  (HLIST,KLIST), (HTABLE,KTABLE,MAP), (NC,MAP(1731)),
     1             (TITLE,MAP(1870)), (TBLMS,PARS)
      EQUIVALENCE (NTOT,PARS(99)),
     1        (GMINP,MAP(1975)), (GMAXP,MAP(1976)), (GSCALE,MAP(1977)),
     2        (IPS,MAP(1973)), (LISTW,MAP(1979)), (LISTG,MAP(1989))
      EQUIVALENCE (MTOT,MAP(1987)), (IRNDM,MAP(1986))                   8/17/68
      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(NOUTH,MAP(1980)),(NOUTM,MAP(1981)),(NPT,MAP(1982))
C     ****************** END OF STANDARD CDE STATEMENTS ****************
      DIMENSION VART(48)
      DATA ITERAT /0/, BLANK /' '/
C                                                                           0370
      IF (ITERAT) 100, 100, 101
C     READ NEW CARD
 100  READ  (NIT,9150)CODE, MCODE, CM,TG, HBEG, HEND, VART
 9150 FORMAT (A1,I3,2A1,2F9.3,48A1)
      CALL LTON ( 1, CODE, L, LDUM)
      CALL LTON (1, CM, LCM, LDUM)
      CALL LTON (1, TG, LTG, LDUM)
C     PROCESS PREVIOSLY READ CARD
 101  IF (L-30) 105, 102, 105
C     GET NEW PARAMETERS                                                    0970
  102 NERR=100                                                              0980
      ITERAT = 0
C     BACKSPACE NIT
      GO TO 1000                                                            1000
 105  IF (L.EQ.5 .AND. ((MCODE+LTG).GT.0 .OR. (HBEG+HEND).GT.0.) .AND.
     1    ITERAT.NE.0)   GO TO 25
      IF ( L-8)   100, 110, 100                                             1030
C
C     ITERATE * START BY ZEROING RDECAY                                     0450
 25   CALL RDECAY ( 0, GARB, GARB, GARB, GARB, GARB, GARB, GARB )
      IRNDM = 0                                                         8/17/68
      ITERAT = -1
C        ZERO MTABLE IF LCM IS ZERO
      IF (LCM) 27, 27, 28
   27 CALL OHIST(-1)                                                        0540
C        RESET PHASE SPACE TYPE IF LTG IS NON-ZERO
 28   IF (LTG-1)   30, 29, 2802
 2802 LTG = 2
 29   IF (LTG-IPS)   2906, 30, 2902
C        REASSIGN HISTOGRAM SPACE IF IPS CHANGES FROM 1 TO 2                0590
 2902 IF (SPACE(KTABLE(1,1),LIMMNO))   2903, 2904, 2903
 2903 ITERAT = 0
      NERR=31
      GO TO 1000
 2904 CALL OHIST (-1)                                                       0610
 2906 IPS = LTG
   30 IF (HBEG) 35,35,33                                                    0630
   33 PINC=HBEG                                                             0640
      EINC=SQRT(BINC**2+PINC**2)                                            0650
 35   IF (HEND)  38,38,36
 36   GMAXP=PINC                                                            0670
      GMINP=HEND
      GSCALE=ALOG(GMAXP/GMINP)                                              0680
   38 IF (MCODE) 41,41,40
 40   MTOT = MCODE * 100                                                    0700
 41   IF (VART(1).EQ.BLANK) GO TO 43
      DO 42 K=1,48
 42   TITLE(K)=VART(K)
 43   CALL SCALW                                                            0710
      GO TO 1000                                                            0720
C
C        ORIGINAL OR NEW EVENT SPECIFICATION                                0730
 110  CALL OHIST(-1)
      DO 90   K = 1, 2000                                                   0820
 90   MAP (K) = 0                                                           0830
      DO 95   K = 1, LIMLNO                                                 0840
 95   KLIST(K) = 0                                                          0850
      CALL RDECAY ( 0, GARB, GARB, GARB, GARB, GARB, GARB, GARB )
      MTOT = NTOT                                                           0810
      NERR = 0                                                              0880
      KNO = 1                                                               0890
      LNO = 1                                                               0900
      MNO = 1                                                               0910
      NXF = 0                                                               0930
      NFLG = 0
      ITERAT = 0
      PINC = HBEG
      GMINP = HEND
      DO 96 K=1,48
 96   TITLE(K) = VART(K)
C        SET P. S. TYPE MARKER - IPS                                        1060
      IPS=LTG
      IF (IPS - 1)   111, 111, 112                                          1080
 111  IPS = 1                                                               1090
      GO TO 120                                                             1100
 112  IPS = 2                                                               1110
 120  BINC = TBLMS(MCODE)                                                   1120
      EINC = SQRT( BINC**2 + PINC**2 )                                      1130
      GMAXP = PINC                                                          1160
      IF (GMINP)  125, 125, 121                                             1170
C     BREMMSTRAHLUNG SPECTRUM = GMINP * EXPF ( ABSF(RAN * GSCALE))          1180
 121  GSCALE= ALOG( GMAXP/ GMINP)                                           1190
C        BEGINNING OF CARD READ-IN LOOP                                     1200
C     CHECK IF TABLES ARE EXCEEDED                                          1210
 125  IF (MNO-LIMMNO)   126, 126, 1281                                      1220
 126  IF (LNO-LIMLNO)   127, 127, 1282                                      1230
 127  IF   (KNO-LIMKNO)  129, 129, 1283                                     1240
 1281 NERR = 31                                                             1250
      GO TO 1000                                                            1260
 1282 NERR = 32                                                             1270
      GO TO 1000                                                            1280
 1283 NERR = 33                                                             1290
      GO TO 1000                                                            1300
C        OKAY, PROCEED                                                      1310
 129  CONTINUE                                                              1320
      KCODE = 0                                                             1340
      READ  (NIT,9150)CODE, MCODE,CM,TG, HBEG, HEND, VART
      CALL LTON ( 1, CODE, L, LDUM)
      IF ( L )      500, 500, 130                                           1370
 130  CALL LTON ( 48, VART(1), NC(1), LENGTH)
 131  CONTINUE                                                              1390
C        MCODE NEGATIVE REQUESTS WEIGHTED HISTOGRAM                         1400
      MNOINC = IABS(MCODE) + 2                                              1410
      GO TO (132, 133), IPS                                                 1420
 132  IF (MCODE)   133, 135, 135                                            1430
 133  MNOINC = 3 * MNOINC                                                   1440
 135  CALL LTON (1, CM, LCM, LDUM)
      CALL LTON (1, TG, LTG, LDUM)
C        BRANCH ON CARD CODE                                                1470
 140  GO TO (300, 302, 304, 280, 490, 306, 383, 480, 500, 308, 310,         1490
     1   500, 312, 180, 600, 314, 500, 316, 290, 200, 318, 220, 380,        150
     2   510, 520, 500, 500, 500, 500, 480), L
C     N CARD                                                                1520
 180  MTOT = MCODE * 100                                                    1530
C     REINITIALIZE RANDOM IF NECESSARY                                  8/17/68
      IF (LENGTH-10) 182, 182, 188                                      8/17/68
 182  DO 184 K=1,LENGTH                                                 8/17/68
      IF (NC(K).LT.0 .OR. NC(K).GT.9) GO TO 188                         8/17/68
 184  IRNDM = 10*IRNDM + NC(K)                                          8/17/68
      IF (IRNDM) 188, 125, 186                                          8/17/68
 186  CALL ITRNDM(IRNDM,LDUM)                                           8/17/68
      GO TO 125                                                         8/17/68
 188  NERR = 11                                                         8/17/68
      GO TO 1000                                                        8/17/68
C     T CARD                                                                1550
 200  IF (NFLG) 2001, 2002, 2001                                            1560
 2001  NERR = 9                                                             1570
      GO TO 1000                                                            1580
 2002      DO 219 K = 1, 48, 2                                              1590
      KVA = NC( K )                                                         1600
      IF ( KVA-20)    201, 201, 203                                         1610
 201  IF ( KVA )    203, 125, 202                                           1620
 202  KVB = NC(K+1)                                                         1630
      IF ( KVB - KVA)     203, 203, 205                                     1640
 203  NERR = 1                                                              1650
      GO TO 1000                                                            1660
 205  ITABLE (1, KVA) = ITABLE ( 1, KVA ) + 1                               1670
      II = ITABLE ( 1, KVA )                                                1680
      IF ( II-8 )     210, 210, 207                                         1690
 207  NERR = 2                                                              1700
      GO TO 1000                                                            1710
 210  LTABLE ( II, KVA, 1 ) =         MCODE                                 1720
      LTABLE ( II, KVA, 2 ) = KVB                                           1730
      IF ( KVB )    211, 219, 213                                           1740
 211  NERR = 4                                                              1750
      GO TO 1000                                                            1760
 213  IF ( KVB- 20 )    214, 214, 219                                       1770
 214  IF ( ITABLE ( 3, KVB) )       211, 216, 215                           1780
 215  NERR = 5                                                              1790
      GO TO 1000                                                            1800
 216  ITABLE ( 3, KVB ) = KVA                                               1810
      II = ITABLE ( 1, KVA )                                                1820
      ITABLE ( 4, KVB )  = II                                               1830
 219  CONTINUE                                                              1840
      GO TO 125                                                             1850
C     V CARD                                                                1860
 220  DO 230     K = 1, 48                                                  1870
      KVA = NC ( K )                                                        1880
      IF (KVA)     221, 125, 223                                            1890
 221  NERR = 7                                                              1900
      GO TO 1000                                                            1910
 223  IF (KVA - 20)         225, 225, 221                                   1920
 225  RTABLE ( 9, KVA, 1 ) = TBLMS ( MCODE )                                1930
      RTABLE(9,KVA,2) = HBEG                                                1940
 230  CONTINUE                                                              1950
      GO TO 125                                                             1960
C     D CARD                                                                1970
 280  DO 289       K = 1, 48, 2                                             1980
      KVA = NC (K)                                                          1990
      IF ( KVA )      282, 125, 285                                         2000
 282  NERR = 8                                                              2010
      GO TO 1000                                                            2020
 285  IF ( KVA- 20)       286, 286, 282                                     2030
 286  ITABLE(5,KVA) = NC(K+1) * 10                                          2040
 289  CONTINUE                                                              2050
      GO TO 125                                                             2060
C     S CARD                                                                2070
C     TERMINATE FIRST GROUP                                                 2080
 290  CALL OFIX (NFLG)                                                      2090
 292  DO 298     K = 1, 48, 4                                               2100
      KVA = NC ( K )                                                        2110
      IF ( KVA )      293, 125, 294                                         2120
 293  NERR = 13                                                             2130
      GO TO 1000                                                            2140
 294  IF ( KVA - 20 )      295, 295, 293                                    2150
 295  ITABLE(5,KVA) = 10 * NC(K+1)                                          2160
 297  KV = NC(K+2)                                                          2210
      KVB = NC(K+3)                                                         2220
      NENT = NOTABL (KV, KVB)                                               2230
      IF (NENT)   2972, 2972, 2975                                          2240
 2972 NERR = 14                                                             2250
      GO TO 1000                                                            2260
 2975 ITABLE(6,KVA) = NENT                                                  2270
 298  CONTINUE                                                              2280
      GO TO 125                                                             2290
C                                                                           2300
C        A CLASS CARDS                                                      2310
 318  KCODE = KCODE + 1                                                     2320
 310  KCODE = KCODE + 3                                                     2330
 304  KCODE = KCODE + 3                                                     2340
 314  KCODE = KCODE + 1                                                     2350
 300  KCODE = KCODE + 1                                                     2360
      KNP = 1                                                               2370
      KERR = 1                                                              2380
      GO TO 330                                                             2390
C        R CLASS CARDS                                                      2400
 302  KCODE = KCODE + 3                                                     2410
 316  KCODE = KCODE + 3                                                     2420
      KNP = 2                                                               2430
      KERR = 2                                                              2440
      GO TO 330                                                             2450
C        M CLASS CARDS                                                      2460
 308  KCODE = KCODE + 3                                                     2470
 312  KCODE = KCODE + 4                                                     2480
      KNP = 24
      KERR = 3                                                              2500
      GO TO 330                                                             2510
C        F CARD                                                             2520
 306  KCODE = KCODE + 100                                                   2530
      KNP = 23
      KERR = 4                                                              2550
C                                                                           2560
 330  CALL OFIX (NFLG)                                                      2570
      KNC = 1                                                               2580
      NFN = 0                                                               2590
      NPAR = 0                                                              2600
C        LOOK FOR CONDITIONAL REQUEST                                       2610
      CALL CONDIT (LNO, KCNO, NERR, LENGTH)
      IF (NERR)   1000, 333, 1000                                           2630
C        LOAD KTABLE FOR THIS HISTOGRAM                                     2640
 333  KTABLE(1,KNO) = KCODE                                                 2650
      KTABLE(2,KNO) = MNO                                                   2660
      KTABLE(3,KNO) = KCNO                                                  2670
      KTABLE(4,KNO) = LNO                                                   2680
      KTABLE(5,KNO) = MCODE                                                 2690
      HTABLE(6,KNO) = HBEG                                                  2700
      HTABLE(7,KNO) = HEND                                                  2710
      MNO = MNO + MNOINC                                                    2720
      GO TO (340, 340, 340, 334), KERR                                      2730
C        F CARD - READ OUT FUNCTION NUMBER                                  2740
 334  NA = IABS(NC(KNC))                                                    2750
      NB= IABS(NC(KNC+1))                                                   2760
      NFN = 10*NA + NB                                                      2770
      IF (NFN - 10)   335, 336, 336                                         2780
 335  NERR = 18                                                             2790
      GO TO 1000                                                            2800
 336  KLIST (LNO) = NFN                                                     2810
      LNO = LNO + 1                                                         2820
      KNC = KNC + 2                                                         2830
 340  KLNO = LNO                                                            2840
      LNO = LNO + 1                                                         2850
C        EXAMINE THE VARIABLE FIELD                                         2860
 342  DO 358   KN = 1, KNP                                                  2870
      NA= IABS(NC(KNC))                                                     2880
      NB= IABS(NC(KNC+1))                                                   2890
      IF (NA)   368, 368, 343
C        CHECK FOR COMMA                                                    2910
 343  IF (NA - 28)   350, 344, 353
 344  IF (NFN)   353, 353, 345
 345  KTABLE(4,KNO) = -(1000*KTABLE(4,KNO) + KLIST(KLNO) + 1)
      CALL ECP(KNC, LENGTH, KLNO, LNO)                                  01/03/68
      GO TO 368                                                         01/03/68
 350  KNC = KNC + 2
      NENT = NOTABL (NA, NB)                                                3000
      IF (NENT)   353, 353, 355                                             3010
 353  GO TO (370, 372, 374, 376), KERR                                      3020
 355  KLIST(LNO) = NENT                                                     3030
      KLIST(KLNO) = KLIST(KLNO) + 1                                         3040
      LNO = LNO + 1                                                         3050
 358  CONTINUE                                                              3060
      IF (KNC - LENGTH) 360, 368, 368
C        IF NEXT ENTRY IS NEGATIVE, ADD ON TO THIS HISTOGRAM                3080
 360  IF (NC(KNC))   342, 368, 362                                          3090
C        FINISH OFF THIS HISTOGRAM, GET CMS REQUEST - IF ANY                3100
 362  CALL CMSREQ (LCM, LNO, LTG, KNO, KLNO)
      KNO = KNO + 1                                                         3120
      GO TO 333                                                             3130
C        END OF CARD - WRAP IT UP                                           3140
 368  CALL CMSREQ (LCM, LNO, LTG, KNO, KLNO)
      KNO = KNO + 1                                                         3160
      GO TO 125                                                             3170
 370  NERR = 15                                                             3180
      GO TO 1000                                                            3190
 372  NERR = 17                                                             3200
      GO TO 1000                                                            3210
 374  NERR = 16                                                             3220
      GO TO 1000                                                            3230
 376  NERR = 20                                                             3240
      GO TO 1000                                                            3250
C                  O CARD * PUNCH OUT FACILITY    JAN 12 67
 600  NPT = MCODE
      IF (HBEG .GT. 0.) NOUTM = 1
      IF (HBEG .NE. 1.) NOUTH = 1
      GO TO 125
C        W CARD * WEIGHT CALCULATION                                        3260
 380  CALL OFIX (NFLG)                                                      3270
 382  LNOFN = LNO                                                           3280
      LISTW = LNO                                                           3290
      KLIST(LNO+1) = MCODE                                                  3300
      LNO = LNO + 2                                                         3310
      GO TO 386                                                             3320
C        G CARD * EXPERIMENTAL FACILITY                                     3330
 383  CALL OFIX (NFLG)                                                      3340
 385  LISTG = LNO                                                           3350
      NTAPE = MCODE                                                         3360
      LNOFN = LNO                                                           3370
      LNO = LNO + 1                                                         3380
 386  HLIST(LNO) = HBEG                                                     3390
      HLIST(LNO+1) = HEND                                                   3400
      LNONE = LNO + 2                                                       3410
      LNO = LNO + 3                                                         3420
      DO 399   K = 1, 48, 2                                                 3430
      KA = NC(K)                                                            3440
      KB = NC(K+1)                                                          3450
      IF (K - 1)   390, 390, 394                                            3460
 390  NFN = 10*KA + KB                                                      3470
      IF (NFN - 10)   391, 392, 392                                         3480
 391  NERR = 18                                                             3490
      GO TO 1000                                                            3500
 392  KLIST(LNOFN) = NFN                                                    3510
      GO TO 399                                                             3520
 394  IF (KA)   125, 125, 396                                               3530
 396  NENT = NOTABL (KA, KB)                                                3540
      IF (NENT)   397, 397, 398                                             3550
 397  NERR = 20                                                             3560
      GO TO 1000                                                            3570
 398  KLIST(LNO) = NENT                                                     3580
      KLIST(LNONE) = KLIST(LNONE) + 1                                       3590
      LNO = LNO + 1                                                         3600
 399  CONTINUE                                                              3610
      GO TO 125                                                             3620
C     E CARD MISSING, PROCEED                                               3630
 480  CONTINUE
C     E CARD                                                                3670
 490  MNOLFT=LIMMNO-MNO+1
      WRITE (NOT,9200) LIMMNO,LIMLNO,LIMEX,LIMKNO,MNOLFT
 9200 FORMAT (//16H0MTABLE LIMIT = I5,16H, KLIST LIMIT = ,I4,17H, EXBANK
     1 LIMIT = I5,42H, MAXIMUM NUMBER OF HISTOGRAMS ALLOWED IS I4,1H.,
     2        /11H0THERE ARE ,I6,26H LOCATIONS LEFT IN MTABLE. //)
C
      IF (NFLG)   493, 491, 493
 491  NERR = 12                                                             3760
      GO TO 1000                                                            3770
 493  CALL SCALW                                                            3780
      ITERAT = 1
      GO TO 1000                                                            3790
C     ILLEGAL CARD CODE                                                     3800
 500  NERR = 10                                                             3810
      GO TO 1000                                                            3820
C        X CARD                                                             3830
 510  KCODE = 1000                                                          3840
      NXF = 1                                                               3850
      MNOINC = 0                                                            3860
      NXA= IABS(MCODE)                                                      3870
      GO TO 530                                                             3880
C        Y CARD                                                             3890
 520  IF (NXF - 1)   521, 522, 521                                          3900
 521  NERR = 25                                                             3910
      GO TO 1000                                                            3920
 522  KCODE = 2000                                                          3930
      MNOINC= (NXA+ 1)*(IABS(MCODE) + 1) + 5                                3940
 530  L= IABS(NC(1))                                                        3950
      DO 532   K = 1, 47                                                    3960
 532  NC(K) = NC(K+1)                                                       3970
      LENGTH = LENGTH - 1
      GO TO 140                                                             3980
 1000 RETURN                                                                3990
      END                                                                   4000