Google
 
Trailing-Edge - PDP-10 Archives - KS10_APT_INSTALL_TAPE - uetp/lib/v4b.for
There is 1 other file named v4b.for in the archive. Click here to see a list.
	LOGICAL CALCSORT(3)
*	INVOKE SS1 OF V4B.
	INCLUDE 'SS1.SUB'
	CALL SBIND('V4B',00001,'SS1',00035,SYSCOM)
	CALL BIND(00003,VACAMT,LNAME,FAMILY,PROFES)
	CALL BIND(00008,EXPER,SKMASK)
	CALL BIND(00001)
	CALL EBIND(0,DBNULL)
	DATA CALCSORT/8,'CALCSORTZZ'/

*	OPEN AREA AREA1 USAGE-MODE IS EXCL UPDATE PRIVACY KEY ABC.
	CALL OPEND( -21 , -25 ,'ABC',00002)

	ACCEPT *,JMAX

	DO 10 I=10,-10,-1
	PROFES=I
*	STORE CALCREC SUPPRESS CALCSORT,AREA UPDATES.
	CALL STORED(00003,00012, -18 )
*	MOVE STATUS CALCREC RECORD TO I1.
	CALL MOVEC(00003, -19 ,I1)
*	MOVE STATUS CALCSORT SET TO I2.
	CALL MOVEC(00012, -20 ,I2)
*	MOVE STATUS AREA1 AREA TO I3.
	CALL MOVEC(00002, -18 ,I3)
*	TYPE 101,I1,I2,I3
10	CONTINUE

	DO 11 I=-10,10
	PROFES=I
	CALL JSTRAN(CALCSORT(2),PROFES+15)
	  DO 12 J=1,JMAX
	  SKMASK(1)=RAN(X)*2**34
	  TYPE *,SKMASK(1)
	  SKMASK(2)=0
*	  STORE SORTREC.
	CALL STORED(00008)
12	  CONTINUE
	CALL JETRAN(CALCSORT(2),PROFES+15)
11	CONTINUE

	CALL STATS

	CALL JBTRAN(15)

*	FIND	OWNER OF SYS-SET SET.
	CALL FIND4(00011)
	IF (ERSTAT.NE.0) STOP 'ERROR'

	DO 21 I=1,100000
*	FIND NEXT RECORD OF SYS-SET SET.
	CALL FIND3( -15 ,0,00011, -20 )
	IF (ERSTAT.EQ.307) GOTO 99
	IF (ERSTAT.NE.0) STOP 'ERROR'
*	GET SORTREC.
	CALL GETS(00008)
	IF (ERSTAT.NE.0) STOP 'ERROR'
	TYPE *,SKMASK(1)
	IF (.NOT. MEMBER('CALCSORT')) STOP 'PRED'
*	FIND OWNER OF CALCSORT SUPPRESS ALL.
	CALL FIND4(00012, -17 )
	IF (ERSTAT.NE.0) STOP 'ERROR'
*	GET CALCREC.
	CALL GETS(00003)
	IF (ERSTAT.NE.0) STOP 'ERROR'
21	CONTINUE

*99	CLOSE AREA AREA1.
99	CALL CLOSED( -18 ,00002)
	CALL STATS

101	FORMAT(1H ,3(O12,X))
*	END V4B.
	END