PDP-10 Archive: uetp/lib/v4s.for from red405a2

Trailing-Edge - PDP-10 Archives - red405a2 - uetp/lib/v4s.for

There is 1 other file named v4s.for in the archive. Click here to see a list.

*	INVOKE SS3 OF V4S.
	INCLUDE 'SS3.SUB'
	CALL SBIND('V4S',00001,'SS3',00033,SYSCOM)
	CALL BIND(00003,VACAMT,LNAME,FAMILY,PROFES)
	CALL BIND(00008,EXPER,SKMASK)
	CALL BIND(00001)
	CALL EBIND(0,DBNULL)

*	OPEN AREA AREA1 USAGE-MODE IS PROT UPDATE PRIVACY KEY ABC.
	CALL OPEND( -21 , -24 ,'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
	  DO 12 J=1,JMAX
	  SKMASK(1)=RAN(X)*2**34
	  TYPE *,SKMASK(1)
	  SKMASK(2)=0
*	  STORE SORTREC.
	CALL STORED(00008)
12	  CONTINUE
11	  CONTINUE

	CALL STATS

*	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 V4S.
	END