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