OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
admmap3.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!|| admmap3 ../engine/source/model/remesh/admmap3.F
25!||--- called by ------------------------------------------------------
26!|| admdiv ../engine/source/model/remesh/admdiv.F
27!|| admini ../engine/source/model/remesh/admini.F
28!|| admregul ../engine/source/model/remesh/admregul.F
29!||--- uses -----------------------------------------------------
30!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
31!|| remesh_mod ../engine/share/modules/remesh_mod.F
32!||====================================================================
33 SUBROUTINE admmap3(N ,IXTG ,X ,IPARG ,ELBUF_TAB,
34 . IGEO ,IPM ,SH3TREE)
35C-----------------------------------------------
36C M o d u l e s
37C-----------------------------------------------
38 USE remesh_mod
39 USE elbufdef_mod
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "vect01_c.inc"
48#include "com01_c.inc"
49#include "param_c.inc"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53 INTEGER N, IXTG(NIXTG,*), IPARG(NPARG,*),
54 . igeo(npropgi,*), ipm(npropmi,*), sh3tree(ksh3tree,*)
55 my_real
56 . x(3,*)
57 TYPE(elbuf_struct_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
58C-----------------------------------------------
59C L o c a l V a r i a b l e s
60C-----------------------------------------------
61 INTEGER IB,M,N1,N2,N3,N4,IR,IS,IT,IL,NPTR,NPTS,NPTT,NLAY,
62 . i,j,k,ii,jj,i1,ng,ng1,nel1,nft1,mlw,nel,
63 . matly,nuvar,ivar,istra,iexpan,nptm,kk(8),kk1(8)
64 my_real
65 . nx,ny,nz,
66 . stot,x12,y12,z12,x13,y13,z13,s2wake(4)
67 TYPE(g_bufel_) ,POINTER :: GBUFS,GBUFT
68 TYPE(l_bufel_) ,POINTER :: LBUFS,LBUFT
69 TYPE(buf_lay_) ,POINTER :: BUFLY
70C-----------------------------------------------
71 stot=zero
72c
73 DO ib=1,4
74 m = sh3tree(2,n)+ib-1
75 n1 = ixtg(2,m)
76 n2 = ixtg(3,m)
77 n3 = ixtg(4,m)
78
79 x12 = x(1,n2) - x(1,n1)
80 y12 = x(2,n2) - x(2,n1)
81 z12 = x(3,n2) - x(3,n1)
82
83 x13 = x(1,n3) - x(1,n1)
84 y13 = x(2,n3) - x(2,n1)
85 z13 = x(3,n3) - x(3,n1)
86
87 nx = y12*z13 - z12*y13
88 ny = z12*x13 - x12*z13
89 nz = x12*y13 - y12*x13
90
91 s2wake(ib)=sqrt(nx*nx+ny*ny+nz*nz)
92 stot = stot+s2wake(ib)
93 END DO
94C-----------------------------------------------
95 ng = sh3tree(4,n)
96 mlw = iparg(1,ng)
97c
98C IF (MLW==0) GOTO 250
99C---
100 nel = iparg(2,ng)
101 nft = iparg(3,ng)
102 npt = iparg(6,ng)
103 istra= iparg(44,ng)
104 igtyp= iparg(38,ng)
105 iexpan=iparg(49,ng)
106 nptm = max(1,npt)
107 i = n-nft
108c
109 gbufs => elbuf_tab(ng)%GBUF
110 nlay = elbuf_tab(ng)%NLAY
111 nptr = elbuf_tab(ng)%NPTR
112 npts = elbuf_tab(ng)%NPTS
113 nptt = elbuf_tab(ng)%NPTT
114C
115C---- T3
116C
117 DO ib=1,3
118
119 m = sh3tree(2,n)+ib-1
120 ng1 = sh3tree(4,m)
121 nel1 = iparg(2,ng1)
122 nft1 = iparg(3,ng1)
123 i1 = m-nft1
124 gbuft => elbuf_tab(ng1)%GBUF
125!
126 DO k=1,8 ! length max of GBUF%G_STRA = 8
127 kk(k) = nel *(k-1)
128 kk1(k) = nel1*(k-1)
129 ENDDO
130!
131 gbuft%FOR(kk1(1)+i1) = gbufs%FOR(kk(1)+i)
132 gbuft%FOR(kk1(2)+i1) = gbufs%FOR(kk(2)+i)
133 gbuft%FOR(kk1(3)+i1) = gbufs%FOR(kk(3)+i)
134 gbuft%FOR(kk1(4)+i1) = gbufs%FOR(kk(4)+i)
135 gbuft%FOR(kk1(5)+i1) = gbufs%FOR(kk(5)+i)
136c
137 gbuft%MOM(kk1(1)+i1) = gbufs%MOM(kk(1)+i)
138 gbuft%MOM(kk1(2)+i1) = gbufs%MOM(kk(2)+i)
139 gbuft%MOM(kk1(3)+i1) = gbufs%MOM(kk(3)+i)
140c
141 gbuft%EINT(i1) = gbufs%EINT(i)*s2wake(ib)/stot
142 gbuft%EINT(i1+nel1) = gbufs%EINT(i+nel)*s2wake(ib)/stot
143c
144 gbuft%THK(i1) = gbufs%THK(i) !thk
145 gbuft%OFF(i1) = gbufs%OFF(i)
146c
147 IF (gbuft%G_EPSD > 0) THEN
148 gbuft%EPSD(i1) = gbufs%EPSD(i) ! eps_dot
149 ENDIF
150c
151 IF (istra > 0) THEN
152 DO k=1,8 ! deformations
153 gbuft%STRA(kk1(k)+i1) = gbufs%STRA(kk(k)+i)
154 END DO
155 END IF
156c
157 IF (iexpan /= 0) THEN
158 gbuft%TEMP(i1) = gbufs%TEMP(i)
159 END IF
160c
161c Local Stress
162c
163 DO ir=1,nptr
164 DO is=1,npts
165 DO il=1,nlay
166 DO it=1,nptt
167 lbuft => elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)
168 lbufs => elbuf_tab(ng )%BUFLY(il)%LBUF(ir,is,it)
169 lbuft%SIG(kk1(1)+i1) = lbufs%SIG(kk(1)+i)
170 lbuft%SIG(kk1(2)+i1) = lbufs%SIG(kk(2)+i)
171 lbuft%SIG(kk1(3)+i1) = lbufs%SIG(kk(3)+i)
172 lbuft%SIG(kk1(4)+i1) = lbufs%SIG(kk(4)+i)
173 lbuft%SIG(kk1(5)+i1) = lbufs%SIG(kk(5)+i)
174 END DO
175 END DO
176 END DO
177 END DO
178c
179c pla
180c
181 IF (gbuft%G_PLA > 0) THEN
182 DO il=1,nlay
183 DO ir=1,nptr
184 DO is=1,npts
185 DO it=1,nptt
186 elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)%PLA(i1) =
187 . elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%PLA(i)
188 END DO
189 END DO
190 END DO
191 END DO
192 ENDIF
193c
194c Uvar
195c
196 IF (mlw>=28 .AND. mlw/=32) THEN
197 DO il=1,nlay
198 DO ir=1,nptr
199 DO is=1,npts
200 DO it=1,nptt
201 DO k=1,elbuf_tab(ng)%BUFLY(il)%NVAR_MAT
202 elbuf_tab(ng1)%BUFLY(il)%MAT(ir,is,it)%VAR(nel1*(k-1)+i1)=
203 . elbuf_tab(ng )%BUFLY(il)%MAT(ir,is,it)%VAR(nel*(k-1)+i)
204 END DO
205 END DO
206 END DO
207 END DO
208 END DO
209 END IF
210c
211c sig moyen
212! IF (NLAY > 1) THEN
213! DO K=1,NLAY
214! DO j=1,5
215! ELBUF_TAB(NG1)%BUFLY(K)%SIGPT(I1) =
216! . ELBUF_TAB(NG)%BUFLY(K)%SIGPT(I)
217! END DO
218! END DO
219! ELSE
220! II = 5*(I1-1)
221! JJ = 5*(I-1)
222! DO K=1,NPT
223! DO J=1,5
224! ELBUF_TAB(NG1)%BUFLY(1)%SIGPT(II+I1) =
225! . ELBUF_TAB(NG)%BUFLY(1)%SIGPT(JJ+I)
226! END DO
227! END DO
228! ENDIF
229
230c-----
231 END DO ! IB=1,3
232c---------------------------------------------------
233c IB=4
234c---------------------------------------------------
235 m = sh3tree(2,n)+3
236 ng1 = sh3tree(4,m)
237
238 nel1 = iparg(2,ng1)
239 nft1 = iparg(3,ng1)
240 gbuft => elbuf_tab(ng1)%GBUF
241 i1 = m-nft1
242!
243 DO k=1,8 ! length max of GBUF%G_STRA = 8
244 kk(k) = nel *(k-1)
245 kk1(k) = nel1*(k-1)
246 ENDDO
247!
248 gbuft%FOR(kk1(1)+i1) = gbufs%FOR(kk(1)+i)
249 gbuft%FOR(kk1(2)+i1) = gbufs%FOR(kk(2)+i)
250 gbuft%FOR(kk1(3)+i1) = gbufs%FOR(kk(3)+i)
251 gbuft%FOR(kk1(4)+i1) = gbufs%FOR(kk(4)+i)
252 gbuft%FOR(kk1(5)+i1) = gbufs%FOR(kk(5)+i)
253c
254 gbuft%MOM(kk1(1)+i1) = gbufs%MOM(kk(1)+i)
255 gbuft%MOM(kk1(2)+i1) = gbufs%MOM(kk(2)+i)
256 gbuft%MOM(kk1(3)+i1) = gbufs%MOM(kk(3)+i)
257c
258 gbuft%THK(i1) = gbufs%THK(i) !thk
259 gbuft%OFF(i1) = gbufs%OFF(i)
260c
261
262c ener totale approximation
263 gbuft%EINT(i1) = gbufs%EINT(i)*s2wake(ib)/stot
264 gbuft%EINT(i1+nel1) = gbufs%EINT(i+nel)*s2wake(ib)/stot
265c
266c
267 IF (gbuft%G_EPSD > 0) THEN
268 gbuft%EPSD(i1) = gbufs%EPSD(i) ! eps_dot
269 ENDIF
270c
271 IF (istra > 0) THEN
272 DO k=1,8 ! deformations
273 gbuft%STRA(kk1(k)+i1) = gbufs%STRA(kk(k)+i)
274 END DO
275 END IF
276c
277 IF (iexpan/=0) THEN
278 gbuft%TEMP(i1)=gbufs%TEMP(i)
279 END IF
280c
281c Local Stress
282c
283 IF (igtyp == 1) THEN
284 DO ir=1,nptr
285 DO is=1,npts
286 DO il=1,nlay
287 DO it=1,nptt
288 lbuft => elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)
289 lbufs => elbuf_tab(ng )%BUFLY(il)%LBUF(ir,is,it)
290 lbuft%SIG(kk1(1)+i1) = lbufs%SIG(kk(1)+i)
291 lbuft%SIG(kk1(2)+i1) = lbufs%SIG(kk(2)+i)
292 lbuft%SIG(kk1(3)+i1) = lbufs%SIG(kk(3)+i)
293 lbuft%SIG(kk1(4)+i1) =-lbufs%SIG(kk(4)+i)
294 lbuft%SIG(kk1(5)+i1) =-lbufs%SIG(kk(5)+i)
295 END DO
296 END DO
297 END DO
298 END DO
299 ELSE
300 DO ir=1,nptr
301 DO is=1,npts
302 DO il=1,nlay
303 DO it=1,nptt
304 lbuft => elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)
305 lbufs => elbuf_tab(ng )%BUFLY(il)%LBUF(ir,is,it)
306 lbuft%SIG(kk1(1)+i1) = lbufs%SIG(kk(1)+i)
307 lbuft%SIG(kk1(2)+i1) = lbufs%SIG(kk(2)+i)
308 lbuft%SIG(kk1(3)+i1) = lbufs%SIG(kk(3)+i)
309 lbuft%SIG(kk1(4)+i1) = lbufs%SIG(kk(4)+i)
310 lbuft%SIG(kk1(5)+i1) = lbufs%SIG(kk(5)+i)
311 END DO
312 END DO
313 END DO
314 END DO
315 END IF
316c
317c pla
318c
319 IF (gbuft%G_PLA > 0) THEN
320 DO il=1,nlay
321 DO ir=1,nptr
322 DO is=1,npts
323 DO it=1,nptt
324 elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)%PLA(i1) =
325 . elbuf_tab(ng )%BUFLY(il)%LBUF(ir,is,it)%PLA(i)
326 END DO
327 END DO
328 END DO
329 END DO
330 ENDIF
331c
332c Uvar
333c
334 IF (mlw>=28 .AND. mlw/=32) THEN
335 DO il=1,nlay
336 DO ir=1,nptr
337 DO is=1,npts
338 DO it=1,nptt
339 DO k=1,elbuf_tab(ng)%BUFLY(il)%NVAR_MAT
340 elbuf_tab(ng1)%BUFLY(il)%MAT(ir,is,it)%VAR(nel1*(k-1)+i1)=
341 . elbuf_tab(ng )%BUFLY(il)%MAT(ir,is,it)%VAR(nel*(k-1)+i)
342 END DO
343 END DO
344 END DO
345 END DO
346 END DO
347 END IF
348
349c
350c sig moyen
351! IF (NLAY > 1) THEN
352! DO IL=1,NLAY
353! BUFLY => ELBUF_TAB(NG)%BUFLY(IL)
354! DO K=1,5
355! BUFLY%SIGPT(I1+K) = BUFLY%SIGPT(I+K)
356! END DO
357! END DO
358! ELSE
359! BUFLY => ELBUF_TAB(NG)%BUFLY(1)
360! II = 5*(I1-1)
361! JJ = 5*(I-1)
362! DO IT=1,NPT
363! II = (IT-1)*NEL*5
364! JJ = (IT-1)*NEL1*5
365! DO K=1,5
366! BUFLY%SIGPT(II+K) = BUFLY%SIGPT(JJ+K)
367! END DO
368! END DO
369! ENDIF
370c---------------------------------------------
371c reset source element variables
372c---------------------------------------------
373 gbufs%OFF(i) =-abs(gbufs%OFF(i))
374!
375 gbufs%FOR(kk(1)+i) = zero
376 gbufs%FOR(kk(2)+i) = zero
377 gbufs%FOR(kk(3)+i) = zero
378 gbufs%FOR(kk(4)+i) = zero
379 gbufs%FOR(kk(5)+i) = zero
380!
381 gbufs%MOM(kk(1)+i) = zero
382 gbufs%MOM(kk(2)+i) = zero
383 gbufs%MOM(kk(3)+i) = zero
384 gbufs%EINT(i) = zero
385 gbufs%EINT(i+nel) = zero
386 IF (gbufs%G_EPSD > 0) gbufs%EPSD(i) = zero
387 IF (istra > 0) THEN ! deformations
388 DO k=1,8
389 gbufs%STRA(kk(k)+i) = zero
390 END DO
391 END IF
392c
393 DO ir=1,nptr
394 DO is=1,npts
395 DO il=1,nlay
396 DO it=1,nptt
397 DO k=1,5
398 elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%SIG(kk(k)+i)=zero
399 ENDDO
400 elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%PLA(i)=zero
401 END DO
402 END DO
403 END DO
404 END DO
405c
406c sig moyen
407c IF (NLAY > 1) THEN
408c DO K=1,NLAY
409c BUFLY => ELBUF_TAB(NG)%BUFLY(K)
410c DO J=1,5
411c BUFLY%SIGPT(J)=ZERO
412c END DO
413c END DO
414c ELSE
415c BUFLY => ELBUF_TAB(NG)%BUFLY(1)
416c DO K=1,NPT
417c II = (K-1)*NEL*5
418c DO J=1,5
419c BUFLY%SIGPT(II+J)=ZERO
420c END DO
421c END DO
422c ENDIF
423C-----------
424 RETURN
425 END
426
admmap3
subroutine admmap3(n, ixtg, x, iparg, elbuf_tab, igeo, ipm, sh3tree)
Definition admmap3.F:35
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
remesh_mod
Definition remesh_mod.F:50