OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_admesh.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!|| sms_admesh_0 ../engine/source/ams/sms_admesh.F
25!||--- called by ------------------------------------------------------
26!|| sms_mass_scale_2 ../engine/source/ams/sms_mass_scale_2.F
27!||--- calls -----------------------------------------------------
28!||--- uses -----------------------------------------------------
29!|| element_mod ../common_source/modules/elements/element_mod.F90
30!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
31!|| remesh_mod ../engine/share/modules/remesh_mod.F
32!||====================================================================
33 SUBROUTINE sms_admesh_0(A ,DIAG_SMS, IXC, IXTG,SH4TREE ,
34 . SH3TREE )
35C-----------------------------------------------
36C M o d u l e s
37C-----------------------------------------------
38 USE remesh_mod
39 USE my_alloc_mod
40 use element_mod , only : nixc,nixtg
41C-----------------------------------------------
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44#include "implicit_f.inc"
45C-----------------------------------------------
46C D u m m y A r g u m e n t s
47C-----------------------------------------------
48 INTEGER IXC(NIXC,*), IXTG(NIXTG,*),
49 . sh4tree(ksh4tree,*), sh3tree(ksh3tree,*)
50C REAL
51 my_real
52 . a(3,*), diag_sms(*)
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com04_c.inc"
57#include "param_c.inc"
58#include "remesh_c.inc"
59C-----------------------------------------------
60C L o c a l V a r i a b l e s
61C-----------------------------------------------
62 INTEGER N, NN, LEVEL
63 INTEGER SON,M1,M2,M3,M4,MC,N1,N2,N3,N4
64 INTEGER,DIMENSION(:),ALLOCATABLE :: LKINNOD
65 my_real
66 . a1,a2,a3,a4,ac
67C-----------------------------------------------
68 CALL my_alloc(lkinnod,numnod)
69 lkinnod=0
70 DO level=levelmax-1,0,-1
71
72 DO nn=psh4kin(level)+1,psh4kin(level+1)
73 n =lsh4kin(nn)
74
75 son=sh4tree(2,n)
76
77 n1=ixc(2,n)
78 n2=ixc(3,n)
79 n3=ixc(4,n)
80 n4=ixc(5,n)
81C
82 mc=ixc(4,son)
83 ac= fourth*diag_sms(mc)
84 diag_sms(n1)=diag_sms(n1)+ac
85 diag_sms(n2)=diag_sms(n2)+ac
86 diag_sms(n3)=diag_sms(n3)+ac
87 diag_sms(n4)=diag_sms(n4)+ac
88
89 diag_sms(mc)=zero
90 lkinnod(mc)=1
91C
92 m1=ixc(3,son )
93 IF(lkinnod(m1)==0)THEN
94 lkinnod(m1)=1
95 a1=half*diag_sms(m1)
96 diag_sms(n1)=diag_sms(n1)+a1
97 diag_sms(n2)=diag_sms(n2)+a1
98 diag_sms(m1)=zero
99 END IF
100C
101 m2=ixc(4,son+1)
102 IF(lkinnod(m2)==0)THEN
103 lkinnod(m2)=1
104 a2=half*diag_sms(m2)
105 diag_sms(n2)=diag_sms(n2)+a2
106 diag_sms(n3)=diag_sms(n3)+a2
107 diag_sms(m2)=zero
108 END IF
109C
110 m3=ixc(5,son+2)
111 IF(lkinnod(m3)==0)THEN
112 lkinnod(m3)=1
113 a3=half*diag_sms(m3)
114 diag_sms(n3)=diag_sms(n3)+a3
115 diag_sms(n4)=diag_sms(n4)+a3
116 diag_sms(m3)=zero
117 END IF
118C
119 m4=ixc(2,son+3)
120 IF(lkinnod(m4)==0)THEN
121 lkinnod(m4)=1
122 a4=half*diag_sms(m4)
123 diag_sms(n1)=diag_sms(n1)+a4
124 diag_sms(n4)=diag_sms(n4)+a4
125 diag_sms(m4)=zero
126 END IF
127
128 END DO
129
130
131 DO nn=psh3kin(level)+1,psh3kin(level+1)
132 n =lsh3kin(nn)
133
134 son=sh3tree(2,n)
135
136 n1=ixtg(2,n)
137 n2=ixtg(3,n)
138 n3=ixtg(4,n)
139C
140 m1=ixtg(4,son+3)
141 IF(lkinnod(m1)==0)THEN
142 lkinnod(m1)=1
143 a1=half*diag_sms(m1)
144 diag_sms(n1)=diag_sms(n1)+a1
145 diag_sms(n2)=diag_sms(n2)+a1
146 diag_sms(m1)=zero
147 END IF
148C
149 m2=ixtg(2,son+3)
150 IF(lkinnod(m2)==0)THEN
151 lkinnod(m2)=1
152 a2=half*diag_sms(m2)
153 diag_sms(n2)=diag_sms(n2)+a2
154 diag_sms(n3)=diag_sms(n3)+a2
155 diag_sms(m2)=zero
156 END IF
157
158 m3=ixtg(3,son+3)
159 IF(lkinnod(m3)==0)THEN
160 lkinnod(m3)=1
161 a3=half*diag_sms(m3)
162 diag_sms(n3)=diag_sms(n3)+a3
163 diag_sms(n1)=diag_sms(n1)+a3
164 diag_sms(m3)=zero
165 END IF
166
167 END DO
168
169 END DO
170 DEALLOCATE(lkinnod)
171 RETURN
172 END
173!||====================================================================
174!|| sms_admesh_1 ../engine/source/ams/sms_admesh.F
175!||--- called by ------------------------------------------------------
176!|| sms_pcg ../engine/source/ams/sms_pcg.F
177!||--- calls -----------------------------------------------------
178!||--- uses -----------------------------------------------------
179!|| element_mod ../common_source/modules/elements/element_mod.F90
180!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
181!|| remesh_mod ../engine/share/modules/remesh_mod.F
182!||====================================================================
183 SUBROUTINE sms_admesh_1(A ,DIAG_SMS, IXC, IXTG,SH4TREE ,
184 . SH3TREE ,NODNX_SMS)
185C-----------------------------------------------
186C M o d u l e s
187C-----------------------------------------------
188 USE remesh_mod
189 USE my_alloc_mod
190 use element_mod , only : nixc,nixtg
191C-----------------------------------------------
192C I m p l i c i t T y p e s
193C-----------------------------------------------
194#include "implicit_f.inc"
195C-----------------------------------------------
196C D u m m y A r g u m e n t s
197C-----------------------------------------------
198 INTEGER IXC(NIXC,*), IXTG(NIXTG,*),
199 . SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*), NODNX_SMS(*)
200C REAL
201 my_real
202 . a(3,*), diag_sms(*)
203C-----------------------------------------------
204C C o m m o n B l o c k s
205C-----------------------------------------------
206#include "com04_c.inc"
207#include "param_c.inc"
208#include "remesh_c.inc"
209C-----------------------------------------------
210C L o c a l V a r i a b l e s
211C-----------------------------------------------
212 INTEGER N, NN, LEVEL
213 INTEGER SON,M1,M2,M3,M4,MC,N1,N2,N3,N4,J
214 INTEGER,DIMENSION(:),ALLOCATABLE :: LKINNOD
215
216 my_real
217 . a1,a2,a3,a4,ac
218C-----------------------------------------------
219 CALL my_alloc(lkinnod,numnod)
220 lkinnod=0
221 DO level=levelmax-1,0,-1
222
223 DO nn=psh4kin(level)+1,psh4kin(level+1)
224 n =lsh4kin(nn)
225
226 son=sh4tree(2,n)
227
228 n1=ixc(2,n)
229 n2=ixc(3,n)
230 n3=ixc(4,n)
231 n4=ixc(5,n)
232C
233 mc=ixc(4,son)
234 DO j=1,3
235 ac= fourth*a(j,mc)
236 a(j,n1)=a(j,n1)+ac
237 a(j,n2)=a(j,n2)+ac
238 a(j,n3)=a(j,n3)+ac
239 a(j,n4)=a(j,n4)+ac
240 a(j,mc)=zero
241 END DO
242 lkinnod(mc)=1
243C
244 m1=ixc(3,son )
245 IF(lkinnod(m1)==0)THEN
246 lkinnod(m1)=1
247 DO j=1,3
248 a1=half*a(j,m1)
249 a(j,n1)=a(j,n1)+a1
250 a(j,n2)=a(j,n2)+a1
251 a(j,m1)=zero
252 END DO
253 END IF
254C
255 m2=ixc(4,son+1)
256 IF(lkinnod(m2)==0)THEN
257 lkinnod(m2)=1
258 DO j=1,3
259 a2=half*a(j,m2)
260 a(j,n2)=a(j,n2)+a2
261 a(j,n3)=a(j,n3)+a2
262 a(j,m2)=zero
263 END DO
264 END IF
265
266 m3=ixc(5,son+2)
267 IF(lkinnod(m3)==0)THEN
268 lkinnod(m3)=1
269 DO j=1,3
270 a3=half*a(j,m3)
271 a(j,n3)=a(j,n3)+a3
272 a(j,n4)=a(j,n4)+a3
273 a(j,m3)=zero
274 END DO
275 END IF
276C
277 m4=ixc(2,son+3)
278 IF(lkinnod(m4)==0)THEN
279 lkinnod(m4)=1
280 DO j=1,3
281 a4=half*a(j,m4)
282 a(j,n1)=a(j,n1)+a4
283 a(j,n4)=a(j,n4)+a4
284 a(j,m4)=zero
285 END DO
286 END IF
287
288 END DO
289
290
291 DO nn=psh3kin(level)+1,psh3kin(level+1)
292 n =lsh3kin(nn)
293
294 son=sh3tree(2,n)
295
296 n1=ixtg(2,n)
297 n2=ixtg(3,n)
298 n3=ixtg(4,n)
299C
300 m1=ixtg(4,son+3)
301 IF(lkinnod(m1)==0)THEN
302 lkinnod(m1)=1
303 DO j=1,3
304 a1=half*a(j,m1)
305 a(j,n1)=a(j,n1)+a1
306 a(j,n2)=a(j,n2)+a1
307 a(j,m1)=zero
308 END DO
309 END IF
310C
311 m2=ixtg(2,son+3)
312 IF(lkinnod(m2)==0)THEN
313 lkinnod(m2)=1
314 DO j=1,3
315 a2=half*a(j,m2)
316 a(j,n2)=a(j,n2)+a2
317 a(j,n3)=a(j,n3)+a2
318 a(j,m2)=zero
319 END DO
320 END IF
321
322 m3=ixtg(3,son+3)
323 IF(lkinnod(m3)==0)THEN
324 lkinnod(m3)=1
325 DO j=1,3
326 a3=half*a(j,m3)
327 a(j,n3)=a(j,n3)+a3
328 a(j,n1)=a(j,n1)+a3
329 a(j,m3)=zero
330 END DO
331 END IF
332
333 END DO
334
335 END DO
336 DEALLOCATE(lkinnod)
337 RETURN
338 END
339!||====================================================================
340!|| sms_admesh_2 ../engine/source/ams/sms_admesh.f
341!||--- called by ------------------------------------------------------
342!|| sms_pcg ../engine/source/ams/sms_pcg.F
343!||--- calls -----------------------------------------------------
344!|| my_barrier ../engine/source/system/machine.F
345!||--- uses -----------------------------------------------------
346!|| element_mod ../common_source/modules/elements/element_mod.F90
347!|| remesh_mod ../engine/share/modules/remesh_mod.F
348!||====================================================================
349 SUBROUTINE sms_admesh_2(A ,DIAG_SMS, IXC, IXTG,SH4TREE ,
350 . SH3TREE ,ITASK)
351C-----------------------------------------------
352C M o d u l e s
353C-----------------------------------------------
354 USE remesh_mod
355 use element_mod , only : nixc,nixtg
356C-----------------------------------------------
357C I m p l i c i t T y p e s
358C-----------------------------------------------
359#include "implicit_f.inc"
360C-----------------------------------------------
361C D u m m y A r g u m e n t s
362C-----------------------------------------------
363 INTEGER IXC(NIXC,*), IXTG(NIXTG,*),
364 . SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*), ITASK
365C REAL
366 my_real
367 . a(3,*), diag_sms(*)
368C-----------------------------------------------
369C C o m m o n B l o c k s
370C-----------------------------------------------
371#include "param_c.inc"
372#include "remesh_c.inc"
373#include "task_c.inc"
374C-----------------------------------------------
375C L o c a l V a r i a b l e s
376C-----------------------------------------------
377 INTEGER N, NN, LEVEL
378 INTEGER SON,M1,M2,M3,M4,MC,N1,N2,N3,N4,J,NA,NB
379 INTEGER LL, SH4FT, SH4LT, SH3FT, SH3LT
380C-----------------------------------------------
381C
382C allocation tag
383 IF(itask==0)THEN
384 tagnod=0
385 END IF
386C
387 CALL my_barrier
388C
389C-------
390 DO level=0,levelmax-1
391
392 ll=psh4kin(level+1)-psh4kin(level)
393 sh4ft = psh4kin(level)+ 1+itask*ll/ nthread
394 sh4lt = psh4kin(level)+ (itask+1)*ll/nthread
395
396 DO nn=sh4ft,sh4lt
397 n =lsh4kin(nn)
398
399 son=sh4tree(2,n)
400
401 n1=ixc(2,n)
402 n2=ixc(3,n)
403 n3=ixc(4,n)
404 n4=ixc(5,n)
405C
406 mc=ixc(4,son)
407 IF(tagnod(mc)==0)THEN
408 tagnod(mc)=1
409 DO j=1,3
410 a(j,mc)= fourth*(a(j,n1)+a(j,n2)+a(j,n3)+a(j,n4))
411 END DO
412 END IF
413C
414 m1=ixc(3,son )
415 IF(tagnod(m1)==0)THEN
416 tagnod(m1)=1
417 na=min(n1,n2)
418 nb=max(n1,n2)
419 DO j=1,3
420 a(j,m1)=half*(a(j,na)+a(j,nb))
421 END DO
422 END IF
423C
424 m2=ixc(4,son+1)
425 IF(tagnod(m2)==0)THEN
426 tagnod(m2)=1
427 na=min(n2,n3)
428 nb=max(n2,n3)
429 DO j=1,3
430 a(j,m2)=half*(a(j,na)+a(j,nb))
431 END DO
432 END IF
433
434 m3=ixc(5,son+2)
435 IF(tagnod(m3)==0)THEN
436 tagnod(m3)=1
437 na=min(n3,n4)
438 nb=max(n3,n4)
439 DO j=1,3
440 a(j,m3)=half*(a(j,na)+a(j,nb))
441 END DO
442 END IF
443C
444 m4=ixc(2,son+3)
445 IF(tagnod(m4)==0)THEN
446 tagnod(m4)=1
447 na=min(n4,n1)
448 nb=max(n4,n1)
449 DO j=1,3
450 a(j,m4)=half*(a(j,na)+a(j,nb))
451 END DO
452 END IF
453
454 END DO
455
456
457 ll=psh3kin(level+1)-psh3kin(level)
458 sh3ft = psh3kin(level)+ 1+itask*ll/ nthread
459 sh3lt = psh3kin(level)+ (itask+1)*ll/nthread
460
461 DO nn=sh3ft,sh3lt
462 n =lsh3kin(nn)
463
464 son=sh3tree(2,n)
465
466 n1=ixtg(2,n)
467 n2=ixtg(3,n)
468 n3=ixtg(4,n)
469C
470 m1=ixtg(4,son+3)
471 IF(tagnod(m1)==0)THEN
472 tagnod(m1)=1
473 na=min(n1,n2)
474 nb=max(n1,n2)
475 DO j=1,3
476 a(j,m1)=half*(a(j,na)+a(j,nb))
477 END DO
478 END IF
479C
480 m2=ixtg(2,son+3)
481 IF(tagnod(m2)==0)THEN
482 tagnod(m2)=1
483 na=min(n2,n3)
484 nb=max(n2,n3)
485 DO j=1,3
486 a(j,m2)=half*(a(j,na)+a(j,nb))
487 END DO
488 END IF
489
490 m3=ixtg(3,son+3)
491 IF(tagnod(m3)==0)THEN
492 tagnod(m3)=1
493 na=min(n3,n1)
494 nb=max(n3,n1)
495 DO j=1,3
496 a(j,m3)=half*(a(j,na)+a(j,nb))
497 END DO
498 END IF
499
500 END DO
501C
502 CALL my_barrier
503C
504 END DO
505
506 RETURN
507 END
508
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
remesh_mod
Definition remesh_mod.F:50
remesh_mod::lsh4kin
integer, dimension(:), allocatable lsh4kin
Definition remesh_mod.F:62
remesh_mod::lsh3kin
integer, dimension(:), allocatable lsh3kin
Definition remesh_mod.F:62
remesh_mod::psh4kin
integer, dimension(:), allocatable psh4kin
Definition remesh_mod.F:62
remesh_mod::psh3kin
integer, dimension(:), allocatable psh3kin
Definition remesh_mod.F:62
remesh_mod::tagnod
integer, dimension(:), allocatable tagnod
Definition remesh_mod.F:77
sms_admesh_1
subroutine sms_admesh_1(a, diag_sms, ixc, ixtg, sh4tree, sh3tree, nodnx_sms)
Definition sms_admesh.F:185
sms_admesh_2
subroutine sms_admesh_2(a, diag_sms, ixc, ixtg, sh4tree, sh3tree, itask)
Definition sms_admesh.F:351
sms_admesh_0
subroutine sms_admesh_0(a, diag_sms, ixc, ixtg, sh4tree, sh3tree)
Definition sms_admesh.F:35
my_barrier
subroutine my_barrier
Definition machine.F:31