OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
law108_upd.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "com04_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine law108_upd (iout, titr, uparam, npc, pld, nfunc, ifunc, mat_id, func_id, pm)

Function/Subroutine Documentation

◆ law108_upd()

subroutine law108_upd ( integer iout,
character(len=nchartitle) titr,
uparam,
integer, dimension(*) npc,
pld,
integer nfunc,
integer, dimension(nfunc) ifunc,
integer mat_id,
integer, dimension(*) func_id,
pm )

Definition at line 33 of file law108_upd.F.

36 USE message_mod
37C-----------------------------------------------
38C M o d u l e s
39C-----------------------------------------------
40 USE message_mod
41 USE table_mod
42 USE names_and_titles_mod , ONLY : nchartitle
43C-----------------------------------------------
44C I m p l i c i t T y p e s
45C-----------------------------------------------
46#include "implicit_f.inc"
47C-----------------------------------------------
48C C o m m o n B l o c k s
49C-----------------------------------------------
50#include "param_c.inc"
51#include "com04_c.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 CHARACTER(LEN=NCHARTITLE) :: TITR
56 INTEGER MAT_ID,IOUT,NFUNC
57 INTEGER NPC(*), FUNC_ID(*),IFUNC(NFUNC)
58 my_real uparam(*),pld(*),pm(npropm)
59C-----------------------------------------------
60C L o c a l V a r i a b l e s
61C-----------------------------------------------
62 INTEGER I,K,FUNC,NUPAR,NPT, J,J1,NUPARAM,
63 . IF1,IF2,IF3,IF4,IC1,IC2,II,JJ,LOAD,UNLOAD,
64 . NP1,NP2,ILENG2,I7,I11,I13,I15,I5,I4,K1,
65 . K2,I14,IFUN
66 my_real
67 . xk, hard,x1,x2,y1,y2,lscale,xk_ini,yfac,
68 . x0,emax,dx,dy,y0,deri,h,xscale,alpha1,alpha2,
69 . s1,s2,t1,t2,ty,sx,xx1,yy1,dydx,dtds,f_x0
70 CHARACTER(LEN=NCHARTITLE) :: TITR1
71C=======================================================================
72c Transform FUNC_ID -> Function number , leakmat only
73cc
74c---------------------------------------------------------------
75c
76c traction X
77c
78 i7 = 40 ! 4 + 6*6
79 i11 = 64 ! 4 + 10*6
80 i13 = 76 ! 4 + 12*6
81 i15 = 90 ! 4 + 14*6 + 2
82 func = ifunc(1)
83 lscale = uparam(i7 + 1)
84 xk = uparam(i11 + 1)
85 hard = uparam(i13 + 1)
86 xk_ini = xk
87 IF (func > 0 ) THEN
88 npt=(npc(func+1)-npc(func))/2
89 f_x0 = zero
90 DO j=2,npt
91 j1 =2*(j-2)
92 x1 = pld(npc(func) + j1)
93 y1 = pld(npc(func) + j1 + 1)
94 x2 = pld(npc(func) + j1 + 2)
95 y2 = pld(npc(func) + j1 + 3)
96 xk = max(xk,lscale*(y2 - y1)/(x2 - x1))
97! Determination of force offset for H=9 - F(0)
98 IF (x1 == zero) THEN
99 f_x0 = y1
100 ELSEIF (x2 == zero) THEN
101 f_x0 = y2
102 ELSEIF ((x1 < zero).AND.(x2 > zero)) THEN
103 f_x0 = y1 + lscale*(y2 - y1)*(zero - x1)/(x2 - x1)
104 ENDIF
105 ENDDO
106 IF(hard/=0)THEN
107 IF(xk_ini<xk)THEN
108!! CALL FRETITL2(TITR1,NOM_OPT(LNOPT1-LTITR+1,FUNC),LTITR)
109 CALL ancmsg(msgid=1640, !
110 . msgtype=msgwarning,
111 . anmode=aninfo_blind_1,
112 . i1=mat_id,
113 . c1=titr,
114 . i2=npc(nfunct+func+1),
115!! . C2=TITR1,
116 . r1=xk_ini,
117 . r2=xk,
118 . r3=xk)
119 ENDIF
120 ENDIF
121 uparam(i11 + 1)= xk
122 IF (nint(hard)==9) uparam(i15 + 1)= f_x0
123 ENDIF
124!-----------------
125 ! Traction Y
126!-----------------
127 func = ifunc(2)
128 lscale = uparam(i7 + 2)
129 xk = uparam(i11 + 2)
130 hard = uparam(i13 + 2)
131 xk_ini = xk
132 IF (func > 0 ) THEN
133 npt=(npc(func+1)-npc(func))/2
134 f_x0 = zero
135 DO j=2,npt
136 j1 =2*(j-2)
137 x1 = pld(npc(func) + j1)
138 y1 = pld(npc(func) + j1 + 1)
139 x2 = pld(npc(func) + j1 + 2)
140 y2 = pld(npc(func) + j1 + 3)
141 xk = max(xk,lscale*(y2 - y1)/(x2 - x1))
142! Determination of force offset for H=9 - F(0)
143 IF (x1 == zero) THEN
144 f_x0 = y1
145 ELSEIF (x2 == zero) THEN
146 f_x0 = y2
147 ELSEIF ((x1 < zero).AND.(x2 > zero)) THEN
148 f_x0 = y1 + lscale*(y2 - y1)*(zero - x1)/(x2 - x1)
149 ENDIF
150 ENDDO
151 IF(hard/=0)THEN
152 IF(xk_ini<xk)THEN
153!! CALL FRETITL2(TITR1,NOM_OPT(LNOPT1-LTITR+1,FUNC),LTITR)
154 CALL ancmsg(msgid=1640,
155 . msgtype=msgwarning,
156 . anmode=aninfo_blind_1,
157 . i1=mat_id,
158 . c1=titr,
159 . i2=npc(nfunct+func+1),
160!! . C2=TITR1,
161 . r1=xk_ini,
162 . r2=xk,
163 . r3=xk)
164 ENDIF
165 ENDIF
166 uparam(i11 + 2) = xk
167 IF (nint(hard)==9) uparam(i15 + 2)= f_x0
168 ENDIF
169!-----------------
170 ! Traction Z
171!-----------------
172 func = ifunc(3)
173 lscale = uparam(i7 + 3)
174 xk = uparam(i11 + 3)
175 hard = uparam(i13 + 3)
176 xk_ini = xk
177 IF (func > 0 ) THEN
178 npt=(npc(func+1)-npc(func))/2
179 f_x0 = zero
180 DO j=2,npt
181 j1 =2*(j-2)
182 x1 = pld(npc(func) + j1)
183 y1 = pld(npc(func) + j1 + 1)
184 x2 = pld(npc(func) + j1 + 2)
185 y2 = pld(npc(func) + j1 + 3)
186 xk = max(xk,lscale*(y2 - y1)/(x2 - x1))
187! Determination of force offset for H=9 - F(0)
188 IF (x1 == zero) THEN
189 f_x0 = y1
190 ELSEIF (x2 == zero) THEN
191 f_x0 = y2
192 ELSEIF ((x1 < zero).AND.(x2 > zero)) THEN
193 f_x0 = y1 + lscale*(y2 - y1)*(zero - x1)/(x2 - x1)
194 ENDIF
195 ENDDO
196 IF(hard/=0)THEN
197 IF(xk_ini<xk)THEN
198!! CALL FRETITL2(TITR1,NOM_OPT(LNOPT1-LTITR+1,FUNC),LTITR)
199 CALL ancmsg(msgid=1640, !
200 . msgtype=msgwarning,
201 . anmode=aninfo_blind_1,
202 . i1=mat_id,
203 . c1=titr,
204 . i2=npc(nfunct+func+1),
205!! . C2=TITR1,
206 . r1=xk_ini,
207 . r2=xk,
208 . r3=xk)
209 ENDIF
210 ENDIF
211 uparam(i11 + 3)= xk
212 IF (nint(hard)==9) uparam(i15 + 3)= f_x0
213 ENDIF
214!-----------------
215 ! Torsion xx
216!-----------------
217 func = ifunc(4)
218 lscale = uparam(i7 + 4)
219 xk = uparam(i11 + 4)
220 hard = uparam(i13 + 4)
221 xk_ini = xk
222 IF (func > 0 ) THEN
223 npt=(npc(func+1)-npc(func))/2
224 f_x0 = zero
225 DO j=2,npt
226 j1 =2*(j-2)
227 x1 = pld(npc(func) + j1)
228 y1 = pld(npc(func) + j1 + 1)
229 x2 = pld(npc(func) + j1 + 2)
230 y2 = pld(npc(func) + j1 + 3)
231 xk = max(xk,lscale*(y2 - y1)/(x2 - x1))
232! Determination of force offset for H=9 - F(0)
233 IF (x1 == zero) THEN
234 f_x0 = y1
235 ELSEIF (x2 == zero) THEN
236 f_x0 = y2
237 ELSEIF ((x1 < zero).AND.(x2 > zero)) THEN
238 f_x0 = y1 + lscale*(y2 - y1)*(zero - x1)/(x2 - x1)
239 ENDIF
240 ENDDO
241 IF(hard/=0)THEN
242 IF(xk_ini<xk)THEN
243!! CALL FRETITL2(TITR1,NOM_OPT(LNOPT1-LTITR+1,FUNC),LTITR)
244 CALL ancmsg(msgid=1640, !
245 . msgtype=msgwarning,
246 . anmode=aninfo_blind_1,
247 . i1=mat_id,
248 . c1=titr,
249 . i2=npc(nfunct+func+1),
250!! . C2=TITR1,
251 . r1=xk_ini,
252 . r2=xk,
253 . r3=xk)
254 ENDIF
255 ENDIF
256 uparam(i11 + 4)= xk
257 IF (nint(hard)==9) uparam(i15 + 4)= f_x0
258 ENDIF
259!-----------------
260 ! Rotation YY
261!-----------------
262 func = ifunc(5)
263 lscale = uparam(i7 + 5)
264 xk = uparam(i11 + 5)
265 hard = uparam(i13 + 5)
266 xk_ini = xk
267 IF (func > 0 ) THEN
268 npt=(npc(func+1)-npc(func))/2
269 f_x0 = zero
270 DO j=2,npt
271 j1 =2*(j-2)
272 x1 = pld(npc(func) + j1)
273 y1 = pld(npc(func) + j1 + 1)
274 x2 = pld(npc(func) + j1 + 2)
275 y2 = pld(npc(func) + j1 + 3)
276 xk = max(xk,lscale*(y2 - y1)/(x2 - x1))
277! determination of force offset for h=9 - f(0)
278 IF (x1 == zero) THEN
279 f_x0 = y1
280 ELSEIF (x2 == zero) THEN
281 f_x0 = y2
282 ELSEIF ((x1 < zero).AND.(x2 > zero)) THEN
283 f_x0 = y1 + lscale*(y2 - y1)*(zero - x1)/(x2 - x1)
284 ENDIF
285 ENDDO
286 IF(hard/=0)THEN
287 IF(xk_ini<xk)THEN
288!! CALL FRETITL2(TITR1,NOM_OPT(LNOPT1-LTITR+1,FUNC),LTITR)
289 CALL ancmsg(msgid=1640, !
290 . msgtype=msgwarning,
291 . anmode=aninfo_blind_1,
292 . i1=mat_id,
293 . c1=titr,
294 . i2=npc(nfunct+func+1),
295!! . C2=TITR1,
296 . r1=xk_ini,
297 . r2=xk,
298 . r3=xk)
299
300 ENDIF
301 ENDIF
302 uparam(i11 + 5)= xk
303 IF (nint(hard)==9) uparam(i15 + 5)= f_x0
304 ENDIF
305!-----------------
306 ! Rotation ZZ
307!-----------------
308 func = ifunc(6)
309 lscale = uparam(i7 + 6)
310 xk = uparam(i11 + 6)
311 hard = uparam(i13 + 6)
312 xk_ini = xk
313 IF (func > 0 ) THEN
314 npt=(npc(func+1)-npc(func))/2
315 f_x0 = zero
316 DO j=2,npt
317 j1 =2*(j-2)
318 x1 = pld(npc(func) + j1)
319 y1 = pld(npc(func) + j1 + 1)
320 x2 = pld(npc(func) + j1 + 2)
321 y2 = pld(npc(func) + j1 + 3)
322 xk = max(xk,lscale*(y2 - y1)/(x2 - x1))
323! Determination of force offset for H=9 - F(0)
324 IF (x1 == zero) THEN
325 f_x0 = y1
326 ELSEIF (x2 == zero) THEN
327 f_x0 = y2
328 ELSEIF ((x1 < zero).AND.(x2 > zero)) THEN
329 f_x0 = y1 + lscale*(y2 - y1)*(zero - x1)/(x2 - x1)
330 ENDIF
331 ENDDO
332 IF(hard/=0)THEN
333 IF(xk_ini<xk)THEN
334!! CALL FRETITL2(TITR1,NOM_OPT(LNOPT1-LTITR+1,FUNC),LTITR)
335 CALL ancmsg(msgid=1640, !
336 . msgtype=msgwarning,
337 . anmode=aninfo_blind_1,
338 . i1=mat_id,
339 . c1=titr,
340 . i2=npc(nfunct+func+1),
341!! . C2=TITR1,
342 . r1=xk_ini,
343 . r2=xk,
344 . r3=xk)
345 ENDIF
346 ENDIF
347 uparam(i11 + 6)= xk
348 IF (nint(hard)==9) uparam(i15 + 6)= f_x0
349 ENDIF
350Cz
351 ! update of max slope
352C
353c --------
354!compute max slope for ifunc3
355 i5 = 44 ! 4 + 4*10
356 i7 = 40 ! 4 + 4*6
357 i13 = 76 ! 4 + 12*6
358 i14 = 82 ! 4 + 13*6
359 if1 = 0
360 if3 = 12
361 if4 = 18
362 DO j=1, 6
363 yfac = uparam(i5 + j) !
364 ifun = ifunc(if4 + j) !
365 IF (ifun /= 0)THEN
366 ic1 = npc(ifun)
367 ic2 = npc(ifun+1)
368 x0 = pld(ic1)
369 emax = zero
370 DO ii = ic1,ic2-4,2
371 jj = ii+2
372 dx = pld(jj) - x0
373 dy = pld(jj+1) - pld(ii+1)
374 y0 = pld(ii+1)
375 y1 = pld(jj+1)
376 deri = yfac * dy / dx
377 x1 = pld(jj)
378 emax = max(emax, deri)
379 x0 = pld(jj)
380 ENDDO
381 uparam(i14+j) = emax
382 ENDIF
383 ENDDO
384C
385 DO 100 j=1, 6
386 h= uparam(i13 + j )
387 IF (h == 7)THEN
388 xscale=uparam(7+j)
389 load =ifunc(if1 + j)
390 unload=ifunc(if3 + j)
391 np1 = (npc(load+1)-npc(load))*half
392 np2 = (npc(unload+1)-npc(unload))*half
393 alpha1=zero
394 alpha2=zero
395c---
396 DO jj=2,np1
397 j1=2*(jj-2)
398 s1=pld(npc(load)+j1)*xscale
399 s2=pld(npc(load)+j1+2)*xscale
400 t1=pld(npc(load)+j1+1)
401 t2=pld(npc(load)+j1+3)
402 ty=zero
403 sx=zero
404 IF ( s1<=zero .AND.s2> zero)alpha1=(t2-t1)/(s2-s1)
405 DO k=2,np2
406 k1=2*(k-2)
407 xx1=pld(npc(unload)+k1)*xscale
408 x2=pld(npc(unload)+k1+2)*xscale
409 yy1=pld(npc(unload)+k1+1)
410 y2=pld(npc(unload)+k1+3)
411 IF ( xx1<=zero .AND.x2> zero)alpha2=(y2-yy1)/(x2-xx1)
412 IF (y2>=t1 .AND.yy1<=t2.AND.x2>=s1.AND.xx1<=s2)THEN
413 dydx = (y2-yy1) / (x2-xx1)
414 dtds = (t2-t1) / (s2-s1)
415 IF (dydx > dtds) THEN
416 sx = (t1-yy1-dtds*s1+dydx*xx1) / (dydx-dtds)
417 ty = t1 + dtds*(sx - s1)
418 ENDIF
419 IF (ty/=zero .AND. sx/=zero )THEN
420 IF (ty>=yy1.AND.ty<=y2.AND.sx>=xx1.AND.sx<=x2
421 . .AND.sx>=s2.AND.ty<=t2)THEN
422 CALL ancmsg(msgid=982,
423 . msgtype=msgerror,
424 . anmode=aninfo_blind_1,
425 . c1=titr,
426 . i1=unload,
427 . i2=load)
428 GOTO 100
429 ENDIF
430 ENDIF
431 ENDIF
432 ENDDO
433 ENDDO
434 IF(alpha2>=alpha1)THEN
435 CALL ancmsg(msgid=982,
436 . msgtype=msgerror,
437 . anmode=aninfo_blind_1,
438 . c1=titr,
439 . i1=unload,
440 . i2=load)
441 ENDIF
442 ENDIF
443 100 CONTINUE
444c-----------
445 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
alpha2
#define alpha2
Definition eval.h:48
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
table_mod
Definition table_mod.F:112
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