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 40 of file rbypid.F.

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