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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
SUBROUTINE ONLINS (*,LX)
C
C ON-LINE SCAN ROUTINE, CALLED ONLY BY SCAN
C
C WRITTEN FEBY G.CHAN/SPERRY, FEB. 1986
C
IMPLICIT INTEGER (A-Z)
EXTERNAL LSHIFT, RSHIFT, ANDF, ORF, COMPLF
LOGICAL DEBUG
INTEGER NAME(2), CARD(20), IZ(1)
REAL R(2), Z(30)
COMMON /MACHIN/ MACH
COMMON /BLANK / IELT(2), ICOMP, NTOP, AMAX, AMIN,
1 IBEG, IEND, ICOMPX
COMMON /SYSTEM/ IBUF, OUTTAP, NOGO, IN, DUM(74),
1 SWTCH1, JDUM(6), INTRA
COMMON /XSCANX/ SKIP(2), LCORE, LBEG, LEND, DUMM(2),
1 IEL, IOPT, ISET, ISORT, IDUM(4),
2 DEBUG
COMMON /IFP1A / SCR1, CASECC, IS, NWPC, NCPW,
1 NMODES, ICC, NSET, DUMMY(3), ISUB,
2 LENCC, IBLNK, IEQUAL, IEOR
C
C /ZZIFP1/ IS THE OPEN CORE FOR SCAN
COMMON /ZZZZZZ/ LCSE(400),CORE(1)
EQUIVALENCE (IZ(1),LCSE(1))
EQUIVALENCE (IMAX,AMAX), (IMIN,AMIN),
1 (IDUPL,IBEG), (INC,IEND),
2 (CARD(1),CORE(1)), (IZ(1),Z(1))
DATA BLANK , EQUAL , STOP , ALL , NAME /
1 4H , 4H= , 4HSTOP, 4HALL , 4HONLI, 4HNS /
DATA LU , DEBUG1, DEBUG2, DEBUG3, I0 /
1 1 , 4HDEBU, 4HG ON, 4HG OF, 0 /
C
C INITIALIZE /IFP1A/
C
SCR1 = 301
CASECC = 101
IS = 0
NWPC = 20
NCPW = 4
NMODES = 0
ICC = 0
ISUB = 1
IBLNK = BLANK
IEQUAL = EQUAL
IEOR = COMPLF(0)
IEOR = RSHIFT(IEOR,1)
C
C SET INTERACTIVE FLAG TO POSITIVE, A SIGNAL TO SCAN, TOTAPE, IFP1C
C
INTRA = IABS(INTRA)
IF (INTRA .EQ. 0) INTRA = 1
C
ICOMP = LX
NWPC1 = NWPC + 1
NOUT = OUTTAP
WRITE (NOUT,10)
10 FORMAT (///1X,'*** SCAN INTERACTIVE INPUT ***')
C
C READ CASECC FILE AND SAVE DATA IN LCSE, ONE SUBCASE AT A TIME
C SAVE SET DATA IN CORE BEGIN AT CORE(BGN)
C
15 LCSE(166) = 200
LCSE(199) = 0
LCSE(200) = 0
NZ = KORSZ(CORE(1)) - 3*IBUF - 1
NZ = MIN0(NZ,LCORE)
ISCAN = 0
NSET = 0
I81 = NWPC1
SUBID =-1
LX = 0
IF (ICOMP .EQ. -2) GO TO 30
C
C NO QUESTION ASKED IF SORT2 DATA TYPE IS USED.
C
LX = 1
20 WRITE (NOUT,25)
25 FORMAT (//,' ENTER SUBCASE ID (DEFAULT=FIRST SUBCASE)')
READ (IN,26) R
26 FORMAT (2A4)
CALL A82INT (*20,R,8,SUBID,I)
IF (SUBID .EQ. 0) SUBID = -1
IF (INTRA .GT. 10) WRITE (LU,27) SUBID
27 FORMAT (///3X,'SUBCASE ID',I8)
30 JJ = 1
CALL REWIND (CASECC)
CALL FWDREC (*110,CASECC)
32 JJ = JJ + 1
CALL READ (*110,*110,CASECC,LCSE(JJ),1,0,I)
IF (SUBID .EQ. -1) SUBID = LCSE(JJ)
IF (LCSE(JJ) .EQ. SUBID) GO TO 35
CALL FWDREC (*110,CASECC)
GO TO 32
35 LCSE(1) = LCSE(JJ)
CALL READ (*110,*125,CASECC,LCSE(2),199,0,I)
LENCC = LCSE(166)
LSEM = LCSE(LENCC)
NSET = LCSE(LENCC-1)
IF (LSEM .GT. 0) CALL READ (*110,*125,CASECC,CORE(I81),LSEM,0,I)
I81 = I81 + LSEM
BGN = I81
END = I81
37 CALL READ (*40,*40,CASECC,CORE(I81),2,0,I)
JMP = CORE(I81+1)
CORE(I81+2) = JJ
I81 = I81 + 3
CALL READ (*110,*125,CASECC,CORE(I81),JMP,0,I)
NSET = NSET + 1
I81 = I81 + JMP
GO TO 37
C
C SET CARD
C
40 WRITE (NOUT,43)
43 FORMAT (//,' ENTER A BLANK, OR A SET CARD (SEE USER MANUAL P. ',
1 '2.3-44)', /,' E.G. SET 101 = 1, 5 THRU 20')
45 CORE(I81) = IEOR
NOGO = 0
CALL XREAD (*40,CARD)
IF (CARD(1).EQ.BLANK .AND. CARD(2).EQ.BLANK) GO TO 60
WRITE (LU,77) CARD
IF (CARD(1) .NE. DEBUG1) GO TO 46
J = LSHIFT(1,20)
IF (CARD(2) .EQ. DEBUG2) SWTCH1 = ORF(J,SWTCH1)
J = COMPLF(J)
IF (CARD(2) .EQ. DEBUG3) SWTCH1 = ANDF(J,SWTCH1)
DEBUG = .FALSE.
IF (CARD(2) .EQ. DEBUG2) DEBUG = .TRUE.
GO TO 40
46 IB = I81
NZZ = NZ - I81
CALL XRCARD (CORE(I81),NZZ,CARD(1))
IF (CORE(I81+8) .NE. ALL) GO TO 47
CORE(I81 ) = CORE(I81+4)
CORE(I81+1) = 1
CORE(I81+2) = JJ
CORE(I81+3) =-1
I81 = I81 + 4
GO TO 50
47 ICC = 1
CALL IFP1C (I81,NZZ)
C
C CONTINUATION CARDS FOR SET ARE READ IN BY IFP1C
C
IF (NOGO .EQ. 0) GO TO 50
I81 = IB
GO TO 40
50 NSET = NSET + 1
WRITE (NOUT,52) CORE(IB)
52 FORMAT (/,' THIS NEW SET',I6,' IS DEFINED FOR LOCAL USE ONLY',
1 //,' ENTER A BLANK, OR ANOTHER SET CARD')
KK = 55
IF (DEBUG) WRITE (6,55) KK,I81
55 FORMAT (' ONLINS/',I2,4X,'I81 =',I7)
GO TO 45
C
C SET DATA - FROM CORE(BGN) THRU CORE(END)
C
60 END = I81 - 1
NZZ = NZ - I81
C
C SCAN CARD
C
70 WRITE (NOUT,72)
72 FORMAT (//,' ENTER A BLANK, OR A SCAN CARD (SEE USER MANUAL P.2.3-
141A', /,' E.G. SCAN (STRESS,CBAR,AXIAL,SA/MAX) = 15, SET 102',
2 /,' SCAN (FORCE,3,ROD,2) = +2000.,-1500.',
3 /,' SCAN (HELP)' )
C
75 JUMPH = 0
CALL XREAD (*70,CARD)
IF (CARD(1).EQ.STOP .AND. CARD(2).EQ.BLANK) GO TO 135
IF (CARD(1).EQ.BLANK .AND. CARD(2).EQ.BLANK) GO TO 90
WRITE (LU,77) CARD
77 FORMAT (20A4)
IB = I81
CALL XRCARD (CORE(I81),NZZ,CARD(1))
CALL IFP1H (I81,NZZ,JUMPH)
IF (NOGO .NE. 0) GO TO 80
IF (JUMPH .EQ. 0) GO TO 82
CALL IFP1H (0,0,2)
80 I81 = IB
IF (NOGO) 70,75,70
C
82 J = CORE(IB)
IF (ISCAN .EQ. 0) ISCAN = J
IF (ISCAN .EQ. J) ISCAN = 30000000
WRITE (NOUT,85)
85 FORMAT (/,' ENTER A BLANK, OR ANOTHER SCAN CARD')
KK = 87
IF (DEBUG) WRITE (6,55) KK,I81
GO TO 75
C
C MOVE SET AND SCAN DATA TO THE END OF CASECC ARRAY IN /ZZIFP1/
C THEN, MOVE THE ENTIRE CASECC DATA (SET AND SCAN INCLUDED) TO
C THE END OF THE OPEN CORE. FINALLY, MOVE THE SAME DATA BLOCK
C TO THE BEGINNING OF THE OPEN CORE SPACE IN /ZZSCAN/ FOR SCAN
C OPERATION
C
90 L = LENCC
IF (I81 .LE. NWPC1) GO TO 100
J = BGN + 2
I81 = I81 - 1
DO 95 I = NWPC1,I81
IF (I .NE. J) GO TO 92
J = J + CORE(J-1) + 3
GO TO 95
92 L = L + 1
LCSE(L) = CORE(I)
95 CONTINUE
J = LCORE
DO 96 I = 1,L
LCSE(J) = LCSE(I)
96 J = J - 1
IF (I .GT. J) CALL MESAGE (+8,0,NAME)
J = LCORE
DO 97 I = 1,L
Z(I) = LCSE(J)
97 J = J - 1
IF (DEBUG) WRITE (6,99) (Z(I),I=1,L)
99 FORMAT (//,' Z(1...200+) =', (/4X,10I7))
100 IF (LX .GT. 0) LX = L
C
IF (ISCAN .EQ. 20000000) GO TO 103
IF (Z(25) .EQ. 0) GO TO 140
C
C STRESS SCAN
C
Z(24) =-1
Z(25) = 1
Z(26) = 1
103 IF (ISCAN .NE. 20000000) GO TO 105
IF (Z(28) .EQ. 0) GO TO 150
C
C FORCE SCAN
C
Z(27) =-1
Z(28) = 1
Z(29) = 1
105 IF (INTRA .GT. 10) OUTTAP = LU
RETURN
C
110 JJ = JJ - 1
WRITE (NOUT,115) SUBID,(Z(I),I=1,JJ)
115 FORMAT (//,' SUBCASE',I5,' NOT FOUND',
1 //,' EXISTING SUBCASES ARE -', (/5X,10I7))
GO TO 15
C
125 CALL MESAGE (+2,CASECC,NAME)
GO TO 105
135 RETURN 1
C
140 WRITE (NOUT,145)
145 FORMAT (//,' STRESS OUTPUT FILE NOT AVAILABLE FOR SCAN',//)
GO TO 75
150 WRITE (NOUT,155)
155 FORMAT (//,' FORCE OUTPUT FILE NOT AVAILABLE FOR SCAN',//)
GO TO 75
END
|
