Trailing-Edge
-
PDP-10 Archives
-
decus_20tap1_198111
-
decus/20-0009/main.for
There is 1 other file named main.for in the archive. Click here to see a list.
C N BODY M VERTEX SAMPLE GENERATOR
C VERSION WITH EXTRA PARAMETER READ-IN FACILITY
C WILL READ PARAMETERS INTO BLOCK IN EXBANK DESIGNATED BY NBRNCH(2)
C USING PAREAD
C REVISED FORTRAN IV VERSION -- SPACE FOR EXBANK IS DIMENSIONED
C IN LIMITS, A BLOCK DATA SUBROUTINE
C RUN TERMINATES WHEN NBRNCH(1) IS 9
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),NBRCH2(10),HEAD2(11)
DIMENSION KTABLE(7,100)
EQUIVALENCE (MAP,ZMAP,KTABLE)
EQUIVALENCE (REMARK,MAP(1001)),(NBRCH2,MAP(1501)),
1 (HEAD2,MAP(1511))
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 (MTOT,MAP(1987)) 7/13/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 (LTAPE,NBRNCH(9)), (LINK,NBRNCH(10))
C ****************** END OF STANDARD CDE STATEMENTS ****************
DATA END/'E'/, LP/-1000/
C
PI=3.14159
RADIAN=57.29578
TYPE 701
701 FORMAT(' OUPUT UNIT?'/)
ACCEPT 702,NOT,XNAME
702 FORMAT(I,A5)
CALL OFILE(NOT,XNAME)
TYPE 703
703 FORMAT(' INPUT UNIT?'/)
ACCEPT 702,NIT,XNAME
CALL IFILE(NIT,XNAME)
C ZERO EXBANK
NBEGN=LIMMNO+1
IJEND=LIMMNO+LIMEX
DO 2 I=NBEGN,IJEND
2 MTABLE(I)=0
1 CALL PAREAD (NIT,NOT,NBRNCH,HEAD,PARS,LP,SNAME,REMARK,500)
IF (NBRNCH(1) - 9) 30,3,30
C PARAMETER END BLOCK READ, WRAP IT UP
3 IF (NTAPE) 8, 8, 4
4 END FILE NTAPE
6 REWIND NTAPE
8 CALL EXIT
C NBRNCH(2) NONZERO SAYS CALL PAREAD TO READ EXTRA PARAMETERS INTO
C BANK INDICATED BY NBRNCH(2).
30 IF(NBRNCH(2)) 10,10,31
31 NCHK=NBRNCH(2)*1000
IF (NCHK-1000-LIMEX) 32,111,111
111 WRITE (NOT,1313) NBRNCH(2),LIMEX
1313 FORMAT(1H0,20X,47HINSUFFICIENT STORAGE AVAILABLE IN EXBANK. EPARS
1I1,29H EXCEEDS EXBANK DIMENSION OF I4/1H 25X,30HPROCEEDING TO NEXT
1 EVENT TYPE.)
33 READ (NIT,9001) ACHECK
9001 FORMAT(A1)
IF(ACHECK.NE.END) GO TO 33
GO TO 10
32 NEPARS = NBRNCH(2)
NBEGN=NCHK-999+LIMMNO
WRITE (NOT,3401)NEPARS
3401 FORMAT(33H1EXTRA PARAMETERS READ INTO EPARS I1 )
IF (NCHK-LIMEX) 35,35,34
34 LENGTH=LIMEX-(NBRNCH(2)-1)*1000
WRITE (NOT,1414) LENGTH
1414 FORMAT (1H0,20X 5HONLY I4,79H SPACES AVAILABLE IN EXBANK. THE REST
1 IS NEEDED FOR SYSTEM AND PROGRAM STORAGE.)
GO TO 36
35 LENGTH=1000
36 CALL PAREAD (NIT,NOT,NBRCH2,HEAD2,MTABLE(NBEGN),LENGTH,SNAME,
1 REMARK,500)
C READ IN AND SET UP A NEW EVENT TYPE
10 CALL SSWTCH(2,K000FX)
GO TO(20,15),K000FX
15 WRITE (NOT,9015)
9015 FORMAT (30H0SENSE SWITCH 2 TERMINATION )
CALL EXIT
20 NERR = 0
CALL SETUP ( NERR )
IF (NERR) 45, 80, 45
C IF NERR = 100 READ IN NEW PARAMETERS
45 IF (NERR - 100) 500, 1, 500
80 CALL HEDING
NORD = 0
C BEGINNING OF EVENT GENERATION LOOP, CHECK FOR OPERATOR KILL
90 CALL SSWTCH(1,K000FX)
GO TO(95,92),K000FX
92 KILL = NORD + 1
WRITE (NOT,9092)KILL
9092 FORMAT (45H0SENSE SWITCH TERMINATION, LAST EVENT NUMBER I6)
NORD = MTOT - 1
95 NORD = NORD + 1
CALL EVENT ( NERR )
C CHECK FOR ERROR DURING EVENT GENERATION
IF (NERR) 96, 100, 96
96 IF (NORD-1) 500, 500, 97
97 CALL OHIST(0)
GO TO 500
100 CALL EHIST
200 IF (NORD - MTOT) 90, 300, 300
C END OF EVENT GENERATION, SAMPLE COMPLETE, OUTPUT
300 CALL OHIST (0)
CALL SSWTCH(1,K000FX)
GO TO(10,3),K000FX
C FOLLOWING IS DUMP ON ERROR FLAG
500 WRITE (NOT,9500)NERR
9500 FORMAT ( 23H0INPUT DATA ERROR TYPE I4/ 65H FOLLOWING ARE DUMP
1S OF ITABLE, KTABLE, OTABLE, LTABLE, AND KLIST )
CALLPDUMP ( ITABLE(1,1), ITABLE(120,1), 2, KTABLE(1,1), KTABLE(700
1,1), 2, OTABLE(1,1), OTABLE(350,1), 1, LTABLE(1,1,1), LTABLE(360
2,1,1), 2, KLIST(1), KLIST(500), 2 )
CALL SSWTCH(1,K000FX)
GO TO(10,3),K000FX
END