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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
SUBROUTINE SOFUT
C
C THE PURPOSE OF THE MODULE IS TO PERFORM THE TASKS OF ALTERING THE
C SOF FILE IN ORDER TO EDIT, PURGE, AND EQUIVALENCE THE DATA ITEMS
C OF SELECTED SUBSTRUCTURES. THE CALLING SEQUENCE TO THE MODULE IS
C
C SOFUT //V,N,DRY/C,N,NAME1/C,N,OPER/C,N,OPT/C,N,NAME2/
C C,N,PREFX/C,N,IA/C,N,IB/C,N,IC/C,N,ID/C,N,IE $
C
EXTERNAL RENAME
LOGICAL DITUP
INTEGER DRY,OPER,OPT,PREFX,SYSBUF,DELE,RENAM,NAME(2)
CHARACTER UFM*23,UWM*25
COMMON /XMSSG / UFM,UWM
COMMON /BLANK / DRY,NAME1(2),OPER(2),OPT,NAME2(2),PREFX(2),
1 ITEMS(10)
COMMON /SOF / SSS(33),DITUP
COMMON /ZZZZZZ/ IZ(1)
COMMON /SYSTEM/ SYSBUF,NOUT
DATA IEDIT , IDEST,IEQUIV / 4HEDIT ,4HDEST ,4HEQUI /
DATA IPRNT / 4HSOFP/
DATA DELE / 4HDELE/
DATA RENAM / 4HRENA/
DATA NAME / 4HSOFU,4HT /
DATA ISCR1 / 301 /
C
ITASK = 0
IF (OPER(1) .EQ. IEDIT) ITASK = 1
IF (OPER(1) .EQ. IDEST) ITASK = 2
IF (OPER(1) .EQ. IEQUIV) ITASK = 3
IF (OPER(1) .EQ. IPRNT) ITASK = 4
IF (OPER(1) .EQ. DELE) ITASK = 5
IF (OPER(1) .EQ. RENAM) ITASK = 6
IF (ITASK .EQ. 0) GO TO 1000
C
C ALLOCATE BUFFERS FOR THE SOF UTILITY SUBROUTINES
C
NZ = KORSZ(IZ)
IF (3*SYSBUF .GT. NZ) CALL MESAGE (-8,0,NAME(1))
IB1 = NZ - SYSBUF + 1
IB2 = IB1 - SYSBUF - 1
IB3 = IB2 - SYSBUF
CALL SOFOPN (IZ(IB1),IZ(IB2),IZ(IB3))
NZ = IB3 - 1
GO TO (20,30,40,130,180,200), ITASK
C
C EDIT OPERATION
C
20 CALL EDIT (NAME1(1),OPT,ITEST)
GO TO 50
C
C DESTROY OPERATION
C
30 I = NZ/2 + 1
CALL DSTROY (NAME1(1),ITEST,IZ,IZ(I),I-1)
GO TO 50
C
C EQUIVALENCE OPERATION
C
40 I = NZ/2 + 1
CALL SETEQ (NAME1,NAME2,PREFX,DRY,ITEST,IZ,I-1)
C
C TEST RETURN CODE
C
50 GO TO (110,110,110,60,110,70,110,80,90,100), ITEST
60 WRITE (NOUT,1010) UWM,NAME1
GO TO 100
70 WRITE (NOUT,1020) UWM,NAME1
GO TO 100
80 WRITE (NOUT,1030) UWM,NAME2
GO TO 100
90 WRITE (NOUT,1040) UWM,NAME2
100 DRY = -2
110 CALL SOFCLS
GO TO 1100
C
C PRINT OPERATIONS
C
130 IF (OPT) 140,140,150
C
C PRINT SOF TABLE OF CONTENTS (DIT MDI)
C
140 CALL SOFTOC
IF (OPT .EQ. 0) GO TO 170
C
C PRINT SOF DATA ITEMS
C
150 DO 160 I = 1,5
II = ITTYPE(ITEMS(2*I-1))
IF (II) 160,152,154
C
C TABLE ITEM
C
152 CALL ITMPRT (NAME1,ITEMS(2*I-1),NZ,OPT)
GO TO 160
C
C MATRIX ITEM
C
154 CALL MATWRT (ISCR1,NAME1,ITEMS(2*I-1),NZ)
C
160 CONTINUE
170 CALL SOFCLS
GO TO 1100
C
C DELETE OPERATION
C
180 DO 190 I = 1,10
190 CALL DELETE (NAME1,ITEMS(I),ITEST)
GO TO 50
C
C RENAME OPERATION
C
200 CALL RENAME (NAME1,NAME2,IZ(1),NZ,ITEST)
GO TO 50
C
C ERROR MESSAGES
C
1000 WRITE (NOUT,1001) UWM,OPER(1),OPER(2)
1001 FORMAT (A25,' 6217, MODULE SOFUT - ',2A4,' IS AN ILLEGAL ',
1 'PARAMETER NAME.')
GO TO 1100
C
1010 FORMAT (A25,' 6212, MODULE SOFUT - THE SUBSTRUCTURE ',2A4,
1 ' DOES NOT EXIST.')
C
1020 FORMAT (A25,' 6218, MODULE SOFUT - THE SUBSTRUCTURE ',2A4,1X,
1 'CANNOT BE DESTROYED BECAUSE IT IS AN IMAGE SUBSTRUCTURE.')
C
1030 FORMAT (A25,' 6219, MODULE SOFUT - RUN EQUALS DRY OR STEP AND ',
1 'SUBSTRUCTURE ',2A4, /33X,
2 'OR ONE OF THE NEW NAMES ALREADY EXISTS.')
C
1040 FORMAT (A25,' 6220, MODULE SOFUT - RUN = GO AND SUBSTRUCTURE ',
1 2A4,' OR ONE OF THE NEW NAMES DOES NOT EXIST')
C
1100 RETURN
END
|
