OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
admmap3.F File Reference
#include "implicit_f.inc"
#include "vect01_c.inc"
#include "com01_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine admmap3 (n, ixtg, x, iparg, elbuf_tab, igeo, ipm, sh3tree)

Function/Subroutine Documentation

◆ admmap3()

subroutine admmap3 ( integer n,
integer, dimension(nixtg,*) ixtg,
x,
integer, dimension(nparg,*) iparg,
type(elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm,
integer, dimension(ksh3tree,*) sh3tree )

Definition at line 34 of file admmap3.F.

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