OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
suforc3.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| suforc3 ../engine/source/user_interface/suforc3.F
25!||--- called by ------------------------------------------------------
26!|| forint ../engine/source/elements/forint.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!|| sfillopt ../engine/source/elements/solid/solide/sfillopt.F
31!|| sucoor3 ../engine/source/user_interface/suforc3.F
32!|| sucumu3 ../engine/source/user_interface/suforc3.F
33!|| sucumu3p ../engine/source/user_interface/suforc3.F
34!|| suser43 ../engine/source/elements/solid/sconnect/suser43.F
35!||--- uses -----------------------------------------------------
36!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
37!|| mat_elem_mod ../common_source/modules/mat_elem/mat_elem_mod.F90
38!|| message_mod ../engine/share/message_module/message_mod.F
39!|| table_mod ../engine/share/modules/table_mod.F
40!|| timer_mod ../engine/source/system/timer_mod.F90
41!||====================================================================
42 SUBROUTINE suforc3(TIMERS, ELBUF_STR,
43 1 LFT ,LLT ,NFT ,NEL ,IXS ,
44 2 PM ,GEO ,IPM ,IGEO ,X ,
45 3 A ,AR ,V ,VR ,W ,
46 4 D ,MS ,IN ,TF ,NPF ,
47 5 BUFMAT ,IPARG ,IPARTS ,PARTSAV ,MAT_PARAM,
48 6 FSKY ,FR_WAVE ,IADS ,EANI ,STIFN ,
49 7 STIFR ,FX ,FY ,FZ ,IFAILURE,
50 8 MTN ,IGTYP ,NPT ,JSMS ,MSSA ,
51 9 DMELS ,ITASK ,IOUTPRT ,JTHE ,TABLE ,
52 A IDTMINS ,DTFACS ,DTMINS)
53C-----------------------------------------------
54C M o d u l e s
55C-----------------------------------------------
56 USE timer_mod
57 USE table_mod
58 USE mat_elem_mod
59 USE message_mod
60 USE elbufdef_mod
61C-----------------------------------------------
62C I m p l i c i t T y p e s
63C-----------------------------------------------
64#include "implicit_f.inc"
65#include "comlock.inc"
66C-----------------------------------------------
67C G l o b a l P a r a m e t e r s
68C-----------------------------------------------
69#include "mvsiz_p.inc"
70C-----------------------------------------------
71C C o m m o n B l o c k s
72C-----------------------------------------------
73#include "com01_c.inc"
74#include "com08_c.inc"
75#include "parit_c.inc"
76#include "units_c.inc"
77#include "param_c.inc"
78#include "userlib.inc"
79#include "com04_c.inc"
80C-----------------------------------------------
81C D u m m y A r g u m e n t s
82C-----------------------------------------------
83 TYPE(timer_), INTENT(INOUT) :: TIMERS
84 INTEGER LFT, LLT,NEL,NFT,MTN,IGTYP,IFAILURE,NPT, JSMS,IOUTPRT,JTHE
85 INTEGER IXS(NIXS,*), IPARG(*), NPF(*),IADS(8,*),
86 . IPARTS(*), IGEO(NPROPGI,*), IPM(NPROPMI,*),ITASK
87 INTEGER ,INTENT(IN) :: IDTMINS
88 my_real ,INTENT(IN) :: DTFACS
89 my_real ,INTENT(IN) :: DTMINS
90C REAL
91C REAL
92 my_real
93 . pm(npropm,*), geo(npropg,*), x(*), a(*), v(*), ms(*), w(*),
94 . ar(*), vr(*), in(*),d(*),tf(*), bufmat(*),fr_wave(*),
95 . partsav(*),stifn(*), stifr(*), fsky(*),eani(*),
96 . fx(mvsiz,8),fy(mvsiz,8),fz(mvsiz,8),
97 . mssa(*), dmels(*)
98 TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_STR
99 TYPE (TTABLE) , DIMENSION(NTABLE) :: TABLE
100 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
101C-----------------------------------------------
102C L o c a l V a r i a b l e s
103C-----------------------------------------------
104 INTEGER I,J,NF1,IFLAG,NUPARAM,IG,IGT,
105 . NUVAR,NUVARP,II(6)
106C-----
107 INTEGER IMAT(MVSIZ),SID(MVSIZ),IPROP(MVSIZ),NC(MVSIZ,8)
108 my_real
109 . mx(mvsiz,8),my(mvsiz,8) , mz(mvsiz,8),
110 . sti(mvsiz),stir(mvsiz), viscm(mvsiz) ,viscr(mvsiz)
111 my_real
112 . off(mvsiz) , rhoo(mvsiz),fr_w_e(mvsiz),
113 . xx(mvsiz,8), yy(mvsiz,8), zz(mvsiz,8),
114 . ux(mvsiz,8), uy(mvsiz,8), uz(mvsiz,8),
115 . vx(mvsiz,8), vy(mvsiz,8), vz(mvsiz,8),
116 . vrx(mvsiz,8),vry(mvsiz,8),vrz(mvsiz,8),sig_loc(6,nel),
117 . eint_loc(mvsiz),vol_loc(mvsiz),off_loc(mvsiz),rho_loc(mvsiz)
118 TYPE(g_bufel_) ,POINTER :: GBUF
119 my_real,
120 . DIMENSION(:),POINTER :: UVAR
121!
122 CHARACTER OPTION*256
123 INTEGER SIZE
124C-----------------------------------------------
125C S o u r c e L i n e s
126C=======================================================================
127 GBUF => elbuf_str%GBUF
128 uvar => elbuf_str%GBUF%VAR
129 nf1=nft+1
130!
131 DO i=1,6
132 ii(i) = nel*(i-1)
133 ENDDO
134!
135C-----------
136C GATHER NODAL VARIABLES
137 CALL sucoor3(ixs(1,nf1),x ,v,vr,w,d,fr_wave ,fr_w_e ,
138 . xx ,yy ,zz, ux ,uy ,uz ,
139 . vx ,vy ,vz, vrx ,vry ,vrz,
140 . gbuf%OFF,off, nc,sid,imat,iprop)
141 nuvar = elbuf_str%GBUF%G_NUVAR
142 nuparam = ipm(9,imat(1))
143C-----------
144 ig =iprop(1)
145 igt=igeo(11,ig)
146 IF (igt>=29)THEN
147 nuvarp=nint(geo(25,ig))
148 ELSE
149 nuvarp=0
150 ENDIF
151C----------------------------
152C INTERNAL FORCES
153C----------------------------
154 IF(igtyp==29)THEN
155 DO i=lft,llt
156 sig_loc(1,i) = gbuf%SIG(ii(1)+i)
157 sig_loc(2,i) = gbuf%SIG(ii(2)+i)
158 sig_loc(3,i) = gbuf%SIG(ii(3)+i)
159 sig_loc(4,i) = gbuf%SIG(ii(4)+i)
160 sig_loc(5,i) = gbuf%SIG(ii(5)+i)
161 sig_loc(6,i) = gbuf%SIG(ii(6)+i)
162 eint_loc(i) = gbuf%EINT(i)
163 vol_loc(i) = gbuf%VOL(i)
164 off_loc(i) = gbuf%OFF(i)
165 rho_loc(i) = gbuf%RHO(i)
166
167 ENDDO
168 IF (userl_avail>0)THEN
169 CALL eng_userlib_suser(igtyp,
170 1 nel ,nuvar ,iprop(1),imat(1),sid ,tt ,dt1 ,
171 2 eint_loc,vol_loc,uvar,fr_w_e,off_loc,rho_loc,sig_loc ,
172 3 xx(1,1),xx(1,2),xx(1,3),xx(1,4),xx(1,5),xx(1,6),xx(1,7),xx(1,8),
173 4 yy(1,1),yy(1,2),yy(1,3),yy(1,4),yy(1,5),yy(1,6),yy(1,7),yy(1,8),
174 5 zz(1,1),zz(1,2),zz(1,3),zz(1,4),zz(1,5),zz(1,6),zz(1,7),zz(1,8),
175 6 ux(1,1),ux(1,2),ux(1,3),ux(1,4),ux(1,5),ux(1,6),ux(1,7),ux(1,8),
176 7 uy(1,1),uy(1,2),uy(1,3),uy(1,4),uy(1,5),uy(1,6),uy(1,7),uy(1,8),
177 8 uz(1,1),uz(1,2),uz(1,3),uz(1,4),uz(1,5),uz(1,6),uz(1,7),uz(1,8),
178 9 vx(1,1),vx(1,2),vx(1,3),vx(1,4),vx(1,5),vx(1,6),vx(1,7),vx(1,8),
179 a vy(1,1),vy(1,2),vy(1,3),vy(1,4),vy(1,5),vy(1,6),vy(1,7),vy(1,8),
180 b vz(1,1),vz(1,2),vz(1,3),vz(1,4),vz(1,5),vz(1,6),vz(1,7),vz(1,8),
181 c vrx(1,1),vrx(1,2),vrx(1,3),vrx(1,4),
182 c vrx(1,5),vrx(1,6),vrx(1,7),vrx(1,8),
183 d vry(1,1),vry(1,2),vry(1,3),vry(1,4),
184 d vry(1,5),vry(1,6),vry(1,7),vry(1,8),
185 e vrz(1,1),vrz(1,2),vrz(1,3),vrz(1,4),
186 e vrz(1,5),vrz(1,6),vrz(1,7),vrz(1,8),
187 f fx(1,1),fx(1,2),fx(1,3),fx(1,4),fx(1,5),fx(1,6),fx(1,7),fx(1,8),
188 g fy(1,1),fy(1,2),fy(1,3),fy(1,4),fy(1,5),fy(1,6),fy(1,7),fy(1,8),
189 h fz(1,1),fz(1,2),fz(1,3),fz(1,4),fz(1,5),fz(1,6),fz(1,7),fz(1,8),
190 i mx(1,1),mx(1,2),mx(1,3),mx(1,4),mx(1,5),mx(1,6),mx(1,7),mx(1,8),
191 j my(1,1),my(1,2),my(1,3),my(1,4),my(1,5),my(1,6),my(1,7),my(1,8),
192 k mz(1,1),mz(1,2),mz(1,3),mz(1,4),mz(1,5),mz(1,6),mz(1,7),mz(1,8),
193 l sti ,stir ,viscm ,viscr)
194 IF(nfilsol/=0) THEN
195 CALL sfillopt(
196 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
197 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
198 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
199 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
200 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
201 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
202 7 fz(1,7), fz(1,8), nel)
203 CALL sfillopt(
204 1 gbuf%FILL,stir, mx(1,1), mx(1,2),
205 2 mx(1,3), mx(1,4), mx(1,5), mx(1,6),
206 3 mx(1,7), mx(1,8), my(1,1), my(1,2),
207 4 my(1,3), my(1,4), my(1,5), my(1,6),
208 5 my(1,7), my(1,8), mz(1,1), mz(1,2),
209 6 mz(1,3), mz(1,4), mz(1,5), mz(1,6),
210 7 mz(1,7), mz(1,8), nel)
211 END IF
212 ELSE
213 ! ----------------
214 ! ERROR to be printed & exit
215 option='/PROP/USER1 - SOLID'
216 size=len_trim(option)
217 CALL ancmsg(msgid=257,c1=option(1:size),anmode=aninfo)
218 CALL arret(2)
219 ! ----------------
220 ENDIF ! IF (USERL_AVAIL)
221 DO i=lft,llt
222 gbuf%SIG(ii(1)+i) = sig_loc(1,i)
223 gbuf%SIG(ii(2)+i) = sig_loc(2,i)
224 gbuf%SIG(ii(3)+i) = sig_loc(3,i)
225 gbuf%SIG(ii(4)+i) = sig_loc(4,i)
226 gbuf%SIG(ii(5)+i) = sig_loc(5,i)
227 gbuf%SIG(ii(6)+i) = sig_loc(6,i)
228 gbuf%EINT(i) = eint_loc(i)
229 gbuf%VOL(i) = vol_loc(i)
230 gbuf%OFF(i) = off_loc(i)
231 gbuf%RHO(i) = rho_loc(i)
232 ENDDO
233
234 ELSEIF(igtyp==30)THEN
235 DO i=lft,llt
236 sig_loc(1,i) = gbuf%SIG(ii(1)+i)
237 sig_loc(2,i) = gbuf%SIG(ii(2)+i)
238 sig_loc(3,i) = gbuf%SIG(ii(3)+i)
239 sig_loc(4,i) = gbuf%SIG(ii(4)+i)
240 sig_loc(5,i) = gbuf%SIG(ii(5)+i)
241 sig_loc(6,i) = gbuf%SIG(ii(6)+i)
242 eint_loc(i) = gbuf%EINT(i)
243 vol_loc(i) = gbuf%VOL(i)
244 off_loc(i) = gbuf%OFF(i)
245 rho_loc(i) = gbuf%RHO(i)
246 ENDDO
247 IF (userl_avail>0)THEN
248 CALL eng_userlib_suser(igtyp,
249 1 nel ,nuvar ,iprop(1),imat(1),sid ,tt ,dt1 ,
250 2 eint_loc,vol_loc,uvar,fr_w_e,off_loc,rho_loc,sig_loc ,
251 3 xx(1,1),xx(1,2),xx(1,3),xx(1,4),xx(1,5),xx(1,6),xx(1,7),xx(1,8),
252 4 yy(1,1),yy(1,2),yy(1,3),yy(1,4),yy(1,5),yy(1,6),yy(1,7),yy(1,8),
253 5 zz(1,1),zz(1,2),zz(1,3),zz(1,4),zz(1,5),zz(1,6),zz(1,7),zz(1,8),
254 6 ux(1,1),ux(1,2),ux(1,3),ux(1,4),ux(1,5),ux(1,6),ux(1,7),ux(1,8),
255 7 uy(1,1),uy(1,2),uy(1,3),uy(1,4),uy(1,5),uy(1,6),uy(1,7),uy(1,8),
256 8 uz(1,1),uz(1,2),uz(1,3),uz(1,4),uz(1,5),uz(1,6),uz(1,7),uz(1,8),
257 9 vx(1,1),vx(1,2),vx(1,3),vx(1,4),vx(1,5),vx(1,6),vx(1,7),vx(1,8),
258 a vy(1,1),vy(1,2),vy(1,3),vy(1,4),vy(1,5),vy(1,6),vy(1,7),vy(1,8),
259 b vz(1,1),vz(1,2),vz(1,3),vz(1,4),vz(1,5),vz(1,6),vz(1,7),vz(1,8),
260 c vrx(1,1),vrx(1,2),vrx(1,3),vrx(1,4),
261 c vrx(1,5),vrx(1,6),vrx(1,7),vrx(1,8),
262 d vry(1,1),vry(1,2),vry(1,3),vry(1,4),
263 d vry(1,5),vry(1,6),vry(1,7),vry(1,8),
264 e vrz(1,1),vrz(1,2),vrz(1,3),vrz(1,4),
265 e vrz(1,5),vrz(1,6),vrz(1,7),vrz(1,8),
266 f fx(1,1),fx(1,2),fx(1,3),fx(1,4),fx(1,5),fx(1,6),fx(1,7),fx(1,8),
267 g fy(1,1),fy(1,2),fy(1,3),fy(1,4),fy(1,5),fy(1,6),fy(1,7),fy(1,8),
268 h fz(1,1),fz(1,2),fz(1,3),fz(1,4),fz(1,5),fz(1,6),fz(1,7),fz(1,8),
269 i mx(1,1),mx(1,2),mx(1,3),mx(1,4),mx(1,5),mx(1,6),mx(1,7),mx(1,8),
270 j my(1,1),my(1,2),my(1,3),my(1,4),my(1,5),my(1,6),my(1,7),my(1,8),
271 k mz(1,1),mz(1,2),mz(1,3),mz(1,4),mz(1,5),mz(1,6),mz(1,7),mz(1,8),
272 l sti ,stir ,viscm ,viscr)
273 IF(nfilsol/=0) THEN
274 CALL sfillopt(
275 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
276 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
277 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
278 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
279 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
280 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
281 7 fz(1,7), fz(1,8), nel)
282 CALL sfillopt(
283 1 gbuf%FILL,stir, mx(1,1), mx(1,2),
284 2 mx(1,3), mx(1,4), mx(1,5), mx(1,6),
285 3 mx(1,7), mx(1,8), my(1,1), my(1,2),
286 4 my(1,3), my(1,4), my(1,5), my(1,6),
287 5 my(1,7), my(1,8), mz(1,1), mz(1,2),
288 6 mz(1,3), mz(1,4), mz(1,5), mz(1,6),
289 7 mz(1,7), mz(1,8), nel)
290 END IF
291 ELSE
292 ! ----------------
293 ! ERROR to be printed & exit
294 option='/PROP/USER2 - SOLID'
295 size=len_trim(option)
296 CALL ancmsg(msgid=257,c1=option(1:size),anmode=aninfo)
297 CALL arret(2)
298 ! ----------------
299 ENDIF ! IF (USERL_AVAIL)
300 DO i=lft,llt
301 gbuf%SIG(ii(1)+i) = sig_loc(1,i)
302 gbuf%SIG(ii(2)+i) = sig_loc(2,i)
303 gbuf%SIG(ii(3)+i) = sig_loc(3,i)
304 gbuf%SIG(ii(4)+i) = sig_loc(4,i)
305 gbuf%SIG(ii(5)+i) = sig_loc(5,i)
306 gbuf%SIG(ii(6)+i) = sig_loc(6,i)
307 gbuf%EINT(i) = eint_loc(i)
308 gbuf%VOL(i) = vol_loc(i)
309 gbuf%OFF(i) = off_loc(i)
310 gbuf%RHO(i) = rho_loc(i)
311 ENDDO
312
313 ELSEIF(igtyp==31)THEN
314 DO i=lft,llt
315 sig_loc(1,i) = gbuf%SIG(ii(1)+i)
316 sig_loc(2,i) = gbuf%SIG(ii(2)+i)
317 sig_loc(3,i) = gbuf%SIG(ii(3)+i)
318 sig_loc(4,i) = gbuf%SIG(ii(4)+i)
319 sig_loc(5,i) = gbuf%SIG(ii(5)+i)
320 sig_loc(6,i) = gbuf%SIG(ii(6)+i)
321 eint_loc(i) = gbuf%EINT(i)
322 vol_loc(i) = gbuf%VOL(i)
323 off_loc(i) = gbuf%OFF(i)
324 rho_loc(i) = gbuf%RHO(i)
325 ENDDO
326 IF (userl_avail>0)THEN
327 CALL eng_userlib_suser(igtyp,
328 1 nel ,nuvar ,iprop(1),imat(1),sid ,tt ,dt1 ,
329 2 eint_loc,vol_loc,uvar,fr_w_e,off_loc,rho_loc,sig_loc ,
330 3 xx(1,1),xx(1,2),xx(1,3),xx(1,4),xx(1,5),xx(1,6),xx(1,7),xx(1,8),
331 4 yy(1,1),yy(1,2),yy(1,3),yy(1,4),yy(1,5),yy(1,6),yy(1,7),yy(1,8),
332 5 zz(1,1),zz(1,2),zz(1,3),zz(1,4),zz(1,5),zz(1,6),zz(1,7),zz(1,8),
333 6 ux(1,1),ux(1,2),ux(1,3),ux(1,4),ux(1,5),ux(1,6),ux(1,7),ux(1,8),
334 7 uy(1,1),uy(1,2),uy(1,3),uy(1,4),uy(1,5),uy(1,6),uy(1,7),uy(1,8),
335 8 uz(1,1),uz(1,2),uz(1,3),uz(1,4),uz(1,5),uz(1,6),uz(1,7),uz(1,8),
336 9 vx(1,1),vx(1,2),vx(1,3),vx(1,4),vx(1,5),vx(1,6),vx(1,7),vx(1,8),
337 a vy(1,1),vy(1,2),vy(1,3),vy(1,4),vy(1,5),vy(1,6),vy(1,7),vy(1,8),
338 b vz(1,1),vz(1,2),vz(1,3),vz(1,4),vz(1,5),vz(1,6),vz(1,7),vz(1,8),
339 c vrx(1,1),vrx(1,2),vrx(1,3),vrx(1,4),
340 c vrx(1,5),vrx(1,6),vrx(1,7),vrx(1,8),
341 d vry(1,1),vry(1,2),vry(1,3),vry(1,4),
342 d vry(1,5),vry(1,6),vry(1,7),vry(1,8),
343 e vrz(1,1),vrz(1,2),vrz(1,3),vrz(1,4),
344 e vrz(1,5),vrz(1,6),vrz(1,7),vrz(1,8),
345 f fx(1,1),fx(1,2),fx(1,3),fx(1,4),fx(1,5),fx(1,6),fx(1,7),fx(1,8),
346 g fy(1,1),fy(1,2),fy(1,3),fy(1,4),fy(1,5),fy(1,6),fy(1,7),fy(1,8),
347 h fz(1,1),fz(1,2),fz(1,3),fz(1,4),fz(1,5),fz(1,6),fz(1,7),fz(1,8),
348 i mx(1,1),mx(1,2),mx(1,3),mx(1,4),mx(1,5),mx(1,6),mx(1,7),mx(1,8),
349 j my(1,1),my(1,2),my(1,3),my(1,4),my(1,5),my(1,6),my(1,7),my(1,8),
350 k mz(1,1),mz(1,2),mz(1,3),mz(1,4),mz(1,5),mz(1,6),mz(1,7),mz(1,8),
351 l sti ,stir ,viscm ,viscr)
352 IF(nfilsol/=0) THEN
353 CALL sfillopt(
354 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
355 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
356 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
357 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
358 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
359 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
360 7 fz(1,7), fz(1,8), nel)
361 CALL sfillopt(
362 1 gbuf%FILL,stir, mx(1,1), mx(1,2),
363 2 mx(1,3), mx(1,4), mx(1,5), mx(1,6),
364 3 mx(1,7), mx(1,8), my(1,1), my(1,2),
365 4 my(1,3), my(1,4), my(1,5), my(1,6),
366 5 my(1,7), my(1,8), mz(1,1), mz(1,2),
367 6 mz(1,3), mz(1,4), mz(1,5), mz(1,6),
368 7 mz(1,7), mz(1,8), nel)
369 END IF
370 ELSE
371 ! ----------------
372 ! ERROR to be printed & exit
373 option='/PROP/USER3 - SOLID'
374 size=len_trim(option)
375 CALL ancmsg(msgid=257,c1=option(1:size),anmode=aninfo)
376 CALL arret(2)
377 ! ----------------
378 ENDIF ! IF (USERL_AVAIL)
379 DO i=lft,llt
380 gbuf%SIG(ii(1)+i) = sig_loc(1,i)
381 gbuf%SIG(ii(2)+i) = sig_loc(2,i)
382 gbuf%SIG(ii(3)+i) = sig_loc(3,i)
383 gbuf%SIG(ii(4)+i) = sig_loc(4,i)
384 gbuf%SIG(ii(5)+i) = sig_loc(5,i)
385 gbuf%SIG(ii(6)+i) = sig_loc(6,i)
386 gbuf%EINT(i) = eint_loc(i)
387 gbuf%VOL(i) = vol_loc(i)
388 gbuf%OFF(i) = off_loc(i)
389 gbuf%RHO(i) = rho_loc(i)
390 ENDDO
391
392 ELSEIF (igtyp == 43) THEN
393C--------------------------
394C-----------
395 fx = zero
396 fy = zero
397 fz = zero
398 mx = zero
399 my = zero
400 mz = zero
401 CALL suser43(timers,
402 1 elbuf_str ,iout ,iprop(1),imat(1),sid ,tt ,dt1 ,fr_w_e,
403 2 xx(1,1),xx(1,2),xx(1,3),xx(1,4),xx(1,5),xx(1,6),xx(1,7),xx(1,8),
404 3 yy(1,1),yy(1,2),yy(1,3),yy(1,4),yy(1,5),yy(1,6),yy(1,7),yy(1,8),
405 4 zz(1,1),zz(1,2),zz(1,3),zz(1,4),zz(1,5),zz(1,6),zz(1,7),zz(1,8),
406 5 ux(1,1),ux(1,2),ux(1,3),ux(1,4),ux(1,5),ux(1,6),ux(1,7),ux(1,8),
407 6 uy(1,1),uy(1,2),uy(1,3),uy(1,4),uy(1,5),uy(1,6),uy(1,7),uy(1,8),
408 7 uz(1,1),uz(1,2),uz(1,3),uz(1,4),uz(1,5),uz(1,6),uz(1,7),uz(1,8),
409 8 vx(1,1),vx(1,2),vx(1,3),vx(1,4),vx(1,5),vx(1,6),vx(1,7),vx(1,8),
410 9 vy(1,1),vy(1,2),vy(1,3),vy(1,4),vy(1,5),vy(1,6),vy(1,7),vy(1,8),
411 a vz(1,1),vz(1,2),vz(1,3),vz(1,4),vz(1,5),vz(1,6),vz(1,7),vz(1,8),
412 b fx(1,1),fx(1,2),fx(1,3),fx(1,4),fx(1,5),fx(1,6),fx(1,7),fx(1,8),
413 f fy(1,1),fy(1,2),fy(1,3),fy(1,4),fy(1,5),fy(1,6),fy(1,7),fy(1,8),
414 g fz(1,1),fz(1,2),fz(1,3),fz(1,4),fz(1,5),fz(1,6),fz(1,7),fz(1,8),
415 h sti ,stir ,viscm ,viscr ,partsav,iparts ,bufmat ,ioutprt,
416 l ifailure,npf ,tf ,ipm ,igeo ,npt ,nel ,jsms ,
417 m dmels ,pm ,geo ,itask ,jthe ,table ,mat_param ,
418 n idtmins,dtfacs ,dtmins)
419 IF(nfilsol/=0) THEN
420 CALL sfillopt(
421 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
422 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
423 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
424 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
425 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
426 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
427 7 fz(1,7), fz(1,8), nel)
428 END IF
429C
430 ENDIF
431C--------------------------------------------
432C Front wave
433C--------------------------------------------
434 IF(ifrwv/=0)THEN
435#include "lockon.inc"
436 DO j=1,8
437 DO i=lft,llt
438 IF(fr_wave(nc(i,j))==zero)fr_wave(nc(i,j))=-fr_w_e(i)
439 ENDDO
440 ENDDO
441#include "lockoff.inc"
442 ENDIF
443C----------------------------
444 IF (iparit == 0) THEN
445 CALL sucumu3(
446 . a ,ar ,nc ,stifn ,stifr ,sti ,stir ,
447 . fx ,fy ,fz ,mx ,my ,mz )
448 ELSE
449 CALL sucumu3p(fsky,fsky,iads(1,nf1),sti,stir,
450 . fx ,fy ,fz ,mx ,my ,mz )
451 ENDIF
452C-----------
453 RETURN
454 END
455
456
457!||====================================================================
458!|| sucumu3 ../engine/source/user_interface/suforc3.F
459!||--- called by ------------------------------------------------------
460!|| suforc3 ../engine/source/user_interface/suforc3.F
461!||====================================================================
462 SUBROUTINE sucumu3(A ,AR ,NC ,STIFN ,STIFR ,
463 . STI ,STIR ,FX ,FY ,FZ ,
464 . MX ,MY ,MZ )
465C-----------------------------------------------
466C I m p l i c i t T y p e s
467C-----------------------------------------------
468#include "implicit_f.inc"
469C-----------------------------------------------
470C G l o b a l P a r a m e t e r s
471C-----------------------------------------------
472#include "mvsiz_p.inc"
473C-----------------------------------------------
474C D u m m y A r g u m e n t s
475C-----------------------------------------------
476 INTEGER NC(MVSIZ,8)
477C REAL
478 my_real
479 . A(3,*),AR(3,*),STIFN(*),STI(*),STIFR(*),STIR(*),
480 . FX(MVSIZ,8),FY(MVSIZ,8),FZ(MVSIZ,8),
481 . MX(MVSIZ,8),MY(MVSIZ,8),MZ(MVSIZ,8)
482C-----------------------------------------------
483C C o m m o n B l o c k s
484C-----------------------------------------------
485#include "vect01_c.inc"
486#include "com01_c.inc"
487C-----------------------------------------------
488C L o c a l V a r i a b l e s
489C-----------------------------------------------
490 INTEGER I,J,K
491C=======================================================================
492 DO J=1,8
493 do i=lft,llt
494 k = nc(i,j)
495 a(1,k) = a(1,k) + fx(i,j)
496 a(2,k) = a(2,k) + fy(i,j)
497 a(3,k) = a(3,k) + fz(i,j)
498 stifn(k)= stifn(k)+ sti(i)
499 ENDDO
500 ENDDO
501c
502 IF (iroddl > 0) THEN
503 DO j=1,8
504 DO i=lft,llt
505 k = nc(i,j)
506 ar(1,k) = ar(1,k) + mx(i,j)
507 ar(2,k) = ar(2,k) + my(i,j)
508 ar(3,k) = ar(3,k) + mz(i,j)
509 stifr(k)= stifr(k)+ stir(i)
510 ENDDO
511 ENDDO
512 ENDIF
513C-----------
514 RETURN
515 END
516!||====================================================================
517!|| sucumu3p ../engine/source/user_interface/suforc3.F
518!||--- called by ------------------------------------------------------
519!|| suforc3 ../engine/source/user_interface/suforc3.F
520!||====================================================================
521 SUBROUTINE sucumu3p(FSKY,FSKYV,IADS,STI,STIR,
522 . FX,FY,FZ,MX,MY,MZ)
523C-----------------------------------------------
524C I m p l i c i t T y p e s
525C-----------------------------------------------
526#include "implicit_f.inc"
527C-----------------------------------------------
528C G l o b a l P a r a m e t e r s
529C-----------------------------------------------
530#include "mvsiz_p.inc"
531C-----------------------------------------------
532C C o m m o n B l o c k s
533C-----------------------------------------------
534#include "vect01_c.inc"
535#include "com01_c.inc"
536#include "parit_c.inc"
537C-----------------------------------------------
538C D u m m y A r g u m e n t s
539C-----------------------------------------------
540C REAL
541 my_real
542 . sti(*),stir(*),
543 . fx(mvsiz,8),fy(mvsiz,8),fz(mvsiz,8),
544 . mx(mvsiz,8),my(mvsiz,8),mz(mvsiz,8)
545 my_real
546 . fskyv(lsky,8),fsky(8,lsky)
547 INTEGER IADS(8,*)
548C-----------------------------------------------
549C L o c a l V a r i a b l e s
550C-----------------------------------------------
551 INTEGER I, II, K, J
552C=======================================================================
553 IF (IVECTOR == 1) then
554 DO j=1,8
555#include "vectorize.inc"
556 DO i=lft,llt
557 k = iads(j,i)
558 fskyv(k,1)=fx(i,j)
559 fskyv(k,2)=fy(i,j)
560 fskyv(k,3)=fz(i,j)
561 fskyv(k,7)=sti(i)
562 ENDDO
563 ENDDO
564 ELSE
565 DO j=1,8
566 DO i=lft,llt
567 k = iads(j,i)
568 fsky(1,k)=fx(i,j)
569 fsky(2,k)=fy(i,j)
570 fsky(3,k)=fz(i,j)
571 fsky(7,k)=sti(i)
572 ENDDO
573 ENDDO
574 ENDIF
575c
576 IF (iroddl > 0) THEN
577 IF (ivector == 1) THEN
578 DO j=1,8
579#include "vectorize.inc"
580 DO i=lft,llt
581 k = iads(j,i)
582 fskyv(k,4)=mx(i,j)
583 fskyv(k,5)=my(i,j)
584 fskyv(k,6)=mz(i,j)
585 fskyv(k,8)=stir(i)
586 ENDDO
587 ENDDO
588 ELSE
589 DO j=1,8
590 DO i=lft,llt
591 k = iads(j,i)
592 fsky(4,k)=mx(i,j)
593 fsky(5,k)=my(i,j)
594 fsky(6,k)=mz(i,j)
595 fsky(8,k)=stir(i)
596 ENDDO
597 ENDDO
598 ENDIF
599 ENDIF
600c-----------
601 RETURN
602 END
603!||====================================================================
604!|| sucoor3 ../engine/source/user_interface/suforc3.F
605!||--- called by ------------------------------------------------------
606!|| suforc3 ../engine/source/user_interface/suforc3.F
607!||====================================================================
608 SUBROUTINE sucoor3(IXS,X ,V,VR,W,D,FR_WAVE ,FR_W_E ,
609 . XX , YY, ZZ, UX, UY, UZ,
610 . VX , VY, VZ, VRX, VRY, VRZ,
611 . OFFG,OFF,NC ,SID,IMAT,IPROP)
612C-----------------------------------------------
613C I m p l i c i t T y p e s
614C-----------------------------------------------
615#include "implicit_f.inc"
616C-----------------------------------------------
617C G l o b a l P a r a m e t e r s
618C-----------------------------------------------
619#include "mvsiz_p.inc"
620C-----------------------------------------------
621C C o m m o n B l o c k s
622C-----------------------------------------------
623#include "com01_c.inc"
624#include "vect01_c.inc"
625C-----------------------------------------------
626C D u m m y A r g u m e n t s
627C-----------------------------------------------
628 INTEGER IXS(NIXS,*)
629C REAL
630 my_real
631 . X(3,*),V(3,*),VR(3,*),W(3,*), D(3,*),FR_WAVE(*) ,FR_W_E(*),
632 . XX(MVSIZ,*), YY(MVSIZ,*), ZZ(MVSIZ,*),
633 . UX(MVSIZ,*), UY(MVSIZ,*), UZ(MVSIZ,*),
634 . VX(MVSIZ,*), VY(MVSIZ,*), VZ(MVSIZ,*),
635 . VRX(MVSIZ,8),VRY(MVSIZ,8),VRZ(MVSIZ,8),
636 . OFFG(*),OFF(*)
637 INTEGER NC(MVSIZ,8), IMAT(*), SID(*),IPROP(*)
638C-----------------------------------------------
639C L o c a l V a r i a b l e s
640C-----------------------------------------------
641 INTEGER I, J
642C=======================================================================
643 DO I=lft,llt
644 iprop(i)=ixs(10,i)
645 sid(i) =ixs(11,i)
646 imat(i) =ixs(1,i)
647 off(i) = min(one,offg(i))
648 ENDDO
649C----------------------------
650 DO j=1,8
651 DO i=lft,llt
652 nc(i,j) = ixs(j+1,i)
653 xx(i,j) = x(1,nc(i,j))
654 yy(i,j) = x(2,nc(i,j))
655 zz(i,j) = x(3,nc(i,j))
656 ux(i,j) = d(1,nc(i,j))
657 uy(i,j) = d(2,nc(i,j))
658 uz(i,j) = d(3,nc(i,j))
659 vx(i,j) = v(1,nc(i,j))
660 vy(i,j) = v(2,nc(i,j))
661 vz(i,j) = v(3,nc(i,j))
662 ENDDO
663 ENDDO
664 IF (iroddl > 0) THEN
665 DO j=1,8
666 DO i=lft,llt
667 vrx(i,j)= vr(1,nc(i,j))
668 vry(i,j)= vr(2,nc(i,j))
669 vrz(i,j)= vr(3,nc(i,j))
670 ENDDO
671 ENDDO
672 ELSE
673 vrx = zero
674 vry = zero
675 vrz = zero
676 ENDIF
677C--------------------------------------------
678C Front wave
679C--------------------------------------------
680 IF(ifrwv/=0)THEN
681 DO i=lft,llt
682 fr_w_e(i)=zero
683 ENDDO
684 DO j=1,8
685 DO i=lft,llt
686 fr_w_e(i)=max(fr_w_e(i),fr_wave(nc(i,j)))
687 ENDDO
688 ENDDO
689 ENDIF
690C-----------
691 RETURN
692 END
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
message_mod
Definition message_mod.F:1249
table_mod
Definition table_mod.F:112
sfillopt
subroutine sfillopt(fill, sti, f11, f21, f31, f12, f22, f32, f13, f23, f33, f14, f24, f34, f15, f25, f35, f16, f26, f36, f17, f27, f37, f18, f28, f38, nel)
Definition sfillopt.F:43
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87
sucumu3
subroutine sucumu3(a, ar, nc, stifn, stifr, sti, stir, fx, fy, fz, mx, my, mz)
Definition suforc3.F:465
sucoor3
subroutine sucoor3(ixs, x, v, vr, w, d, fr_wave, fr_w_e, xx, yy, zz, ux, uy, uz, vx, vy, vz, vrx, vry, vrz, offg, off, nc, sid, imat, iprop)
Definition suforc3.F:612
sucumu3p
subroutine sucumu3p(fsky, fskyv, iads, sti, stir, fx, fy, fz, mx, my, mz)
Definition suforc3.F:523
suforc3
subroutine suforc3(timers, elbuf_str, lft, llt, nft, nel, ixs, pm, geo, ipm, igeo, x, a, ar, v, vr, w, d, ms, in, tf, npf, bufmat, iparg, iparts, partsav, mat_param, fsky, fr_wave, iads, eani, stifn, stifr, fx, fy, fz, ifailure, mtn, igtyp, npt, jsms, mssa, dmels, itask, ioutprt, jthe, table, idtmins, dtfacs, dtmins)
Definition suforc3.F:53
suser43
subroutine suser43(timers, elbuf_str, iout, iprop, imat, ngl, time, timestep, fr_wave, xx1, xx2, xx3, xx4, xx5, xx6, xx7, xx8, yy1, yy2, yy3, yy4, yy5, yy6, yy7, yy8, zz1, zz2, zz3, zz4, zz5, zz6, zz7, zz8, ux1, ux2, ux3, ux4, ux5, ux6, ux7, ux8, uy1, uy2, uy3, uy4, uy5, uy6, uy7, uy8, uz1, uz2, uz3, uz4, uz5, uz6, uz7, uz8, vx1, vx2, vx3, vx4, vx5, vx6, vx7, vx8, vy1, vy2, vy3, vy4, vy5, vy6, vy7, vy8, vz1, vz2, vz3, vz4, vz5, vz6, vz7, vz8, fx1, fx2, fx3, fx4, fx5, fx6, fx7, fx8, fy1, fy2, fy3, fy4, fy5, fy6, fy7, fy8, fz1, fz2, fz3, fz4, fz5, fz6, fz7, fz8, stifm, stifr, viscm, viscr, partsav, iparts, bufmat, ioutprt, ifailure, npf, tf, ipm, igeo, npg, nel, jsms, dmels, pm, geo, itask, jthe, table, mat_param, idtmins, dtfacs, dtmins)
Definition suser43.F:71