Google
 
Trailing-Edge - PDP-10 Archives - KS10_APT_INSTALL_TAPE - uetp/lib/v4.for
There is 1 other file named v4.for in the archive. Click here to see a list.
*	INVOKE SUBS1 OF ORDTIN PRIVACY KEY COMPILE ORDER1.
	INCLUDE 'SUBS1.SUB'
	CALL SBIND('ORDTIN',00001,'SUBS1',00035,SYSCOM)
	CALL BIND(00006,UNDEFP(1),CUSKEY,CUSDBK,UNDEFP(7),0)
	CALL BIND(00011,ORDNUM,UNDEFP(25),UNDEFP(27),UNDEFP(28))
	CALL BIND(00016,UNDEFP(30),UNDEFP(32),UNDEFP(34),UNDEFP(35))
	CALL BIND(00021,UNDEFP(37),PRDESC,UNDEFP(39),UNDEFP(41),UNDEFP(42
	1),UNDEFP(44),UNDEFP(45),PINS)
	CALL BIND(00030,OSORD,UNDEFP(46),0)
	CALL BIND(00033,UNDEFP(48),SLSOFF,UNDEFP(54),0)
	CALL BIND(00037,UNDEFP(57),UNDEFP(59),UNDEFP(64),UNDEFP(71),UNDEF
	1P(73))
	CALL BIND(00043,UNDEFP(75),UNDEFP(77))
	CALL BIND(00001)
	CALL EBIND(0,DBNULL)
	IF (ERCNT.NE.0) ACCEPT 101,J

	ACCEPT *,J
	IF (J.EQ.0) CALL JMNONE(0)
	IF (J.EQ.1) CALL JMBEF('AREA1')

*	OPEN AREA AREA1 USAGE-MODE IS EXCLUSIVE UPDATE.
	CALL OPEND( -21 , -25 ,0,00002)
	IF (ERCNT.NE.0) ACCEPT 101,J
	SLSOFF(1,1)='HOME'

	DO 11 I=1,50
*	STORE SLSENG.
	CALL STORED(00033)
	IF (ERCNT.NE.0) ACCEPT 101,J
	CUSKEY=I
*	STORE CUSTOM.
	CALL STORED(00006)
	IF (ERCNT.NE.0) ACCEPT 101,J
*	MOVE STATUS AREA1 AREA TO CUSDBK.
	CALL MOVEC(00002, -18 ,CUSDBK)
*	INSERT CUSTOM INTO SLSCUS-SET.
	CALL INSRT(00006,00049)
	IF (ERCNT.NE.0) ACCEPT 101,J

	CUSKEY=I
*	STORE CUSTOM.
	CALL STORED(00006)
	IF (ERCNT.NE.0) ACCEPT 101,J
*	MOVE STATUS AREA1 AREA TO CUSDBK.
	CALL MOVEC(00002, -18 ,CUSDBK)
*	INSERT CUSTOM INTO SLSCUS-SET.
	CALL INSRT(00006,00049)
	IF (ERCNT.NE.0) ACCEPT 101,J
11	CONTINUE


*	FIND FIRST RECORD OF AREA1 AREA.
	CALL FIND3( -12 ,0,00002, -18 )
	IF (ERCNT.NE.0) ACCEPT 101,J
*	GET.
	CALL GETS(0)
	IF (ERCNT.NE.0) ACCEPT 101,J
	IF (KKK.EQ.7) TYPE 102,CUSKEY,CUSDBK

	DO 12 I=1,49
*	FIND NEXT SLSENG RECORD OF AREA1 AREA.
	CALL FIND3( -15 ,00033,00002, -18 )
	IF (ERCNT.NE.0) ACCEPT 101,J
*	FIND NEXT RECORD OF SLSCUS-SET SET.
	CALL FIND3( -15 ,0,00049, -20 )
	IF (ERCNT.NE.0) ACCEPT 101,J
*	GET.
	CALL GETS(0)
	IF (ERCNT .NE. 0) ACCEPT 101,J
	IF (KKK.EQ.7) 	TYPE 102,CUSKEY,CUSDBK
*	FIND NEXT RECORD OF SLSCUS-SET SET.
	CALL FIND3( -15 ,0,00049, -20 )
	IF (ERCNT.NE.0) ACCEPT 101,J
*	GET.
	CALL GETS(0)
	IF (ERCNT .NE. 0) ACCEPT 101,J
	IF (KKK.EQ.7) 	TYPE 102,CUSKEY,CUSDBK
*	FIND NEXT RECORD OF SLSCUS-SET SET.
	CALL FIND3( -15 ,0,00049, -20 )
	IF (ERSTAT.NE.0307) ACCEPT 101,J
12	CONTINUE

*	CLOSE ALL.
	CALL CLOSED( -17 )

	CALL STATS

101	FORMAT(I)
102	FORMAT (1X ,I8,2X,O12)
	END