1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
SUBROUTINE DELETE (NAME,ITEMX,ITEST)
C
C DELETES ITEM WHICH BELONGS TO THE SUBSTRUCTURE NAME. THE MDI IS
C UPDATED ACCORDINGLY AND THE BLOCKS ON WHICH ITEM WAS WRITTEN ARE
C RETURNED TO THE LIST OF FREE BLOCKS. ITEST IS AN OUTPUT PARAMETER
C WHICH TAKES ON ONE OF THE FOLLOWING VALUES
C
C 1 IF ITEM DOES EXIST
C 2 IF ITEM PSEUDO-EXISTS
C 3 IF ITEM DOES NOT EXIST
C 4 IF NAME DOES NOT EXIST
C 5 IF ITEM IS AN ILLEGAL ITEM NAME
C
C THE BLOCKS OCCUPIED BY THE ITEM ARE RETURNED TO THE LIST OF FREE
C BLOCKS IF THEY BELONG TO THE SPECIFIED SUBSTRUCTURE
C
C
EXTERNAL RSHIFT,ANDF
LOGICAL MDIUP
INTEGER BUF,MDI,MDIPBN,MDILBN,MDIBL,BLKSIZ,DIRSIZ,PS,SS,
1 ANDF,RSHIFT
DIMENSION NAME(2),NMSBR(2)
COMMON /ZZZZZZ/ BUF(1)
COMMON /SOF / DITDUM(6),IODUM(8),MDI,MDIPBN,MDILBN,MDIBL,
1 NXTDUM(15),DITUP,MDIUP
COMMON /SYS / BLKSIZ,DIRSIZ,SYS(3),IFRST
COMMON /ITEMDT/ NITEM,ITEM(7,1)
DATA IS,PS , SS/ 1,1,1 /
DATA NMSBR / 4HDELE,4HTE /
C
CALL CHKOPN (NMSBR(1))
CALL FDSUB (NAME(1),K)
IF (K .EQ. -1) GO TO 500
CALL FMDI (K,IMDI)
II = ITCODE(ITEMX)
IF (II .EQ. -1) GO TO 510
ITM = II - IFRST + 1
IBL = ANDF(BUF(IMDI+II),65535)
C 55535 = 2**16 - 1
IF (IBL .NE. 0) GO TO 10
C
C ITEM DOES NOT EXIST.
C
ITEST = 3
RETURN
C
10 BUF(IMDI+II) = 0
MDIUP = .TRUE.
IF (IBL .NE. 65535) GO TO 20
C
C ITEM PSEUDO-EXISTS.
C
ITEST = 2
GO TO 30
C
C ITEM DOES EXIST.
C
20 ITEST = 1
30 IF (ANDF(BUF(IMDI+IS),1073741824) .EQ. 0) GO TO 35
C 1073741824 = 2**30
C
C IMAGE SUBSTRUCTURE
C
IF (ITEST .NE. 1) RETURN
IF (ITEM(4,ITM) .EQ. 0) GO TO 32
CALL RETBLK (IBL)
32 RETURN
C
C NAME IS A SECONDARY OR A PRIMARY SUBSTRUCTURE
C
35 ISVPS = ANDF(BUF(IMDI+PS),1023)
C 1023 = 2**10 - 1
IF (ISVPS .EQ. 0) GO TO 39
C
C SECONDARY SUBSTRUCTURE
C
IF (ITEST .NE. 1) RETURN
IF (ITEM(5,ITM) .EQ. 0) GO TO 37
CALL RETBLK (IBL)
37 RETURN
C
C PRIMARY SUBSTRUCTURE
C
39 IF (ITEST .EQ. 1) CALL RETBLK (IBL)
40 ISVSS = RSHIFT(ANDF(BUF(IMDI+SS),1048575),10)
C 1048575 = 2*20 - 1
IF (ISVSS .EQ. 0) RETURN
CALL FMDI (ISVSS,IMDI)
IF (ANDF(BUF(IMDI+II),65535) .NE. IBL) GO TO 40
BUF(IMDI+II) = 0
MDIUP = .TRUE.
GO TO 40
C
C NAME DOES NOT EXIST.
C
500 ITEST = 4
RETURN
C
C ITEM IS AN ILLEGAL ITEM NAME.
C
510 ITEST = 5
RETURN
END
|
