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!|| element_mod ../common_source/modules/elements/element_mod.F90
40!||====================================================================
41 SUBROUTINE rbypid(IPARG ,IPARI ,MS ,IN ,
42 . IXS ,IXQ ,IXC ,IXT ,IXP ,
43 . IXR ,SKEW ,ITAB ,ITABM1,ISKWN ,
44 . NPBY ,ONOF ,ITAG ,LPBY ,
45 . X ,V ,VR ,RBY ,
46 . IXTG ,NPBYI,RBYI ,LPBYI ,IACTS ,
47 . FR_RBY2 ,NRB ,ONFELT,WEIGHT,PARTSAV,
48 . IPARTC ,NSN ,ELBUF_TAB,PRI_OFF)
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.AND..AND. ELSEIF(ITY == 6MLW /= 3
625.OR. . (IACTS == 1CODVERS>=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.OR. IF ((PRI_OFF==0)(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.OR. IF ((PRI_OFF==0)(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.AND. ELSEIF (ITY == 7 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.OR. IF ((PRI_OFF==0)(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.OR. IF ((PRI_OFF==0)(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.OR. ENDIF ! IF(ONFELT == 0ONFELT == 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
713 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: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
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:49
spmd_exch_fr6
subroutine spmd_exch_fr6(fr, fs6, len)
Definition spmd_exch_fr6.F:52
spmd_part_com
subroutine spmd_part_com(tag, main, icomv)
Definition spmd_th.F:240