OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
admmap4.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 admmap4 (n, ixc, x, iparg, elbuf_tab, igeo, ipm, sh4tree)

Function/Subroutine Documentation

◆ admmap4()

subroutine admmap4 ( integer n,
integer, dimension(nixc,*) ixc,
x,
integer, dimension(nparg,*) iparg,
type(elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm,
integer, dimension(ksh4tree,*) sh4tree )

Definition at line 34 of file admmap4.F.

36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE remesh_mod
40 USE elbufdef_mod
41 use element_mod , only : nixc
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, IXC(NIXC,*), IPARG(NPARG,*),
56 . IGEO(NPROPGI,*), IPM(NPROPMI,*), SH4TREE(KSH4TREE,*)
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,IPT,NPTR,NPTS,NPTT,NLAY,
64 . I,J,K,II,JJ,I1,IG,NG,NG1,NEL1,NFT1,MLW,NEL,ISTRA,
65 . IEXPAN,IH,LENS,LENM,LENF,NPTM,
66 . PTF,PTM,PTE,PTP,PTS,QTF,QTM,QTE,QTP,QTS,KK(12),KK1(12)
67 my_real
68 . nx,ny,nz,stot,x13,y13,z13,x24,y24,z24,zz
69 my_real
70 . qpg(2,4),s2wake(4),sk(2),st(2),mk(2),mt(2),
71 . shk(2),sht(2),z01(11,11)
72 TYPE(G_BUFEL_) ,POINTER :: GBUFS,GBUFT
73 TYPE(L_BUFEL_) ,POINTER :: LBUFS,LBUFT
74 TYPE(BUF_LAY_) ,POINTER :: BUFLY
75C---------------------------
76 DATA qpg/-0.5,-0.5,
77 . 0.5,-0.5,
78 . 0.5, 0.5,
79 . -0.5, 0.5/
80 DATA z01/
81 1 0. ,0. ,0. ,0. ,0. ,
82 1 0. ,0. ,0. ,0. ,0. ,0. ,
83 2 -.5 ,0.5 ,0. ,0. ,0. ,
84 2 0. ,0. ,0. ,0. ,0. ,0. ,
85 3 -.5 ,0. ,0.5 ,0. ,0. ,
86 3 0. ,0. ,0. ,0. ,0. ,0. ,
87 4 -.5 ,-.1666667,0.1666667,0.5 ,0. ,
88 4 0. ,0. ,0. ,0. ,0. ,0. ,
89 5 -.5 ,-.25 ,0. ,0.25 ,0.5 ,
90 5 0. ,0. ,0. ,0. ,0. ,0. ,
91 6 -.5 ,-.3 ,-.1 ,0.1 ,0.3 ,
92 6 0.5 ,0. ,0. ,0. ,0. ,0. ,
93 7 -.5 ,-.3333333,-.1666667,0.0 ,0.1666667,
94 7 0.3333333,0.5 ,0. ,0. ,0. ,0. ,
95 8 -.5 ,-.3571429,-.2142857,-.0714286,0.0714286,
96 8 0.2142857,0.3571429,0.5 ,0. ,0. ,0. ,
97 9 -.5 ,-.375 ,-.25 ,-.125 ,0.0 ,
98 9 0.125 ,0.25 ,0.375 ,0.5 ,0. ,0. ,
99 a -.5 ,-.3888889,-.2777778,-.1666667,0.0555555,
100 a 0.0555555,0.1666667,0.2777778,0.3888889,0.5 ,0. ,
101 b -.5 ,-.4 ,-.3 ,-.2 ,-.1 ,
102 b 0. ,0.1 ,0.2 ,0.3 ,0.4 ,0.5 /
103C-----------------------------------------------
104 stot=zero
105 DO ib=1,4
106
107 m = sh4tree(2,n)+ib-1
108 n1 = ixc(2,m)
109 n2 = ixc(3,m)
110 n3 = ixc(4,m)
111 n4 = ixc(5,m)
112
113 x13 = x(1,n3) - x(1,n1)
114 y13 = x(2,n3) - x(2,n1)
115 z13 = x(3,n3) - x(3,n1)
116
117 x24 = x(1,n4) - x(1,n2)
118 y24 = x(2,n4) - x(2,n2)
119 z24 = x(3,n4) - x(3,n2)
120
121 nx = y13*z24 - z13*y24
122 ny = z13*x24 - x13*z24
123 nz = x13*y24 - y13*x24
124
125 s2wake(ib)=sqrt(nx*nx+ny*ny+nz*nz)
126 stot=stot+s2wake(ib)
127
128 END DO
129C-----------------------------------------------
130 ng =sh4tree(4,n)
131 mlw = iparg(1,ng)
132C IF (MLW == 0) GOTO 250
133C---
134 nel = iparg(2,ng)
135 nft = iparg(3,ng)
136 npt = iparg(6,ng)
137 istra= iparg(44,ng)
138 jhbe = iparg(23,ng)
139 igtyp= iparg(38,ng)
140 iexpan=iparg(49,ng)
141 i = n-nft
142
143 nptm = max(1,npt)
144 gbufs => elbuf_tab(ng)%GBUF
145 nlay = elbuf_tab(ng)%NLAY
146 nptr = elbuf_tab(ng)%NPTR
147 npts = elbuf_tab(ng)%NPTS
148 nptt = elbuf_tab(ng)%NPTT
149!
150 DO k=1,12 ! length max of GBUF%G_HOURG = 12
151 kk(k) = nel *(k-1)
152 ENDDO
153!
154c----------------------------------------------
155 DO ib=1,4
156
157 m = sh4tree(2,n)+ib-1
158 ng1= sh4tree(4,m)
159
160 nel1 = iparg(2,ng1)
161 nft1 = iparg(3,ng1)
162 i1 = m-nft1
163 gbuft => elbuf_tab(ng1)%GBUF
164!
165 DO k=1,12 ! length max of GBUF%G_HOURG = 12
166 kk1(k) = nel1*(k-1)
167 ENDDO
168!
169c----
170 IF (jhbe == 11) THEN ! Batoz
171c----
172 gbuft%THK(i1) = gbufs%THK(i) !thk
173C ener totale approximation
174 gbuft%EINT(i1) = gbufs%EINT(i)*s2wake(ib)/stot
175 gbuft%EINT(i1+nel1) = gbufs%EINT(i+nel)*s2wake(ib)/stot
176c
177 gbuft%OFF(i1) = gbufs%OFF(i)
178c
179 IF (gbuft%G_EPSD > 0) THEN
180 gbuft%EPSD(i1) = gbufs%EPSD(i) ! eps_dot
181 ENDIF
182c
183 IF (istra > 0) THEN
184 DO k=1,8 ! deformations
185 gbuft%STRA(kk1(k)+i1)=gbufs%STRA(kk(k)+i)
186 END DO
187 END IF
188c
189 IF (iexpan /= 0) THEN
190 gbuft%TEMP(i1)=gbufs%TEMP(i)
191 END IF
192c
193C pla
194c
195 IF (gbuft%G_PLA > 0) THEN
196 DO il=1,nlay
197 DO ir=1,nptr
198 DO is=1,npts
199 DO it=1,nptt
200 elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)%PLA(i1) =
201 . elbuf_tab(ng) %BUFLY(il)%LBUF(ir,is,it)%PLA(i)
202 END DO
203 END DO
204 END DO
205 END DO
206 ENDIF
207c
208C Stress
209c
210 DO il=1,nlay
211 DO ir=1,nptr
212 DO is=1,npts
213 DO it=1,nptt
214 lbuft => elbuf_tab(ng1)%BUFLY(il)%LBUF(ir,is,it)
215 lbufs => elbuf_tab(ng )%BUFLY(il)%LBUF(ir,is,it)
216 lbuft%SIG(kk1(1)+i1) = lbufs%SIG(kk(1)+i)
217 lbuft%SIG(kk1(2)+i1) = lbufs%SIG(kk(2)+i)
218 lbuft%SIG(kk1(3)+i1) = lbufs%SIG(kk(3)+i)
219 lbuft%SIG(kk1(4)+i1) = lbufs%SIG(kk(4)+i)
220 lbuft%SIG(kk1(5)+i1) = lbufs%SIG(kk(5)+i)
221 END DO
222 END DO
223 END DO
224 END DO
225c
226C Uvar
227c
228 IF (mlw>=28 .AND. mlw/=32) THEN
229 DO il=1,nlay
230 DO ir=1,nptr
231 DO is=1,npts
232 DO it=1,nptt
233 DO k=1,elbuf_tab(ng)%BUFLY(il)%NVAR_MAT
234 elbuf_tab(ng1)%BUFLY(il)%MAT(ir,is,it)%VAR(nel1*(k-1)+i1)=
235 . elbuf_tab(ng)%BUFLY(il)%MAT(ir,is,it)%VAR(nel*(k-1)+i)
236 END DO
237 END DO
238 END DO
239 END DO
240 END DO
241 END IF
242c
243 lenf = nel*5
244 lenm = nel*3
245 lens = nel*8
246 ptf = 5*nel*(ib-1)
247 ptm = 3*nel*(ib-1)
248 DO ir=1,nptr
249 DO is=1,npts
250 ig = nptr*(is-1) + ir
251 qtf = 5*nel1*(ig-1)
252 qtm = 3*nel1*(ig-1)
253 gbuft%FORPG(qtf+kk1(1)+i1)=gbufs%FORPG(ptf+kk(1)+i)
254 gbuft%FORPG(qtf+kk1(2)+i1)=gbufs%FORPG(ptf+kk(2)+i)
255 gbuft%FORPG(qtf+kk1(3)+i1)=gbufs%FORPG(ptf+kk(3)+i)
256 gbuft%FORPG(qtf+kk1(4)+i1)=gbufs%FORPG(ptf+kk(4)+i)
257 gbuft%FORPG(qtf+kk1(5)+i1)=gbufs%FORPG(ptf+kk(5)+i)
258!
259 gbuft%MOMPG(qtm+kk1(1)+i1)=gbufs%MOMPG(ptm+kk(1)+i)
260 gbuft%MOMPG(qtm+kk1(2)+i1)=gbufs%MOMPG(ptm+kk(2)+i)
261 gbuft%MOMPG(qtm+kk1(3)+i1)=gbufs%MOMPG(ptm+kk(3)+i)
262 ENDDO
263 ENDDO
264C end Batoz
265c----
266 ELSE !Q4 & QEPH
267c----
268 gbuft%FOR(kk1(1)+i1) = gbufs%FOR(kk(1)+i)
269 gbuft%FOR(kk1(2)+i1) = gbufs%FOR(kk(2)+i)
270 gbuft%FOR(kk1(3)+i1) = gbufs%FOR(kk(3)+i)
271 gbuft%FOR(kk1(4)+i1) = gbufs%FOR(kk(4)+i)
272 gbuft%FOR(kk1(5)+i1) = gbufs%FOR(kk(5)+i)
273!
274 gbuft%MOM(kk1(1)+i1) = gbufs%MOM(kk(1)+i)
275 gbuft%MOM(kk1(2)+i1) = gbufs%MOM(kk(2)+i)
276 gbuft%MOM(kk1(3)+i1) = gbufs%MOM(kk(3)+i)
277c
278 gbuft%THK(i1) = gbufs%THK(i) !thk
279c
280 IF (jhbe == 22 .OR. jhbe == 23) THEN
281 ih = (i-1)*12
282 st(1) = gbufs%HOURG(kk(1)+i)
283 st(2) = -gbufs%HOURG(kk(2)+i)
284 mt(1) = gbufs%HOURG(kk(3)+i)
285 mt(2) = -gbufs%HOURG(kk(4)+i)
286 sk(1) = -gbufs%HOURG(kk(7)+i)
287 sk(2) = gbufs%HOURG(kk(8)+i)
288 mk(1) = -gbufs%HOURG(kk(9)+i)
289 mk(2) = gbufs%HOURG(kk(10)+i)
290 sht(1)= gbufs%HOURG(kk(5)+i)
291 sht(2)= -gbufs%HOURG(kk(6)+i)
292 shk(1)= -gbufs%HOURG(kk(11)+i)
293 shk(2)= gbufs%HOURG(kk(12)+i)
294
295 IF (npt==0) THEN
296 gbuft%FOR(kk1(1)+i1) = gbuft%FOR(kk1(1)+i1)
297 . + st(1)*qpg(2,ib)+sk(1)*qpg(1,ib)
298 gbuft%FOR(kk1(2)+i1) = gbuft%FOR(kk1(2)+i1)
299 . + st(2)*qpg(2,ib)+sk(2)*qpg(1,ib)
300C GBUFT%FOR(KK1(3)+I1) = GBUFT%FOR(KK1(3)+I1)
301 gbuft%FOR(kk1(4)+i1) = gbuft%FOR(kk1(4)+i1)
302 . + sht(2)*qpg(2,ib)+shk(2)*qpg(1,ib)
303 gbuft%FOR(kk1(5)+i1) = gbuft%FOR(kk1(5)+i1)
304 . + sht(1)*qpg(2,ib)+shk(1)*qpg(1,ib)
305!
306 gbuft%MOM(kk1(1)+i1) = gbuft%MOM(kk1(1)+i1)
307 . + mt(1)*qpg(2,ib)+mk(1)*qpg(1,ib)
308 gbuft%MOM(kk1(2)+i1) = gbuft%MOM(kk1(2)+i1)
309 . + mt(2)*qpg(2,ib)+mk(2)*qpg(1,ib)
310C GBUFT%MOM(KK1(3)+I1) = GBUFT%MOM(KK1(3)+I1)
311 ELSE
312 CONTINUE
313 END IF
314c---
315 DO k=1,12 ! hour
316 gbuft%HOURG(kk1(k)+i1) = zero
317 END DO
318c
319 ELSE ! JHBE
320 DO k=1,5 ! hour
321 gbuft%HOURG(kk1(k)+i1) = gbufs%HOURG(kk(k)+i)
322 END DO
323 END IF
324C ener totale approximation
325 gbuft%EINT(i1) = gbufs%EINT(i)*s2wake(ib)/stot
326 gbuft%EINT(i1+nel1) = gbufs%EINT(i+nel)*s2wake(ib)/stot
327c
328 gbuft%OFF(i1) = gbufs%OFF(i)
329 IF (gbuft%G_EPSD > 0) THEN
330 gbuft%EPSD(i1) = gbufs%EPSD(i) ! eps_dot
331 ENDIF
332 IF (iexpan/=0) THEN
333 gbuft%TEMP(i1) = gbufs%TEMP(i)
334 END IF
335c
336 IF (istra > 0) THEN
337 DO k=1,8 ! deformations
338 gbuft%STRA(kk1(k)+i1)=gbufs%STRA(kk(k)+i)
339 END DO
340 END IF
341c
342C Stress
343c
344 DO il=1,nlay
345 DO it=1,nptt
346 lbuft => elbuf_tab(ng1)%BUFLY(il)%LBUF(1,1,it)
347 lbufs => elbuf_tab(ng )%BUFLY(il)%LBUF(1,1,it)
348 lbuft%SIG(kk1(1)+i1) = lbufs%SIG(kk(1)+i)
349 lbuft%SIG(kk1(2)+i1) = lbufs%SIG(kk(2)+i)
350 lbuft%SIG(kk1(3)+i1) = lbufs%SIG(kk(3)+i)
351 lbuft%SIG(kk1(4)+i1) = lbufs%SIG(kk(4)+i)
352 lbuft%SIG(kk1(5)+i1) = lbufs%SIG(kk(5)+i)
353 END DO
354 END DO
355c
356 IF (jhbe == 22 .OR. jhbe == 23) THEN
357 DO il=1,nlay
358 DO it=1,nptt
359 lbuft => elbuf_tab(ng1)%BUFLY(il)%LBUF(1,1,it)
360 ipt = il*it
361 zz = gbuft%THK(i1)*z01(ipt,npt)
362 lbuft%SIG(kk1(1)+i1) = lbuft%SIG(kk1(1)+i1)
363 . + (st(1)+zz*mt(1))*qpg(2,ib)
364 . + (sk(1)+zz*mk(1))*qpg(1,ib)
365 lbuft%SIG(kk1(2)+i1) = lbuft%SIG(kk1(2)+i1)
366 . + (st(2)+zz*mt(2))*qpg(2,ib)
367 . + (sk(2)+zz*mk(2))*qpg(1,ib)
368C LBUFT%SIG(KK1(3)+I1) = LBUFT%SIG(KK1(3)+I1)
369 lbuft%SIG(kk1(4)+i1) = lbuft%SIG(kk1(4)+i1)
370 . + sht(2)*qpg(2,ib) + shk(2)*qpg(1,ib)
371 lbuft%SIG(kk1(5)+i1) = lbuft%SIG(kk1(5)+i1)
372 . + sht(1)*qpg(2,ib) + shk(1)*qpg(1,ib)
373 END DO
374 END DO
375 END IF
376c
377C pla
378c
379 IF (gbuft%G_PLA > 0) THEN
380 DO il=1,nlay
381 DO it=1,nptt
382 elbuf_tab(ng1)%BUFLY(il)%LBUF(1,1,it)%PLA(i1) =
383 . elbuf_tab(ng )%BUFLY(il)%LBUF(1,1,it)%PLA(i)
384 END DO
385 END DO
386 ENDIF
387c
388C uvar
389c
390 IF (mlw>=28 .AND. mlw/=32) THEN
391 DO il=1,nlay
392 DO it=1,nptt
393 DO k=1,elbuf_tab(ng)%BUFLY(il)%NVAR_MAT
394 elbuf_tab(ng1)%BUFLY(il)%MAT(1,1,it)%VAR(nel1*(k-1)+i1)=
395 . elbuf_tab(ng )%BUFLY(il)%MAT(1,1,it)%VAR(nel*(k-1)+i)
396 END DO
397 END DO
398 END DO
399 END IF
400c
401C---- end Q4 & QEPH
402C
403 END IF
404 END DO ! IB=1,4
405c---------------------------------------------
406C Reset Source Variable elements
407c---------------------------------------------
408 gbufs%OFF(i) =-abs(gbufs%OFF(i))
409!
410 gbufs%FOR(kk(1)+i) = zero
411 gbufs%FOR(kk(2)+i) = zero
412 gbufs%FOR(kk(3)+i) = zero
413 gbufs%FOR(kk(4)+i) = zero
414 gbufs%FOR(kk(5)+i) = zero
415!
416 gbufs%MOM(kk(1)+i) = zero
417 gbufs%MOM(kk(2)+i) = zero
418 gbufs%MOM(kk(3)+i) = zero
419 gbufs%EINT(i) = zero
420 gbufs%EINT(i+nel) = zero
421 IF (gbufs%G_EPSD > 0) gbufs%EPSD(i) = zero
422 IF (istra > 0) THEN ! deformations
423 DO k=1,8
424 gbufs%STRA(kk(k)+i) = zero
425 END DO
426 END IF
427c
428 DO ir=1,nptr
429 DO is=1,npts
430 DO il=1,nlay
431 DO it=1,nptt
432 DO k=1,5
433 elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)%SIG(kk(k)+i)=zero
434 ENDDO
435 END DO
436 END DO
437 END DO
438 END DO
439c
440C sig moyen
441! IF (NLAY > 1) THEN
442! DO IL=1,NLAY
443! BUFLY => ELBUF_TAB(NG)%BUFLY(IL)
444! DO K=1,5
445! BUFLY%SIGPT(K)=ZERO
446! END DO
447! END DO
448! ELSE
449! BUFLY => ELBUF_TAB(NG)%BUFLY(1)
450! DO IPT=1,NPT
451! II = (IPT-1)*NEL*5
452! DO K=1,5
453! BUFLY%SIGPT(II+K)=ZERO
454! END DO
455! END DO
456! ENDIF
457!c
458! IF (JHBE==11) THEN
459! DO IR=1,NPTR
460! DO IS=1,NPTS
461! IG = NPTR*(IS-1) + IR
462! PTF = (IG-1)*NEL*5
463! JJ = 5*(I-1)
464! DO K=1,5 ! for
465! GBUFS%FORPG(PTF+KK(K)+I) = ZERO
466! END DO
467! PTM = (IG-1)*NEL*3
468! JJ = 3*(I-1)
469! DO K=1,3 ! mom
470! GBUFS%MOMPG(PTM+KK(K)+I) = ZERO
471! END DO
472!
473! IF (ISTRA /= 0) THEN
474! PTE = 8*NEL*(IG-1)
475! JJ = 8*(I-1)
476! DO K=1,8 ! deformations
477! GBUFS%STRPG(PTE+KK(K)+I) = ZERO
478! END DO
479! END IF
480! END DO
481! END DO
482! END IF
483c
484C-----------
485 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