OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rbypid.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!|| rbypid ../engine/source/constraints/general/rbody/rbypid.F
25!||--- called by ------------------------------------------------------
26!|| rbyonf ../engine/source/constraints/general/rbody/rbyonf.F
27!|| rbysens ../engine/source/constraints/general/rbody/rbyonf.F
28!||--- calls -----------------------------------------------------
29!|| rbyact ../engine/source/constraints/general/rbody/rbyact.f
30!|| spmd_chkw ../engine/source/mpi/generic/spmd_chkw.F
31!|| spmd_exch_fr6 ../engine/source/mpi/kinematic_conditions/spmd_exch_fr6.F
32!|| spmd_glob_isum9 ../engine/source/mpi/interfaces/spmd_th.F
33!|| spmd_ibcast ../engine/source/mpi/generic/spmd_ibcast.F
34!|| spmd_part_com ../engine/source/mpi/interfaces/spmd_th.F
35!|| spmd_wiout ../engine/source/mpi/generic/spmd_wiout.F
36!|| sum_6_float ../engine/source/system/parit.F
37!||--- uses -----------------------------------------------------
38!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
39!||====================================================================
40 SUBROUTINE rbypid(IPARG ,IPARI ,MS ,IN ,
41 . IXS ,IXQ ,IXC ,IXT ,IXP ,
42 . IXR ,SKEW ,ITAB ,ITABM1,ISKWN ,
43 . NPBY ,ONOF ,ITAG ,LPBY ,
44 . X ,V ,VR ,RBY ,
45 . IXTG ,NPBYI,RBYI ,LPBYI ,IACTS ,
46 . FR_RBY2 ,NRB ,ONFELT,WEIGHT,PARTSAV,
47 . IPARTC ,NSN ,ELBUF_TAB,PRI_OFF)
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
711 END
my_real
#define my_real
Definition cppsort.cpp:32
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
rbypid
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)
Definition rbypid.F:48
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