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 33 of file admmap3.F.

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
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