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
104
105
106
107
108
109
110
111
112
113
114
115
|
SUBROUTINE SFETCH (NAME,ITEM,IRW,ITEST)
C
C POSITIONS THE SOF TO READ OR WRITE DATA ASSOCIATED WITH ITEM OF
C SUBSTRUCTURE NAME.
C
EXTERNAL ANDF
LOGICAL MDIUP
INTEGER ANDF,BUF,MDI,MDIPBN,MDILBN,MDIBL,BLKSIZ,DIRSIZ
DIMENSION NAME(2),NMSBR(2)
CHARACTER UFM*23,UWM*25,UIM*29,SFM*25
COMMON /XMSSG / UFM,UWM,UIM,SFM
COMMON /ZZZZZZ/ BUF(1)
COMMON /SOF / DITDUM(6),IO,IOPBN,IOLBN,IOMODE,IOPTR,IOSIND,
1 IOITCD,IOBLK,MDI,MDIPBN,MDILBN,MDIBL,NXTDUM(15),
2 DITUP,MDIUP
COMMON /SYS / BLKSIZ,DIRSIZ
COMMON /SYSTEM/ NBUFF,NOUT
DATA IDLE , IRD,IWRT /0,1,2/, NMSBR /4HSFET,4HCH /
C
CALL CHKOPN (NMSBR(1))
CALL FDSUB (NAME(1),IOSIND)
IF (IOSIND .EQ. -1) GO TO 500
IOITCD = ITCODE(ITEM)
IF (IOITCD .EQ. -1) GO TO 510
C
C CHECK IF ITEM IS A TABLE ITEM UNLESS SPECIAL CALL FROM MTRXO OR
C MTRXI
C
IF (IRW .LT. 0) GO TO 10
ITM = ITTYPE(ITEM)
IF (ITM .NE. 0) GO TO 530
10 CALL FMDI (IOSIND,IMDI)
IOLBN = 1
IOPTR = IO + 1
IBL = ANDF(BUF(IMDI+IOITCD),65535)
IRDWRT= IABS(IRW)
GO TO (30,80,30), IRDWRT
C
C READ OPERATION.
C
30 IF (IBL .EQ. 0) GO TO 50
IF (IBL .NE. 65535) GO TO 60
C
C ITEM WAS PSEUDO-WRITTEN.
C
ITEST = 2
GO TO 520
C
C ITEM HAS NOT BEEN WRITTEN.
C
50 ITEST = 3
GO TO 520
C
C UPDATE THE COMMON BLOCK SOF, AND BRING INTO CORE THE DESIRED BLOCK
C
60 ITEST = 1
IF (IRDWRT .EQ. 3) GO TO 520
IOPBN = IBL
IOMODE = IRD
CALL SOFIO (IRD,IOPBN,BUF(IO-2))
RETURN
C
C WRITE OPERATION.
C
80 IF (IBL.EQ.0 .OR. IBL.EQ.65535) GO TO 90
C
C ITEM HAS ALREADY BEEN WRITTEN.
C
ITEST = 1
GO TO 520
90 ITEST1 = ITEST - 1
GO TO (100,110), ITEST1
C
C ITEM IS TO BE PSEUDO-WRITTEN.
C
100 BUF(IMDI+IOITCD) = 65535
MDIUP = .TRUE.
RETURN
C
C ITEM IS TO BE WRITTEN. GET A FREE BLOCK AND UPDATE THE COMMON
C BLOCK SOF.
C
110 CALL GETBLK (0,IOBLK)
IF (IOBLK .EQ. -1) GO TO 1000
IOPBN = IOBLK
IOMODE = IWRT
RETURN
C
C NAME DOES NOT EXIST.
C
500 ITEST = 4
GO TO 520
C
C ITEM IS AN ILLEGAL ITEM NAME.
C
510 ITEST = 5
520 IOMODE = IDLE
RETURN
C
C ATTEMPT TO OPERATE ON A MATRIX ITEM
C
530 WRITE (NOUT,540) SFM,ITEM,NAME
540 FORMAT (A25,' 6227, AN ATTEMPT HAS BEEN MADE TO OPERATE ON THE ',
1 'MATRIX ITEM ',A4,' OF SUBSTRUCTURE ',2A4,' USING SFETCH.')
GO TO 1010
C
C NO MORE BLOCKS ON SOF
C
1000 WRITE (NOUT,1001) UFM
1001 FORMAT (A23,' 6223, SUBROUTINE SFETCH - THERE ARE NO MORE FREE ',
1 'BLOCKS AVAILABLE ON THE SOF.')
1010 CALL SOFCLS
CALL MESAGE (-61,0,0)
RETURN
END
|
