PDP-10 Archive: from

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
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