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!|| element_mod ../common_source/modules/elements/element_mod.F90
38!|| mat_elem_mod ../common_source/modules/mat_elem/mat_elem_mod.F90
39!|| message_mod ../engine/share/message_module/message_mod.F
40!|| table_mod ../engine/share/modules/table_mod.F
41!|| timer_mod ../engine/source/system/timer_mod.F90
42!||====================================================================
43 SUBROUTINE suforc3(TIMERS, ELBUF_STR,
44 1 LFT ,LLT ,NFT ,NEL ,IXS ,
45 2 PM ,GEO ,IPM ,IGEO ,X ,
46 3 A ,AR ,V ,VR ,W ,
47 4 D ,MS ,IN ,TF ,NPF ,
48 5 BUFMAT ,IPARG ,IPARTS ,PARTSAV ,MAT_PARAM,
49 6 FSKY ,FR_WAVE ,IADS ,EANI ,STIFN ,
50 7 STIFR ,FX ,FY ,FZ ,IFAILURE,
51 8 MTN ,IGTYP ,NPT ,JSMS ,MSSA ,
52 9 DMELS ,ITASK ,IOUTPRT ,JTHE ,TABLE ,
53 A IDTMINS ,DTFACS ,DTMINS)
54C-----------------------------------------------
55C M o d u l e s
56C-----------------------------------------------
57 USE timer_mod
58 USE table_mod
59 USE mat_elem_mod
60 USE message_mod
61 USE elbufdef_mod
62 use element_mod , only : nixs
63C-----------------------------------------------
64C I m p l i c i t T y p e s
65C-----------------------------------------------
66#include "implicit_f.inc"
67#include "comlock.inc"
68C-----------------------------------------------
69C G l o b a l P a r a m e t e r s
70C-----------------------------------------------
71#include "mvsiz_p.inc"
72C-----------------------------------------------
73C C o m m o n B l o c k s
74C-----------------------------------------------
75#include "com01_c.inc"
76#include "com08_c.inc"
77#include "parit_c.inc"
78#include "units_c.inc"
79#include "param_c.inc"
80#include "userlib.inc"
81#include "com04_c.inc"
82C-----------------------------------------------
83C D u m m y A r g u m e n t s
84C-----------------------------------------------
85 TYPE(timer_), INTENT(INOUT) :: TIMERS
86 INTEGER LFT, LLT,NEL,NFT,MTN,IGTYP,IFAILURE,NPT, JSMS,IOUTPRT,JTHE
87 INTEGER IXS(NIXS,*), IPARG(*), NPF(*),IADS(8,*),
88 . IPARTS(*), IGEO(NPROPGI,*), IPM(NPROPMI,*),ITASK
89 INTEGER ,INTENT(IN) :: IDTMINS
90 my_real ,INTENT(IN) :: DTFACS
91 my_real ,INTENT(IN) :: DTMINS
92C REAL
93C REAL
94 my_real
95 . pm(npropm,*), geo(npropg,*), x(*), a(*), v(*), ms(*), w(*),
96 . ar(*), vr(*), in(*),d(*),tf(*), bufmat(*),fr_wave(*),
97 . partsav(*),stifn(*), stifr(*), fsky(*),eani(*),
98 . fx(mvsiz,8),fy(mvsiz,8),fz(mvsiz,8),
99 . mssa(*), dmels(*)
100 TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_STR
101 TYPE (TTABLE) , DIMENSION(NTABLE) :: TABLE
102 TYPE (MATPARAM_STRUCT_) ,DIMENSION(NUMMAT) ,INTENT(IN) :: MAT_PARAM
103C-----------------------------------------------
104C L o c a l V a r i a b l e s
105C-----------------------------------------------
106 INTEGER I,J,NF1,NUPARAM,IG,IGT,
107 . NUVAR,NUVARP,II(6)
108C-----
109 INTEGER IMAT(MVSIZ),SID(MVSIZ),IPROP(MVSIZ),NC(MVSIZ,8)
110 my_real
111 . mx(mvsiz,8),my(mvsiz,8) , mz(mvsiz,8),
112 . sti(mvsiz),stir(mvsiz), viscm(mvsiz) ,viscr(mvsiz)
113 my_real
114 . off(mvsiz) ,fr_w_e(mvsiz),
115 . xx(mvsiz,8), yy(mvsiz,8), zz(mvsiz,8),
116 . ux(mvsiz,8), uy(mvsiz,8), uz(mvsiz,8),
117 . vx(mvsiz,8), vy(mvsiz,8), vz(mvsiz,8),
118 . vrx(mvsiz,8),vry(mvsiz,8),vrz(mvsiz,8),sig_loc(6,nel),
119 . eint_loc(mvsiz),vol_loc(mvsiz),off_loc(mvsiz),rho_loc(mvsiz)
120 TYPE(g_bufel_) ,POINTER :: GBUF
121 my_real,
122 . DIMENSION(:),POINTER :: UVAR
123!
124 CHARACTER OPTION*256
125 INTEGER SIZE
126C-----------------------------------------------
127C S o u r c e L i n e s
128C=======================================================================
129 GBUF => elbuf_str%GBUF
130 uvar => elbuf_str%GBUF%VAR
131 nf1=nft+1
132!
133 DO i=1,6
134 ii(i) = nel*(i-1)
135 ENDDO
136!
137C-----------
138C GATHER NODAL VARIABLES
139 CALL sucoor3(ixs(1,nf1),x ,v,vr,w,d,fr_wave ,fr_w_e ,
140 . xx ,yy ,zz, ux ,uy ,uz ,
141 . vx ,vy ,vz, vrx ,vry ,vrz,
142 . gbuf%OFF,off, nc,sid,imat,iprop)
143 nuvar = elbuf_str%GBUF%G_NUVAR
144 nuparam = ipm(9,imat(1))
145C-----------
146 ig =iprop(1)
147 igt=igeo(11,ig)
148 IF (igt>=29)THEN
149 nuvarp=nint(geo(25,ig))
150 ELSE
151 nuvarp=0
152 ENDIF
153C----------------------------
154C INTERNAL FORCES
155C----------------------------
156 IF(igtyp==29)THEN
157 DO i=lft,llt
158 sig_loc(1,i) = gbuf%SIG(ii(1)+i)
159 sig_loc(2,i) = gbuf%SIG(ii(2)+i)
160 sig_loc(3,i) = gbuf%SIG(ii(3)+i)
161 sig_loc(4,i) = gbuf%SIG(ii(4)+i)
162 sig_loc(5,i) = gbuf%SIG(ii(5)+i)
163 sig_loc(6,i) = gbuf%SIG(ii(6)+i)
164 eint_loc(i) = gbuf%EINT(i)
165 vol_loc(i) = gbuf%VOL(i)
166 off_loc(i) = gbuf%OFF(i)
167 rho_loc(i) = gbuf%RHO(i)
168
169 ENDDO
170 IF (userl_avail>0)THEN
171 CALL eng_userlib_suser(igtyp,
172 1 nel ,nuvar ,iprop(1),imat(1),sid ,tt ,dt1 ,
173 2 eint_loc,vol_loc,uvar,fr_w_e,off_loc,rho_loc,sig_loc ,
174 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),
175 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),
176 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),
177 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),
178 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),
179 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),
180 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),
181 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),
182 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),
183 c vrx(1,1),vrx(1,2),vrx(1,3),vrx(1,4),
184 c vrx(1,5),vrx(1,6),vrx(1,7),vrx(1,8),
185 d vry(1,1),vry(1,2),vry(1,3),vry(1,4),
186 d vry(1,5),vry(1,6),vry(1,7),vry(1,8),
187 e vrz(1,1),vrz(1,2),vrz(1,3),vrz(1,4),
188 e vrz(1,5),vrz(1,6),vrz(1,7),vrz(1,8),
189 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),
190 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),
191 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),
192 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),
193 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),
194 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),
195 l sti ,stir ,viscm ,viscr)
196 IF(nfilsol/=0) THEN
197 CALL sfillopt(
198 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
199 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
200 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
201 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
202 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
203 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
204 7 fz(1,7), fz(1,8), nel)
205 CALL sfillopt(
206 1 gbuf%FILL,stir, mx(1,1), mx(1,2),
207 2 mx(1,3), mx(1,4), mx(1,5), mx(1,6),
208 3 mx(1,7), mx(1,8), my(1,1), my(1,2),
209 4 my(1,3), my(1,4), my(1,5), my(1,6),
210 5 my(1,7), my(1,8), mz(1,1), mz(1,2),
211 6 mz(1,3), mz(1,4), mz(1,5), mz(1,6),
212 7 mz(1,7), mz(1,8), nel)
213 END IF
214 ELSE
215 ! ----------------
216 ! ERROR to be printed & exit
217 option='/PROP/USER1 - SOLID'
218 size=len_trim(option)
219 CALL ancmsg(msgid=257,c1=option(1:size),anmode=aninfo)
220 CALL arret(2)
221 ! ----------------
222 ENDIF ! IF (USERL_AVAIL)
223 DO i=lft,llt
224 gbuf%SIG(ii(1)+i) = sig_loc(1,i)
225 gbuf%SIG(ii(2)+i) = sig_loc(2,i)
226 gbuf%SIG(ii(3)+i) = sig_loc(3,i)
227 gbuf%SIG(ii(4)+i) = sig_loc(4,i)
228 gbuf%SIG(ii(5)+i) = sig_loc(5,i)
229 gbuf%SIG(ii(6)+i) = sig_loc(6,i)
230 gbuf%EINT(i) = eint_loc(i)
231 gbuf%VOL(i) = vol_loc(i)
232 gbuf%OFF(i) = off_loc(i)
233 gbuf%RHO(i) = rho_loc(i)
234 ENDDO
235
236 ELSEIF(igtyp==30)THEN
237 DO i=lft,llt
238 sig_loc(1,i) = gbuf%SIG(ii(1)+i)
239 sig_loc(2,i) = gbuf%SIG(ii(2)+i)
240 sig_loc(3,i) = gbuf%SIG(ii(3)+i)
241 sig_loc(4,i) = gbuf%SIG(ii(4)+i)
242 sig_loc(5,i) = gbuf%SIG(ii(5)+i)
243 sig_loc(6,i) = gbuf%SIG(ii(6)+i)
244 eint_loc(i) = gbuf%EINT(i)
245 vol_loc(i) = gbuf%VOL(i)
246 off_loc(i) = gbuf%OFF(i)
247 rho_loc(i) = gbuf%RHO(i)
248 ENDDO
249 IF (userl_avail>0)THEN
250 CALL eng_userlib_suser(igtyp,
251 1 nel ,nuvar ,iprop(1),imat(1),sid ,tt ,dt1 ,
252 2 eint_loc,vol_loc,uvar,fr_w_e,off_loc,rho_loc,sig_loc ,
253 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),
254 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),
255 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),
256 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),
257 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),
258 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),
259 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),
260 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),
261 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),
262 c vrx(1,1),vrx(1,2),vrx(1,3),vrx(1,4),
263 c vrx(1,5),vrx(1,6),vrx(1,7),vrx(1,8),
264 d vry(1,1),vry(1,2),vry(1,3),vry(1,4),
265 d vry(1,5),vry(1,6),vry(1,7),vry(1,8),
266 e vrz(1,1),vrz(1,2),vrz(1,3),vrz(1,4),
267 e vrz(1,5),vrz(1,6),vrz(1,7),vrz(1,8),
268 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),
269 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),
270 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),
271 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),
272 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),
273 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),
274 l sti ,stir ,viscm ,viscr)
275 IF(nfilsol/=0) THEN
276 CALL sfillopt(
277 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
278 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
279 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
280 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
281 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
282 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
283 7 fz(1,7), fz(1,8), nel)
284 CALL sfillopt(
285 1 gbuf%FILL,stir, mx(1,1), mx(1,2),
286 2 mx(1,3), mx(1,4), mx(1,5), mx(1,6),
287 3 mx(1,7), mx(1,8), my(1,1), my(1,2),
288 4 my(1,3), my(1,4), my(1,5), my(1,6),
289 5 my(1,7), my(1,8), mz(1,1), mz(1,2),
290 6 mz(1,3), mz(1,4), mz(1,5), mz(1,6),
291 7 mz(1,7), mz(1,8), nel)
292 END IF
293 ELSE
294 ! ----------------
295 ! ERROR to be printed & exit
296 option='/PROP/USER2 - SOLID'
297 size=len_trim(option)
298 CALL ancmsg(msgid=257,c1=option(1:size),anmode=aninfo)
299 CALL arret(2)
300 ! ----------------
301 ENDIF ! IF (USERL_AVAIL)
302 DO i=lft,llt
303 gbuf%SIG(ii(1)+i) = sig_loc(1,i)
304 gbuf%SIG(ii(2)+i) = sig_loc(2,i)
305 gbuf%SIG(ii(3)+i) = sig_loc(3,i)
306 gbuf%SIG(ii(4)+i) = sig_loc(4,i)
307 gbuf%SIG(ii(5)+i) = sig_loc(5,i)
308 gbuf%SIG(ii(6)+i) = sig_loc(6,i)
309 gbuf%EINT(i) = eint_loc(i)
310 gbuf%VOL(i) = vol_loc(i)
311 gbuf%OFF(i) = off_loc(i)
312 gbuf%RHO(i) = rho_loc(i)
313 ENDDO
314
315 ELSEIF(igtyp==31)THEN
316 DO i=lft,llt
317 sig_loc(1,i) = gbuf%SIG(ii(1)+i)
318 sig_loc(2,i) = gbuf%SIG(ii(2)+i)
319 sig_loc(3,i) = gbuf%SIG(ii(3)+i)
320 sig_loc(4,i) = gbuf%SIG(ii(4)+i)
321 sig_loc(5,i) = gbuf%SIG(ii(5)+i)
322 sig_loc(6,i) = gbuf%SIG(ii(6)+i)
323 eint_loc(i) = gbuf%EINT(i)
324 vol_loc(i) = gbuf%VOL(i)
325 off_loc(i) = gbuf%OFF(i)
326 rho_loc(i) = gbuf%RHO(i)
327 ENDDO
328 IF (userl_avail>0)THEN
329 CALL eng_userlib_suser(igtyp,
330 1 nel ,nuvar ,iprop(1),imat(1),sid ,tt ,dt1 ,
331 2 eint_loc,vol_loc,uvar,fr_w_e,off_loc,rho_loc,sig_loc ,
332 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),
333 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),
334 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),
335 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),
336 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),
337 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),
338 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),
339 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),
340 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),
341 c vrx(1,1),vrx(1,2),vrx(1,3),vrx(1,4),
342 c vrx(1,5),vrx(1,6),vrx(1,7),vrx(1,8),
343 d vry(1,1),vry(1,2),vry(1,3),vry(1,4),
344 d vry(1,5),vry(1,6),vry(1,7),vry(1,8),
345 e vrz(1,1),vrz(1,2),vrz(1,3),vrz(1,4),
346 e vrz(1,5),vrz(1,6),vrz(1,7),vrz(1,8),
347 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),
348 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),
349 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),
350 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),
351 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),
352 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),
353 l sti ,stir ,viscm ,viscr)
354 IF(nfilsol/=0) THEN
355 CALL sfillopt(
356 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
357 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
358 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
359 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
360 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
361 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
362 7 fz(1,7), fz(1,8), nel)
363 CALL sfillopt(
364 1 gbuf%FILL,stir, mx(1,1), mx(1,2),
365 2 mx(1,3), mx(1,4), mx(1,5), mx(1,6),
366 3 mx(1,7), mx(1,8), my(1,1), my(1,2),
367 4 my(1,3), my(1,4), my(1,5), my(1,6),
368 5 my(1,7), my(1,8), mz(1,1), mz(1,2),
369 6 mz(1,3), mz(1,4), mz(1,5), mz(1,6),
370 7 mz(1,7), mz(1,8), nel)
371 END IF
372 ELSE
373 ! ----------------
374 ! ERROR to be printed & exit
375 option='/PROP/USER3 - SOLID'
376 size=len_trim(option)
377 CALL ancmsg(msgid=257,c1=option(1:size),anmode=aninfo)
378 CALL arret(2)
379 ! ----------------
380 ENDIF ! IF (USERL_AVAIL)
381 DO i=lft,llt
382 gbuf%SIG(ii(1)+i) = sig_loc(1,i)
383 gbuf%SIG(ii(2)+i) = sig_loc(2,i)
384 gbuf%SIG(ii(3)+i) = sig_loc(3,i)
385 gbuf%SIG(ii(4)+i) = sig_loc(4,i)
386 gbuf%SIG(ii(5)+i) = sig_loc(5,i)
387 gbuf%SIG(ii(6)+i) = sig_loc(6,i)
388 gbuf%EINT(i) = eint_loc(i)
389 gbuf%VOL(i) = vol_loc(i)
390 gbuf%OFF(i) = off_loc(i)
391 gbuf%RHO(i) = rho_loc(i)
392 ENDDO
393
394 ELSEIF (igtyp == 43) THEN
395C--------------------------
396C-----------
397 fx = zero
398 fy = zero
399 fz = zero
400 mx = zero
401 my = zero
402 mz = zero
403 CALL suser43(timers,
404 1 elbuf_str ,iout ,iprop(1),imat(1),sid ,tt ,dt1 ,fr_w_e,
405 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),
406 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),
407 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),
408 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),
409 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),
410 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),
411 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),
412 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),
413 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),
414 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),
415 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),
416 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),
417 h sti ,stir ,viscm ,viscr ,partsav,iparts ,bufmat ,ioutprt,
418 l ifailure,npf ,tf ,ipm ,igeo ,npt ,nel ,jsms ,
419 m dmels ,pm ,geo ,itask ,jthe ,table ,mat_param ,
420 n idtmins,dtfacs ,dtmins)
421 IF(nfilsol/=0) THEN
422 CALL sfillopt(
423 1 gbuf%FILL,sti, fx(1,1), fx(1,2),
424 2 fx(1,3), fx(1,4), fx(1,5), fx(1,6),
425 3 fx(1,7), fx(1,8), fy(1,1), fy(1,2),
426 4 fy(1,3), fy(1,4), fy(1,5), fy(1,6),
427 5 fy(1,7), fy(1,8), fz(1,1), fz(1,2),
428 6 fz(1,3), fz(1,4), fz(1,5), fz(1,6),
429 7 fz(1,7), fz(1,8), nel)
430 END IF
431C
432 ENDIF
433C--------------------------------------------
434C Front wave
435C--------------------------------------------
436 IF(ifrwv/=0)THEN
437#include "lockon.inc"
438 DO j=1,8
439 DO i=lft,llt
440 IF(fr_wave(nc(i,j))==zero)fr_wave(nc(i,j))=-fr_w_e(i)
441 ENDDO
442 ENDDO
443#include "lockoff.inc"
444 ENDIF
445C----------------------------
446 IF (iparit == 0) THEN
447 CALL sucumu3(
448 . a ,ar ,nc ,stifn ,stifr ,sti ,stir ,
449 . fx ,fy ,fz ,mx ,my ,mz )
450 ELSE
451 CALL sucumu3p(fsky,fsky,iads(1,nf1),sti,stir,
452 . fx ,fy ,fz ,mx ,my ,mz )
453 ENDIF
454C-----------
455 RETURN
456 END
457
458
459!||====================================================================
460!|| sucumu3 ../engine/source/user_interface/suforc3.F
461!||--- called by ------------------------------------------------------
462!|| suforc3 ../engine/source/user_interface/suforc3.F
463!||====================================================================
464 SUBROUTINE sucumu3(A ,AR ,NC ,STIFN ,STIFR ,
465 . STI ,STIR ,FX ,FY ,FZ ,
466 . MX ,MY ,MZ )
467C-----------------------------------------------
468C I m p l i c i t T y p e s
469C-----------------------------------------------
470#include "implicit_f.inc"
471C-----------------------------------------------
472C G l o b a l P a r a m e t e r s
473C-----------------------------------------------
474#include "mvsiz_p.inc"
475C-----------------------------------------------
476C D u m m y A r g u m e n t s
477C-----------------------------------------------
478 INTEGER NC(MVSIZ,8)
479C REAL
480 my_real
481 . A(3,*),AR(3,*),STIFN(*),STI(*),STIFR(*),STIR(*),
482 . FX(MVSIZ,8),FY(MVSIZ,8),FZ(MVSIZ,8),
483 . MX(MVSIZ,8),MY(MVSIZ,8),MZ(MVSIZ,8)
484C-----------------------------------------------
485C C o m m o n B l o c k s
486C-----------------------------------------------
487#include "vect01_c.inc"
488#include "com01_c.inc"
489C-----------------------------------------------
490C L o c a l V a r i a b l e s
491C-----------------------------------------------
492 INTEGER I,J,K
493C=======================================================================
494 DO J=1,8
495 do i=lft,llt
496 k = nc(i,j)
497 a(1,k) = a(1,k) + fx(i,j)
498 a(2,k) = a(2,k) + fy(i,j)
499 a(3,k) = a(3,k) + fz(i,j)
500 stifn(k)= stifn(k)+ sti(i)
501 ENDDO
502 ENDDO
503c
504 IF (iroddl > 0) THEN
505 DO j=1,8
506 DO i=lft,llt
507 k = nc(i,j)
508 ar(1,k) = ar(1,k) + mx(i,j)
509 ar(2,k) = ar(2,k) + my(i,j)
510 ar(3,k) = ar(3,k) + mz(i,j)
511 stifr(k)= stifr(k)+ stir(i)
512 ENDDO
513 ENDDO
514 ENDIF
515C-----------
516 RETURN
517 END
518!||====================================================================
519!|| sucumu3p ../engine/source/user_interface/suforc3.F
520!||--- called by ------------------------------------------------------
521!|| suforc3 ../engine/source/user_interface/suforc3.F
522!||====================================================================
523 SUBROUTINE sucumu3p(FSKY,FSKYV,IADS,STI,STIR,
524 . FX,FY,FZ,MX,MY,MZ)
525C-----------------------------------------------
526C I m p l i c i t T y p e s
527C-----------------------------------------------
528#include "implicit_f.inc"
529C-----------------------------------------------
530C G l o b a l P a r a m e t e r s
531C-----------------------------------------------
532#include "mvsiz_p.inc"
533C-----------------------------------------------
534C C o m m o n B l o c k s
535C-----------------------------------------------
536#include "vect01_c.inc"
537#include "com01_c.inc"
538#include "parit_c.inc"
539C-----------------------------------------------
540C D u m m y A r g u m e n t s
541C-----------------------------------------------
542C REAL
543 my_real
544 . sti(*),stir(*),
545 . fx(mvsiz,8),fy(mvsiz,8),fz(mvsiz,8),
546 . mx(mvsiz,8),my(mvsiz,8),mz(mvsiz,8)
547 my_real
548 . fskyv(lsky,8),fsky(8,lsky)
549 INTEGER IADS(8,*)
550C-----------------------------------------------
551C L o c a l V a r i a b l e s
552C-----------------------------------------------
553 INTEGER I, K, J
554C=======================================================================
555 IF (IVECTOR == 1) then
556 DO j=1,8
557#include "vectorize.inc"
558 DO i=lft,llt
559 k = iads(j,i)
560 fskyv(k,1)=fx(i,j)
561 fskyv(k,2)=fy(i,j)
562 fskyv(k,3)=fz(i,j)
563 fskyv(k,7)=sti(i)
564 ENDDO
565 ENDDO
566 ELSE
567 DO j=1,8
568 DO i=lft,llt
569 k = iads(j,i)
570 fsky(1,k)=fx(i,j)
571 fsky(2,k)=fy(i,j)
572 fsky(3,k)=fz(i,j)
573 fsky(7,k)=sti(i)
574 ENDDO
575 ENDDO
576 ENDIF
577c
578 IF (iroddl > 0) THEN
579 IF (ivector == 1) THEN
580 DO j=1,8
581#include "vectorize.inc"
582 DO i=lft,llt
583 k = iads(j,i)
584 fskyv(k,4)=mx(i,j)
585 fskyv(k,5)=my(i,j)
586 fskyv(k,6)=mz(i,j)
587 fskyv(k,8)=stir(i)
588 ENDDO
589 ENDDO
590 ELSE
591 DO j=1,8
592 DO i=lft,llt
593 k = iads(j,i)
594 fsky(4,k)=mx(i,j)
595 fsky(5,k)=my(i,j)
596 fsky(6,k)=mz(i,j)
597 fsky(8,k)=stir(i)
598 ENDDO
599 ENDDO
600 ENDIF
601 ENDIF
602c-----------
603 RETURN
604 END
605!||====================================================================
606!|| sucoor3 ../engine/source/user_interface/suforc3.F
607!||--- called by ------------------------------------------------------
608!|| suforc3 ../engine/source/user_interface/suforc3.F
609!||--- uses -----------------------------------------------------
610!|| element_mod ../common_source/modules/elements/element_mod.F90
611!||====================================================================
612 SUBROUTINE sucoor3(IXS,X ,V,VR,W,D,FR_WAVE ,FR_W_E ,
613 . XX , YY, ZZ, UX, UY, UZ,
614 . VX , VY, VZ, VRX, VRY, VRZ,
615 . OFFG,OFF,NC ,SID,IMAT,IPROP)
616 use element_mod , only : nixs
617C-----------------------------------------------
618C I m p l i c i t T y p e s
619C-----------------------------------------------
620#include "implicit_f.inc"
621C-----------------------------------------------
622C G l o b a l P a r a m e t e r s
623C-----------------------------------------------
624#include "mvsiz_p.inc"
625C-----------------------------------------------
626C C o m m o n B l o c k s
627C-----------------------------------------------
628#include "com01_c.inc"
629#include "vect01_c.inc"
630C-----------------------------------------------
631C D u m m y A r g u m e n t s
632C-----------------------------------------------
633 INTEGER IXS(NIXS,*)
634C REAL
635 my_real
636 . X(3,*),V(3,*),VR(3,*),W(3,*), D(3,*),FR_WAVE(*) ,FR_W_E(*),
637 . XX(MVSIZ,*), YY(MVSIZ,*), ZZ(MVSIZ,*),
638 . UX(MVSIZ,*), UY(MVSIZ,*), UZ(MVSIZ,*),
639 . VX(MVSIZ,*), VY(MVSIZ,*), VZ(MVSIZ,*),
640 . VRX(MVSIZ,8),VRY(MVSIZ,8),VRZ(MVSIZ,8),
641 . OFFG(*),OFF(*)
642 INTEGER NC(MVSIZ,8), IMAT(*), SID(*),IPROP(*)
643C-----------------------------------------------
644C L o c a l V a r i a b l e s
645C-----------------------------------------------
646 INTEGER I, J
647C=======================================================================
648 DO I=lft,llt
649 iprop(i)=ixs(10,i)
650 sid(i) =ixs(11,i)
651 imat(i) =ixs(1,i)
652 off(i) = min(one,offg(i))
653 ENDDO
654C----------------------------
655 DO j=1,8
656 DO i=lft,llt
657 nc(i,j) = ixs(j+1,i)
658 xx(i,j) = x(1,nc(i,j))
659 yy(i,j) = x(2,nc(i,j))
660 zz(i,j) = x(3,nc(i,j))
661 ux(i,j) = d(1,nc(i,j))
662 uy(i,j) = d(2,nc(i,j))
663 uz(i,j) = d(3,nc(i,j))
664 vx(i,j) = v(1,nc(i,j))
665 vy(i,j) = v(2,nc(i,j))
666 vz(i,j) = v(3,nc(i,j))
667 ENDDO
668 ENDDO
669 IF (iroddl > 0) THEN
670 DO j=1,8
671 DO i=lft,llt
672 vrx(i,j)= vr(1,nc(i,j))
673 vry(i,j)= vr(2,nc(i,j))
674 vrz(i,j)= vr(3,nc(i,j))
675 ENDDO
676 ENDDO
677 ELSE
678 vrx = zero
679 vry = zero
680 vrz = zero
681 ENDIF
682C--------------------------------------------
683C Front wave
684C--------------------------------------------
685 IF(ifrwv/=0)THEN
686 DO i=lft,llt
687 fr_w_e(i)=zero
688 ENDDO
689 DO j=1,8
690 DO i=lft,llt
691 fr_w_e(i)=max(fr_w_e(i),fr_wave(nc(i,j)))
692 ENDDO
693 ENDDO
694 ENDIF
695C-----------
696 RETURN
697 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:1257
table_mod
Definition table_mod.F:113
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:895
arret
subroutine arret(nn)
Definition arret.F:86
sucumu3
subroutine sucumu3(a, ar, nc, stifn, stifr, sti, stir, fx, fy, fz, mx, my, mz)
Definition suforc3.F:467
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:616
sucumu3p
subroutine sucumu3p(fsky, fskyv, iads, sti, stir, fx, fy, fz, mx, my, mz)
Definition suforc3.F:525
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:54
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