OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rbypid.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "scr03_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "spmd_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine rbypid (iparg, ipari, ms, in, ixs, ixq, ixc, ixt, ixp, ixr, skew, itab, itabm1, iskwn, npby, onof, itag, lpby, x, v, vr, rby, ixtg, npbyi, rbyi, lpbyi, iacts, fr_rby2, nrb, onfelt, weight, partsav, ipartc, nsn, elbuf_tab, pri_off)

Function/Subroutine Documentation

◆ rbypid()

subroutine rbypid ( integer, dimension(nparg,*) iparg,
integer, dimension(*) ipari,
ms,
in,
integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
skew,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
integer, dimension(liskn,*) iskwn,
integer, dimension(*) npby,
integer onof,
integer, dimension(*) itag,
integer, dimension(*) lpby,
x,
v,
vr,
rby,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) npbyi,
rbyi,
integer, dimension(*) lpbyi,
integer iacts,
integer, dimension(3,*) fr_rby2,
integer nrb,
integer onfelt,
integer, dimension(*) weight,
partsav,
integer, dimension(*) ipartc,
integer nsn,
type(elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, intent(in) pri_off )

Definition at line 41 of file rbypid.F.

49C-----------------------------------------------
50C M o d u l e s
51C-----------------------------------------------
52 USE elbufdef_mod
53 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "com01_c.inc"
62#include "com04_c.inc"
63#include "param_c.inc"
64#include "scr03_c.inc"
65#include "units_c.inc"
66#include "task_c.inc"
67#include "spmd_c.inc"
68C-----------------------------------------------
69C D u m m y A r g u m e n t s
70C-----------------------------------------------
71 INTEGER IPARG(NPARG,*), IPARI(*), IXS(NIXS,*), IXQ(NIXQ,*),
72 . IXC(NIXC,*), IXT(NIXT,*), IXP(NIXP,*), IXR(NIXR,*),
73 . ITAB(*), ITABM1(*),IXTG(NIXTG,*),NRB, NSN,
74 . ISKWN(LISKN,*), NPBY(*),ITAG(*),LPBY(*),NPBYI(*) ,LPBYI(*),
75 . WEIGHT(*), FR_RBY2(3,*), IPARTC(*)
76 INTEGER ONOF,IACTS, ONFELT, IWIOUT
77 INTEGER, INTENT(IN) :: PRI_OFF
78C REAL
79 my_real
80 . skew(lskew,*),ms(*),in(*),partsav(npsav,*),
81 . x(3,*),v(3,*),vr(3,*),rby(*),rbyi(nrby,*)
82 TYPE(ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
83C-----------------------------------------------
84C L o c a l V a r i a b l e s
85C-----------------------------------------------
86 INTEGER I, II, NG, ITY, NEL, NFT, IAD, IGOF, N, NI,
87 . M, ISPH, NALL,MLW, K, PMAIN, TAG,
88 . MX,ICOMM(NSPMD+2),ISTRAIN,NPT,IHBE, ID
89C REAL
90 my_real
91 . xmom, ymom, zmom,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,
92 . ig1,ig2,ig3,ig4,ig5,ig6,ig7,ig8,ig9,
93 . xxmom, yymom, zzmom, wa1, wa2, wa3,
94 .
95 .
96 . f1(nsn), f2(nsn), f3(nsn), f4(nsn),
97 . f5(nsn), f6(nsn), off_old
98 DOUBLE PRECISION RBF6(6,6)
99 my_real,
100 . DIMENSION(:), POINTER :: offg
101 TYPE(G_BUFEL_) ,POINTER :: GBUF
102C======================================================================|
103 m = npby(1)
104C
105 icomm(1:nspmd+2) = 0
106 IF(nspmd > 1)THEN
107C FR_RBY2(3,NRB) => proc main ; ICOMM : Array of flag for necessary comm pmain => p
108 pmain = abs(fr_rby2(3,nrb))
109 tag = 1
110 IF(m < 0) tag = 0
111 IF(ispmd+1/=pmain) icomm(ispmd+1) = tag
112 CALL spmd_part_com(tag,pmain,icomm)
113 IF(m < 0) GOTO 100
114C for use of ICOMM in SPMD_EXCH_FR6
115C FR_RBY2 can not be used directly
116 icomm(nspmd+1) = 0
117 icomm(nspmd+2) = pmain
118 ELSE
119 pmain = 1
120 ENDIF
121C
122 isph = npby(5)
123 id = npby(6)
124C
125C-----------------------------------------------
126 IF(onof == 0)THEN
127C-----------------------
128C DEACTIVATION OF RB
129C-----------------------
130 in(m) = rby(13)
131 ms(m) = rby(15)
132 ELSEIF(onof == 1)THEN
133C-----------------------
134C REACTIVATION OF RB
135C-----------------------
136 IF(n2d==0) THEN
137C 3D ANALYSIS
138 xmom = v(1,m)*ms(m)
139 ymom = v(2,m)*ms(m)
140 zmom = v(3,m)*ms(m)
141C
142 xxmom = vr(1,m)*in(m)
143 yymom = vr(2,m)*in(m)
144 zzmom = vr(3,m)*in(m)
145 ELSEIF(n2d==1) THEN
146C 2D ANALYSIS : Axisymmetry
147 xmom = zero
148 ymom = v(2,m)*ms(m)
149 zmom = v(3,m)*ms(m)
150C
151 xxmom = zero
152 yymom = zero
153 zzmom = vr(3,m)*in(m)
154 ELSEIF(n2d==2) THEN
155C 2D ANALYSIS : Plane strain
156 xmom = zero
157 ymom = v(2,m)*ms(m)
158 zmom = v(3,m)*ms(m)
159C
160 xxmom = vr(1,m)*in(m)
161 yymom = zero
162 zzmom = zero
163 ENDIF
164C
165 CALL rbyact(rby ,m ,lpby ,nsn ,ms ,
166 . in ,x ,itab ,skew ,isph ,
167 . itag(1+numnod),npbyi,rbyi ,lpbyi ,
168 . pmain,icomm,weight,id )
169C----------------------------------------------
170C MOMENTUM +
171C RESET OF MASSES AND INERTIAS OF SECNDS NODES
172C----------------------------------------------
173 IF(n2d==0) THEN
174C 3D ANALYSIS
175 DO i=1,nsn
176 n = lpby(i)
177 IF(itag(numnod+n) > 0.AND.weight(n) == 1)THEN
178C main node of secondary rbody
179 ni = itag(numnod+n)
180 f1(i) = v(1,n)*ms(n)
181 f2(i) = v(2,n)*ms(n)
182 f3(i) = v(3,n)*ms(n)
183c XMOM = XMOM + V(1,N)*MS(N)
184c YMOM = YMOM + V(2,N)*MS(N)
185c ZMOM = ZMOM + V(3,N)*MS(N)
186C Inertia matrix -> global frame
187 ii1=rbyi(10,ni)*rbyi(1,ni)
188 ii2=rbyi(10,ni)*rbyi(2,ni)
189 ii3=rbyi(10,ni)*rbyi(3,ni)
190 ii4=rbyi(11,ni)*rbyi(4,ni)
191 ii5=rbyi(11,ni)*rbyi(5,ni)
192 ii6=rbyi(11,ni)*rbyi(6,ni)
193 ii7=rbyi(12,ni)*rbyi(7,ni)
194 ii8=rbyi(12,ni)*rbyi(8,ni)
195 ii9=rbyi(12,ni)*rbyi(9,ni)
196C
197 ig1=rbyi(1,ni)*ii1+rbyi(4,ni)*ii4+rbyi(7,ni)*ii7
198 ig2=rbyi(1,ni)*ii2+rbyi(4,ni)*ii5+rbyi(7,ni)*ii8
199 ig3=rbyi(1,ni)*ii3+rbyi(4,ni)*ii6+rbyi(7,ni)*ii9
200 ig4=rbyi(2,ni)*ii1+rbyi(5,ni)*ii4+rbyi(8,ni)*ii7
201 ig5=rbyi(2,ni)*ii2+rbyi(5,ni)*ii5+rbyi(8,ni)*ii8
202 ig6=rbyi(2,ni)*ii3+rbyi(5,ni)*ii6+rbyi(8,ni)*ii9
203 ig7=rbyi(3,ni)*ii1+rbyi(6,ni)*ii4+rbyi(9,ni)*ii7
204 ig8=rbyi(3,ni)*ii2+rbyi(6,ni)*ii5+rbyi(9,ni)*ii8
205 ig9=rbyi(3,ni)*ii3+rbyi(6,ni)*ii6+rbyi(9,ni)*ii9
206C
207 f4(i) = vr(1,n)*ig1 + vr(2,n)*ig2 + vr(3,n)*ig3
208 . +(x(2,n)-x(2,m))*v(3,n)*ms(n)
209 . -(x(3,n)-x(3,m))*v(2,n)*ms(n)
210 f5(i) = vr(1,n)*ig4 + vr(2,n)*ig5 + vr(3,n)*ig6
211 . +(x(3,n)-x(3,m))*v(1,n)*ms(n)
212 . -(x(1,n)-x(1,m))*v(3,n)*ms(n)
213 f6(i) = vr(1,n)*ig7 + vr(2,n)*ig8 + vr(3,n)*ig9
214 . +(x(1,n)-x(1,m))*v(2,n)*ms(n)
215 . -(x(2,n)-x(2,m))*v(1,n)*ms(n)
216c XXMOM = XXMOM + VR(1,N)*IG1 + VR(2,N)*IG2 + VR(3,N)*IG3
217c . +(X(2,N)-X(2,M))*V(3,N)*MS(N)
218c . -(X(3,N)-X(3,M))*V(2,N)*MS(N)
219c YYMOM = YYMOM + VR(1,N)*IG4 + VR(2,N)*IG5 + VR(3,N)*IG6
220c . +(X(3,N)-X(3,M))*V(1,N)*MS(N)
221c . -(X(1,N)-X(1,M))*V(3,N)*MS(N)
222c ZZMOM = ZZMOM + VR(1,N)*IG7 + VR(2,N)*IG8 + VR(3,N)*IG9
223c . +(X(1,N)-X(1,M))*V(2,N)*MS(N)
224c . -(X(2,N)-X(2,M))*V(1,N)*MS(N)
225 ELSEIF(itag(numnod+n) == 0.AND.weight(n) == 1)THEN
226C node neither main nor secondary of secondary rbody
227 f1(i) = v(1,n)*ms(n)
228 f2(i) = v(2,n)*ms(n)
229 f3(i) = v(3,n)*ms(n)
230c XMOM = XMOM + V(1,N)*MS(N)
231c YMOM = YMOM + V(2,N)*MS(N)
232c ZMOM = ZMOM + V(3,N)*MS(N)
233C
234 f4(i) = vr(1,n)*in(n)
235 . +(x(2,n)-x(2,m))*v(3,n)*ms(n)
236 . -(x(3,n)-x(3,m))*v(2,n)*ms(n)
237 f5(i) = vr(2,n)*in(n)
238 . +(x(3,n)-x(3,m))*v(1,n)*ms(n)
239 . -(x(1,n)-x(1,m))*v(3,n)*ms(n)
240 f6(i) = vr(3,n)*in(n)
241 . +(x(1,n)-x(1,m))*v(2,n)*ms(n)
242 . -(x(2,n)-x(2,m))*v(1,n)*ms(n)
243c XXMOM = XXMOM + VR(1,N)*IN(N)
244c . +(X(2,N)-X(2,M))*V(3,N)*MS(N)
245c . -(X(3,N)-X(3,M))*V(2,N)*MS(N)
246c YYMOM = YYMOM + VR(2,N)*IN(N)
247c . +(X(3,N)-X(3,M))*V(1,N)*MS(N)
248c . -(X(1,N)-X(1,M))*V(3,N)*MS(N)
249c ZZMOM = ZZMOM + VR(3,N)*IN(N)
250c . +(X(1,N)-X(1,M))*V(2,N)*MS(N)
251c . -(X(2,N)-X(2,M))*V(1,N)*MS(N)
252 ELSE
253 f1(i) = zero
254 f2(i) = zero
255 f3(i) = zero
256 f4(i) = zero
257 f5(i) = zero
258 f6(i) = zero
259 ENDIF
260C
261 ENDDO
262 ELSEIF(n2d==1) THEN
263C 2D ANALYSIS : Axisymmetry
264 DO i=1,nsn
265 n = lpby(i)
266 IF(itag(numnod+n) > 0.AND.weight(n) == 1)THEN
267C main node of secondary rbody
268 ni = itag(numnod+n)
269 f1(i) = v(1,n)*ms(n)
270 f2(i) = v(2,n)*ms(n)
271 f3(i) = v(3,n)*ms(n)
272C Inertia matrix -> global frame
273 ig1=rbyi(10,ni)
274 ig5=rbyi(11,ni)
275 ig9=rbyi(12,ni)
276C
277 f4(i) = vr(1,n)*ig1
278 . +(x(2,n)-x(2,m))*v(3,n)*ms(n)
279 . -(x(3,n)-x(3,m))*v(2,n)*ms(n)
280 f5(i) = vr(2,n)*ig5
281 . +(x(3,n)-x(3,m))*v(1,n)*ms(n)
282 . -(x(1,n)-x(1,m))*v(3,n)*ms(n)
283 f6(i) = vr(3,n)*ig9
284 . +(x(1,n)-x(1,m))*v(2,n)*ms(n)
285 . -(x(2,n)-x(2,m))*v(1,n)*ms(n)
286
287 ELSEIF(itag(numnod+n) == 0.AND.weight(n) == 1)THEN
288C node neither main nor secondary of secondary rbody
289 f1(i) = v(1,n)*ms(n)
290 f2(i) = v(2,n)*ms(n)
291 f3(i) = v(3,n)*ms(n)
292C
293 f4(i) = vr(1,n)*in(n)
294 . +(x(2,n)-x(2,m))*v(3,n)*ms(n)
295 . -(x(3,n)-x(3,m))*v(2,n)*ms(n)
296 f5(i) = vr(2,n)*in(n)
297 . +(x(3,n)-x(3,m))*v(1,n)*ms(n)
298 . -(x(1,n)-x(1,m))*v(3,n)*ms(n)
299 f6(i) = vr(3,n)*in(n)
300 . +(x(1,n)-x(1,m))*v(2,n)*ms(n)
301 . -(x(2,n)-x(2,m))*v(1,n)*ms(n)
302 ELSE
303 f1(i) = zero
304 f2(i) = zero
305 f3(i) = zero
306 f4(i) = zero
307 f5(i) = zero
308 f6(i) = zero
309 ENDIF
310C
311 ENDDO
312 ELSEIF(n2d==2) THEN
313C 2D ANALYSIS : Plane symmetry
314 DO i=1,nsn
315 n = lpby(i)
316 IF(itag(numnod+n) > 0.AND.weight(n) == 1)THEN
317C main node of secondary rbody
318 ni = itag(numnod+n)
319 f1(i) = zero
320 f2(i) = v(2,n)*ms(n)
321 f3(i) = v(3,n)*ms(n)
322C Inertia matrix -> global frame
323 ii1=rbyi(10,ni)*rbyi(1,ni)
324 ii5=rbyi(11,ni)*rbyi(5,ni)
325 ii6=rbyi(11,ni)*rbyi(6,ni)
326 ii8=rbyi(12,ni)*rbyi(8,ni)
327 ii9=rbyi(12,ni)*rbyi(9,ni)
328C
329 ig1=rbyi(1,ni)*ii1
330 ig5=rbyi(5,ni)*ii5+rbyi(8,ni)*ii8
331 ig6=rbyi(5,ni)*ii6+rbyi(8,ni)*ii9
332 ig8=rbyi(6,ni)*ii5+rbyi(9,ni)*ii8
333 ig9=rbyi(6,ni)*ii6+rbyi(9,ni)*ii9
334C
335 f4(i) = vr(1,n)*ig1+(x(2,n)-x(2,m))*v(3,n)*ms(n)
336 . -(x(3,n)-x(3,m))*v(2,n)*ms(n)
337 f5(i) = zero
338 f6(i) = zero
339 f5(i) = vr(2,n)*ig5 + vr(3,n)*ig6
340 f6(i) = vr(2,n)*ig8 + vr(3,n)*ig9
341 ELSEIF(itag(numnod+n) == 0.AND.weight(n) == 1)THEN
342C node neither main nor secondary of secondary rbody
343 f1(i) = zero
344 f2(i) = v(2,n)*ms(n)
345 f3(i) = v(3,n)*ms(n)
346 f4(i) = vr(1,n)*in(n)+(x(2,n)-x(2,m))*v(3,n)*ms(n)
347 . -(x(3,n)-x(3,m))*v(2,n)*ms(n)
348 f5(i) = zero
349 f6(i) = zero
350 f5(i) = vr(2,n)*in(n)
351 f6(i) = vr(3,n)*in(n)
352 ELSE
353 f1(i) = zero
354 f2(i) = zero
355 f3(i) = zero
356 f4(i) = zero
357 f5(i) = zero
358 f6(i) = zero
359 ENDIF
360C
361 ENDDO
362 ENDIF
363C
364C
365C Parith/ON treatment before exchange
366C
367C
368 DO k = 1, 6
369 rbf6(1,k) = zero
370 rbf6(2,k) = zero
371 rbf6(3,k) = zero
372 rbf6(4,k) = zero
373 rbf6(5,k) = zero
374 rbf6(6,k) = zero
375 END DO
376
377 CALL sum_6_float(1 ,nsn ,f1, rbf6(1,1), 6)
378 CALL sum_6_float(1 ,nsn ,f2, rbf6(2,1), 6)
379 CALL sum_6_float(1 ,nsn ,f3, rbf6(3,1), 6)
380 CALL sum_6_float(1 ,nsn ,f4, rbf6(4,1), 6)
381 CALL sum_6_float(1 ,nsn ,f5, rbf6(5,1), 6)
382 CALL sum_6_float(1 ,nsn ,f6, rbf6(6,1), 6)
383
384
385 IF(nspmd > 1) THEN
386 CALL spmd_exch_fr6(icomm,rbf6,6*6)
387 ENDIF
388
389 xmom = xmom+
390 + rbf6(1,1)+rbf6(1,2)+rbf6(1,3)+
391 + rbf6(1,4)+rbf6(1,5)+rbf6(1,6)
392 ymom = ymom+
393 + rbf6(2,1)+rbf6(2,2)+rbf6(2,3)+
394 + rbf6(2,4)+rbf6(2,5)+rbf6(2,6)
395 zmom = zmom+
396 + rbf6(3,1)+rbf6(3,2)+rbf6(3,3)+
397 + rbf6(3,4)+rbf6(3,5)+rbf6(3,6)
398 xxmom= xxmom+
399 + rbf6(4,1)+rbf6(4,2)+rbf6(4,3)+
400 + rbf6(4,4)+rbf6(4,5)+rbf6(4,6)
401 yymom= yymom+
402 + rbf6(5,1)+rbf6(5,2)+rbf6(5,3)+
403 + rbf6(5,4)+rbf6(5,5)+rbf6(5,6)
404 zzmom= zzmom+
405 + rbf6(6,1)+rbf6(6,2)+rbf6(6,3)+
406 + rbf6(6,4)+rbf6(6,5)+rbf6(6,6)
407
408C
409 v(1,m) = xmom / ms(m)
410 v(2,m) = ymom / ms(m)
411 v(3,m) = zmom / ms(m)
412C
413 wa1=xxmom
414 wa2=yymom
415 wa3=zzmom
416 xxmom=rby(1)*wa1+rby(2)*wa2+rby(3)*wa3
417 yymom=rby(4)*wa1+rby(5)*wa2+rby(6)*wa3
418 zzmom=rby(7)*wa1+rby(8)*wa2+rby(9)*wa3
419 wa1 = xxmom / rby(10)
420 wa2 = yymom / rby(11)
421 wa3 = zzmom / rby(12)
422 IF(n2d==0) THEN
423 vr(1,m)=rby(1)*wa1+rby(4)*wa2+rby(7)*wa3
424 vr(2,m)=rby(2)*wa1+rby(5)*wa2+rby(8)*wa3
425 vr(3,m)=rby(3)*wa1+rby(6)*wa2+rby(9)*wa3
426 ELSEIF(n2d==1) THEN
427 vr(1,m)=zero
428 vr(2,m)=zero
429 vr(3,m)=rby(9)*wa3
430 ELSEIF(n2d==2) THEN
431 vr(1,m)=rby(1)*wa1+rby(4)*wa2+rby(7)*wa3
432 vr(2,m)=zero
433 vr(3,m)=zero
434 ENDIF
435
436 ENDIF
437C
438 IF(onfelt == 0.OR.onfelt == 1)THEN
439C-----------------------
440C Tag of secondary nodes
441C-----------------------
442 DO i=1,nsn
443 itag(lpby(i))=1
444 ENDDO
445C-----------------------
446C OFF SET TO -OFF
447C-----------------------
448 DO ng=1,ngroup
449 mlw=iparg(1,ng)
450 ity=iparg(5,ng)
451 nel=iparg(2,ng)
452 nft=iparg(3,ng)
453 iad=iparg(4,ng) - 1
454 gbuf => elbuf_tab(ng)%GBUF
455C-----------------------
456C 1. Solid elements
457C-----------------------
458 IF(ity == 1.AND.mlw /= 0)THEN ! void material, off not used
459 offg => elbuf_tab(ng)%GBUF%OFF
460 DO i=1,nel
461 ii=i+nft
462 nall = itag(ixs(2,ii)) * itag(ixs(3,ii)) *
463 + itag(ixs(4,ii)) * itag(ixs(5,ii)) *
464 + itag(ixs(6,ii)) * itag(ixs(7,ii)) *
465 + itag(ixs(8,ii)) * itag(ixs(9,ii))
466 IF(nall /= 0)THEN
467 off_old = offg(i)
468 IF (onfelt == 1) THEN
469 offg(i) = abs(offg(i))
470 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
471 . WRITE(iout,*)' BRICK ACTIVATION:',ixs(11,ii)
472 ELSEIF(onfelt == 0)THEN
473 offg(i) = -abs(offg(i))
474 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
475 . WRITE(iout,*)' BRICK DEACTIVATION:',ixs(11,ii)
476 ENDIF
477 ENDIF
478 ENDDO
479C----------------------------------------
480C Test for elimination of the group
481C----------------------------------------
482 igof = 1
483 DO i = 1,nel
484 ii=i+nft
485 IF (offg(i) > zero) igof=0
486 ENDDO
487 iparg(8,ng) = igof
488C-----------------------
489C 2. Quad elements
490C-----------------------
491 ELSEIF(ity == 2.AND.mlw /= 0)THEN ! void material, off not used
492 offg => elbuf_tab(ng)%GBUF%OFF
493 DO i=1,nel
494 ii=i+nft
495 nall = itag(ixq(2,ii)) * itag(ixq(3,ii)) *
496 + itag(ixq(4,ii)) * itag(ixq(5,ii))
497 IF(nall /= 0)THEN
498 off_old = offg(i)
499 IF (onfelt == 1) THEN
500 offg(i) = abs(offg(i))
501 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
502 . WRITE(iout,*)' QUAD ACTIVATION:',ixq(7,ii)
503 ELSEIF(onfelt == 0)THEN
504 offg(i) = -abs(offg(i))
505 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
506 . WRITE(iout,*)' QUAD DEACTIVATION:',ixq(7,ii)
507 ENDIF
508 ENDIF
509 ENDDO
510C----------------------------------------
511C Test for elimination of the group
512C----------------------------------------
513 igof = 1
514 DO i = 1,nel
515 ii=i+nft
516 IF (offg(i) > zero) igof=0
517 ENDDO
518 iparg(8,ng) = igof
519C-----------------------
520C 3. SHell elements
521C-----------------------
522 ELSEIF(ity == 3.AND.mlw /= 0)THEN ! void material, off not used
523 offg => elbuf_tab(ng)%GBUF%OFF
524 istrain = iparg(44,ng)
525 npt = iabs(iparg(6,ng))
526 ihbe = iparg(23,ng)
527 DO i=1,nel
528 ii=i+nft
529 nall = itag(ixc(2,ii)) * itag(ixc(3,ii)) *
530 + itag(ixc(4,ii)) * itag(ixc(5,ii))
531 IF(nall /= 0)THEN
532 off_old = offg(i)
533 IF(onfelt == 1)THEN
534 IF (offg(i) < zero)THEN
535 offg(i) = -offg(i)
536 mx = ipartc(ii)
537 partsav(24,mx) = partsav(24,mx)
538 . - gbuf%EINT(i) - gbuf%EINT(i+nel)
539 ENDIF
540 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
541 . WRITE(iout,*)' SHELL ACTIVATION:',ixc(7,ii)
542 ELSEIF(onfelt == 0)THEN
543 IF (offg(i) > zero) THEN
544 offg(i) = -offg(i)
545 mx = ipartc(ii)
546 partsav(24,mx) = partsav(24,mx)
547 . + gbuf%EINT(i) + gbuf%EINT(i+nel)
548 ENDIF
549 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
550 . WRITE(iout,*)' SHELL DEACTIVATION:',ixc(7,ii)
551 ENDIF
552 ENDIF
553 ENDDO
554C----------------------------------------
555C Test for elimination of the group
556C----------------------------------------
557 igof = 1
558 DO i = 1,nel
559 IF (offg(i) > zero) igof=0
560 ENDDO
561 iparg(8,ng) = igof
562C-----------------------
563C 4. Truss elements
564C-----------------------
565 ELSEIF(ity == 4.AND.(iacts == 1.OR.codvers>=44))THEN
566 offg => elbuf_tab(ng)%GBUF%OFF
567 DO i=1,nel
568 ii=i+nft
569 nall = itag(ixt(2,ii)) * itag(ixt(3,ii))
570 IF(nall /= 0)THEN
571 off_old = offg(i)
572 IF(onfelt == 1)THEN
573 offg(i) = abs(offg(i))
574 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
575 . WRITE(iout,*)' TRUSS ACTIVATION:',ixt(5,ii)
576 ELSEIF(onfelt == 0)THEN
577 offg(i) = -abs(offg(i))
578 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
579 . WRITE(iout,*)' TRUSS DEACTIVATION:',ixt(5,ii)
580 ENDIF
581 ENDIF
582 ENDDO
583C----------------------------------------
584C Test for elimination of the group
585C----------------------------------------
586C Incompatible with gap option in truss property
587C IGOF = 1
588C DO I = 1,NEL
589C IF(ELBUF(IAD + I) /= ZERO) IGOF=0
590C ENDDO
591C IPARG(8,NG) = IGOF
592C-----------------------
593C 5. Beam elements
594C-----------------------
595 ELSEIF(ity == 5.AND.(iacts == 1.OR.codvers>=44))THEN
596 offg => elbuf_tab(ng)%GBUF%OFF
597 DO i=1,nel
598 ii=i+nft
599 nall = itag(ixp(2,ii)) * itag(ixp(3,ii))
600 IF(nall /= 0)THEN
601 off_old = offg(i)
602 IF(onfelt == 1)THEN
603 offg(i) = abs(offg(i))
604 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
605 . WRITE(iout,*)' BEAM ACTIVATION:',ixp(6,ii)
606 ELSEIF(onfelt == 0)THEN
607 offg(i) = -abs(offg(i))
608 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
609 . WRITE(iout,*)' BEAM DEACTIVATION:',ixp(6,ii)
610 ENDIF
611 ENDIF
612 ENDDO
613C----------------------------------------
614C Test for elimination of the group
615C----------------------------------------
616 igof = 1
617 DO i = 1,nel
618 IF (offg(i) > zero) igof=0
619 ENDDO
620 iparg(8,ng) = igof
621C-----------------------
622C 6. Spring elements
623C-----------------------
624 ELSEIF(ity == 6.AND.mlw /= 3.AND.
625 . (iacts == 1.OR.codvers>=44))THEN
626 offg => elbuf_tab(ng)%GBUF%OFF
627 DO i=1,nel
628 ii=i+nft
629 nall = itag(ixr(2,ii)) * itag(ixr(3,ii))
630 IF(nall /= 0)THEN
631 off_old = offg(i)
632 IF(onfelt == 1)THEN
633 IF (offg(i) /= -ten)
634C spring is active
635 . offg(i)= abs(offg(i))
636 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
637 . WRITE(iout,*)' SPRING ACTIVATION:',ixr(nixr,ii)
638 ELSEIF(onfelt == 0)THEN
639 IF (offg(i) /= -ten)
640C spring is active
641 . offg(i) = -abs(offg(i))
642 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
643 . WRITE(iout,*)' SPRING DEACTIVATION:',ixr(nixr,ii)
644 ENDIF
645 ENDIF
646 ENDDO
647C----------------------------------------
648C Test for elimination of the group
649C----------------------------------------
650 igof = 1
651 DO i = 1,nel
652 IF(offg(i) /= zero) igof=0
653 ENDDO
654 iparg(8,ng) = igof
655C-----------------------
656C 7. SH3N elements
657C-----------------------
658 ELSEIF (ity == 7 .AND. mlw /= 0) THEN ! void material, off not used
659 offg => elbuf_tab(ng)%GBUF%OFF
660 istrain = iparg(44,ng)
661 npt = iabs(iparg(6,ng))
662 DO i=1,nel
663 ii=i+nft
664 nall = itag(ixtg(2,ii)) * itag(ixtg(3,ii)) *
665 + itag(ixtg(4,ii))
666 IF(nall /= 0)THEN
667 off_old = offg(i)
668 IF (onfelt == 1) THEN
669 offg(i) = abs(offg(i))
670 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
671 . WRITE(iout,*)' SH_3N ACTIVATION:',ixtg(6,ii)
672 ELSEIF(onfelt == 0)THEN
673 offg(i) = -abs(offg(i))
674 IF ((pri_off==0).OR.(off_old*offg(i)<zero))
675 . WRITE(iout,*)' SH_3N DEACTIVATION:',ixtg(6,ii)
676 ENDIF
677 ENDIF
678 ENDDO
679C----------------------------------------
680C Test for elimination of the group
681C----------------------------------------
682 igof = 1
683 DO i = 1,nel
684 IF (offg(i) > zero) igof=0
685 ENDDO
686 iparg(8,ng) = igof
687C----------------------------------------
688 ENDIF
689 ENDDO
690C-----------------------
691C Rest of tag of secondary nodes
692C-----------------------
693 DO i=1,nsn
694 itag(lpby(i))=0
695 ENDDO
696
697 ENDIF ! IF(ONFELT == 0.OR.ONFELT == 1)THEN
698C
699 100 CONTINUE
700 IF(nspmd > 1) THEN
701C Treatment needed to get active and inative elements in the right order
702 iwiout = 0
703 IF (ispmd /= 0) CALL spmd_chkw(iwiout,iout)
704 CALL spmd_glob_isum9(iwiout,1)
705 CALL spmd_ibcast(iwiout,iwiout,1,1,0,2)
706 IF (iwiout > 0) THEN
707 CALL spmd_wiout(iout,iwiout)
708 iwiout = 0
709 ENDIF
710 ENDIF
711C-----------
712 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
id
initmumps id
Definition multiplerhs_example.m:4
sum_6_float
subroutine sum_6_float(jft, jlt, f, f6, n)
Definition parit.F:65
rbyact
subroutine rbyact(rby, m, lsn, nsl, ms, in, x, itab, skew, isph, iwa, npbyi, rbyi, lsni, pmain, icomm, weight, id)
Definition rbyact.F:41
spmd_chkw
subroutine spmd_chkw(iwiout, iout)
Definition spmd_chkw.F:38
spmd_exch_fr6
subroutine spmd_exch_fr6(fr, fs6, len)
Definition spmd_exch_fr6.F:52
spmd_ibcast
subroutine spmd_ibcast(tabi, tabr, n1, n2, from, add)
Definition spmd_ibcast.F:57
spmd_glob_isum9
subroutine spmd_glob_isum9(v, len)
Definition spmd_th.F:520
spmd_part_com
subroutine spmd_part_com(tag, main, icomv)
Definition spmd_th.F:240
spmd_wiout
subroutine spmd_wiout(iout, iwiout)
Definition spmd_wiout.F:40