Trailing-Edge
-
PDP-10 Archives
-
red405a2
-
uetp/lib/v4.fml
There are 16 other files named v4.fml in the archive. Click here to see a list.
* DBMS
INVOKE SUBS1 OF ORDTIN PRIVACY KEY COMPILE ORDER1.
IF (ERCNT.NE.0) ACCEPT 101,J
ACCEPT *,J
IF (J.EQ.0) CALL JMNONE(0)
IF (J.EQ.1) CALL JMBEF('AREA1')
* DBMS
OPEN AREA AREA1 USAGE-MODE IS EXCLUSIVE UPDATE.
IF (ERCNT.NE.0) ACCEPT 101,J
SLSOFF(1,1)='HOME'
DO 11 I=1,50
* DBMS
STORE SLSENG.
IF (ERCNT.NE.0) ACCEPT 101,J
CUSKEY=I
* DBMS
STORE CUSTOM.
IF (ERCNT.NE.0) ACCEPT 101,J
* DBMS
MOVE STATUS AREA1 AREA TO CUSDBK.
* DBMS
INSERT CUSTOM INTO SLSCUS-SET.
IF (ERCNT.NE.0) ACCEPT 101,J
CUSKEY=I
* DBMS
STORE CUSTOM.
IF (ERCNT.NE.0) ACCEPT 101,J
* DBMS
MOVE STATUS AREA1 AREA TO CUSDBK.
* DBMS
INSERT CUSTOM INTO SLSCUS-SET.
IF (ERCNT.NE.0) ACCEPT 101,J
11 CONTINUE
* DBMS
FIND FIRST RECORD OF AREA1 AREA.
IF (ERCNT.NE.0) ACCEPT 101,J
* DBMS
GET.
IF (ERCNT.NE.0) ACCEPT 101,J
IF (KKK.EQ.7) TYPE 102,CUSKEY,CUSDBK
DO 12 I=1,49
* DBMS
FIND NEXT SLSENG RECORD OF AREA1 AREA.
IF (ERCNT.NE.0) ACCEPT 101,J
* DBMS
FIND NEXT RECORD OF SLSCUS-SET SET.
IF (ERCNT.NE.0) ACCEPT 101,J
* DBMS
GET.
IF (ERCNT .NE. 0) ACCEPT 101,J
IF (KKK.EQ.7) TYPE 102,CUSKEY,CUSDBK
* DBMS
FIND NEXT RECORD OF SLSCUS-SET SET.
IF (ERCNT.NE.0) ACCEPT 101,J
* DBMS
GET.
IF (ERCNT .NE. 0) ACCEPT 101,J
IF (KKK.EQ.7) TYPE 102,CUSKEY,CUSDBK
* DBMS
FIND NEXT RECORD OF SLSCUS-SET SET.
IF (ERSTAT.NE.0307) ACCEPT 101,J
12 CONTINUE
* DBMS
CLOSE ALL.
CALL STATS
101 FORMAT(I)
102 FORMAT (1X ,I8,2X,O12)
END