OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
admregul.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "remesh_c.inc"
#include "task_c.inc"
#include "scr17_c.inc"
#include "lockon.inc"
#include "lockoff.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine admregul (ixc, ipartc, ixtg, iparttg, ipart, itask, iparg, x, ms, in, elbuf_tab, nodft, nodlt, igeo, ipm, sh4tree, msc, inc, sh3tree, mstg, intg, ptg, mscnd, incnd, pm, mcp, mcpc, mcptg, itherm_fe)

Function/Subroutine Documentation

◆ admregul()

subroutine admregul ( integer, dimension(nixc,*) ixc,
integer, dimension(*) ipartc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) iparttg,
integer, dimension(lipart1,*) ipart,
integer itask,
integer, dimension(nparg,*) iparg,
x,
ms,
in,
type(elbuf_struct_), dimension(ngroup) elbuf_tab,
integer nodft,
integer nodlt,
integer, dimension(npropgi,*) igeo,
integer, dimension(npropmi,*) ipm,
integer, dimension(ksh4tree,*) sh4tree,
msc,
inc,
integer, dimension(ksh3tree,*) sh3tree,
mstg,
intg,
ptg,
mscnd,
incnd,
pm,
mcp,
mcpc,
mcptg,
integer, intent(in) itherm_fe )

Definition at line 39 of file admregul.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE remesh_mod
49 USE elbufdef_mod
50 USE my_alloc_mod
51 use element_mod , only : nixc,nixtg
52C-----------------------------------------------
53C I m p l i c i t T y p e s
54C-----------------------------------------------
55#include "implicit_f.inc"
56#include "comlock.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "com01_c.inc"
61#include "com04_c.inc"
62#include "param_c.inc"
63#include "parit_c.inc"
64#include "remesh_c.inc"
65#include "task_c.inc"
66#include "scr17_c.inc"
67C-----------------------------------------------
68C D u m m y A r g u m e n t s
69C-----------------------------------------------
70 INTEGER IXC(NIXC,*),IPARTC(*),IXTG(NIXTG,*),IPARTTG(*),
71 . IPART(LIPART1,*),ITASK,IPARG(NPARG,*),
72 . NODFT, NODLT, IGEO(NPROPGI,*), IPM(NPROPMI,*),
73 . SH4TREE(KSH4TREE,*),SH3TREE(KSH3TREE,*)
74 integer ,INTENT(IN) :: ITHERM_FE
75 my_real
76 . x(3,*),ms(*),in(*),msc(*), inc(*),
77 . mstg(*), intg(*), ptg(3,*), mscnd(*), incnd(*),
78 . pm(npropm,*), mcp(*), mcpc(*), mcptg(*)
79 TYPE(ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
80C-----------------------------------------------
81C L o c a l V a r i a b l e s
82C-----------------------------------------------
83 INTEGER SH4FT, SH4LT, SH3FT, SH3LT
84 INTEGER NN,N,IB,M,N1,N2,N3,N4
85 INTEGER I,J,K,NG1,
86 . NA1, NA2, NA3, NA4, NA5, NA6, NA7, NA8, NA9, NA10, NA11,
87 . NA12, NA13,NA14,NA15,NA16,NA17,NA18,NA19,NA20,NA21,NA22,
88 . NA17A,NA17B,NB17A,NB17B,LLL,
89 . MATLY,MY_NUVAR,MY_NUVARR,NUVAR,NUVARR,II,IVAR,
90 . NA16A,NB16A,MPT,NPTM,NAM_S,NBM_S,IG,IH,IS,
91 . PTF,PTM,PTE,PTP,PTS,QTF,QTM,QTE,QTP,QTS,NPG
92 INTEGER LEVEL,NTMP,LEV,P,NI,MYLEV,IP
93 INTEGER NSKYML, WORK(70000)
94 INTEGER,DIMENSION(:), ALLOCATABLE :: KDIVIDE4
95 INTEGER,DIMENSION(:), ALLOCATABLE :: KDIVIDE3
96 INTEGER,DIMENSION(:), ALLOCATABLE :: ITRI
97 INTEGER,DIMENSION(:), ALLOCATABLE :: INDEX1
98 my_real
99 . msbig, inbig, mcpm, mcpn
100C-----------------------------------------------
101 CALL my_alloc(kdivide4,numelc)
102 CALL my_alloc(kdivide3,numeltg)
103 CALL my_alloc(itri,max(numelc,numeltg))
104 CALL my_alloc(index1,2*max(numelc,numeltg))
105
106 10 CONTINUE
107
108 IF(itask==0) THEN
109
110 ilevnod=0
111
112 DO nn=1,nsh4act
113 n=lsh4act(nn)
114 lev=sh4tree(3,n)
115 DO i=1,4
116 ni=ixc(i+1,n)-1
117 ilevnod(ni)=max(ilevnod(ni),lev)
118 END DO
119 END DO
120
121 DO nn=1,nsh3act
122 n=lsh3act(nn)
123 lev=sh3tree(3,n)
124 DO i=1,3
125 ni=ixtg(i+1,n)-1
126 ilevnod(ni)=max(ilevnod(ni),lev)
127 END DO
128 END DO
129
130 END IF
131
132 kadmrule=0
133C
134 CALL my_barrier
135C
136 IF(nsh4act/=0) kdivide4=0
137
138 sh4ft = 1+itask*nsh4act/ nthread
139 sh4lt = (itask+1)*nsh4act/nthread
140C
141 DO nn=sh4ft,sh4lt
142
143 n =lsh4act(nn)
144
145 level=sh4tree(3,n)
146 IF( level >= levelmax-1 ) cycle
147
148 DO i=1,4
149 ni=ixc(i+1,n)-1
150 lev=ilevnod(ni)
151 IF(lev-level > 1) THEN
152 kdivide4(n)=1
153 kadmrule=1
154 GO TO 100
155 END IF
156 END DO
157
158 100 CONTINUE
159 CALL sync_data(kdivide4(n))
160
161 END DO
162C
163 IF(nsh3act/=0) kdivide3=0
164
165 sh3ft = 1+itask*nsh3act/ nthread
166 sh3lt = (itask+1)*nsh3act/nthread
167C
168 DO nn=sh3ft,sh3lt
169
170 n =lsh3act(nn)
171
172 level=sh3tree(3,n)
173 IF( level >= levelmax-1 ) cycle
174
175 DO i=1,3
176 ni=ixtg(i+1,n)-1
177 lev=ilevnod(ni)
178 IF(lev-level > 1) THEN
179 kdivide3(n)=1
180 kadmrule=1
181 GO TO 200
182 END IF
183 END DO
184 200 CONTINUE
185 CALL sync_data(kdivide3(n))
186
187 END DO
188C
189 nskymsh4=0
190 nskymsh3=0
191C
192 CALL my_barrier
193C
194 IF(kadmrule==0) RETURN
195 DO nn=sh4ft,sh4lt
196 n =lsh4act(nn)
197
198 IF( kdivide4(n) == 0 ) cycle
199
200#include "lockon.inc"
201 iadmesh=1
202 IF(iparit/=0)THEN
203 nskyml =nskymsh4
204 nskymsh4 =nskymsh4+5
205 END IF
206#include "lockoff.inc"
207C---
208C Divide elt N
209C---
210 DO ib=1,4
211
212 m = sh4tree(2,n)+ib-1
213C
214 n1 = ixc(2,m)
215 n2 = ixc(3,m)
216 n3 = ixc(4,m)
217 n4 = ixc(5,m)
218C
219C wake up the son
220 sh4tree(3,m)=-sh4tree(3,m)-1
221#include "lockon.inc"
222 nsh4act=nsh4act+1
223 lsh4act(nsh4act)=m
224#include "lockoff.inc"
225C
226C 1/4 of the element mass has been stored
227 IF(iparit==0)THEN
228 IF(istatcnd==0)THEN
229#include "lockon.inc"
230 ms(n1)=ms(n1)+msc(m)
231 ms(n2)=ms(n2)+msc(m)
232 ms(n3)=ms(n3)+msc(m)
233 ms(n4)=ms(n4)+msc(m)
234 in(n1)=in(n1)+inc(m)
235 in(n2)=in(n2)+inc(m)
236 in(n3)=in(n3)+inc(m)
237 in(n4)=in(n4)+inc(m)
238#include "lockoff.inc"
239 ELSE
240#include "lockon.inc"
241 msbig=msc(m)
242 mscnd(n1)=mscnd(n1)+msbig
243 mscnd(n2)=mscnd(n2)+msbig
244 mscnd(n3)=mscnd(n3)+msbig
245 mscnd(n4)=mscnd(n4)+msbig
246 inbig=inc(m)
247 incnd(n1)=incnd(n1)+inbig
248 incnd(n2)=incnd(n2)+inbig
249 incnd(n3)=incnd(n3)+inbig
250 incnd(n4)=incnd(n4)+inbig
251#include "lockoff.inc"
252 END IF
253C
254 IF(itherm_fe > 0)THEN
255#include "lockon.inc"
256 mcpm=mcpc(m)
257 mcp(n1)=mcp(n1)+mcpm
258 mcp(n2)=mcp(n2)+mcpm
259 mcp(n3)=mcp(n3)+mcpm
260 mcp(n4)=mcp(n4)+mcpm
261#include "lockoff.inc"
262 END IF
263 ELSE
264 nskyml=nskyml+1
265 msh4sky(nskyml)=m
266 END IF
267C
268C map fields to the son
269 ng1 =sh4tree(4,m)
270 iparg(8,ng1)=0
271 END DO
272C
273 CALL admmap4(n, ixc, x, iparg, elbuf_tab,
274 . igeo, ipm ,sh4tree)
275C
276 n1 = ixc(2,n)
277 n2 = ixc(3,n)
278 n3 = ixc(4,n)
279 n4 = ixc(5,n)
280 IF(iparit==0)THEN
281 IF(istatcnd==0)THEN
282#include "lockon.inc"
283 ms(n1)=max(zero,ms(n1)-msc(n))
284 ms(n2)=max(zero,ms(n2)-msc(n))
285 ms(n3)=max(zero,ms(n3)-msc(n))
286 ms(n4)=max(zero,ms(n4)-msc(n))
287 in(n1)=max(zero,in(n1)-inc(n))
288 in(n2)=max(zero,in(n2)-inc(n))
289 in(n3)=max(zero,in(n3)-inc(n))
290 in(n4)=max(zero,in(n4)-inc(n))
291#include "lockoff.inc"
292 ELSE
293#include "lockon.inc"
294 msbig=msc(n)
295 mscnd(n1)=max(zero,mscnd(n1)-msbig)
296 mscnd(n2)=max(zero,mscnd(n2)-msbig)
297 mscnd(n3)=max(zero,mscnd(n3)-msbig)
298 mscnd(n4)=max(zero,mscnd(n4)-msbig)
299 inbig=inc(n)
300 incnd(n1)=max(zero,incnd(n1)-inbig)
301 incnd(n2)=max(zero,incnd(n2)-inbig)
302 incnd(n3)=max(zero,incnd(n3)-inbig)
303 incnd(n4)=max(zero,incnd(n4)-inbig)
304#include "lockoff.inc"
305 END IF
306C
307 IF(itherm_fe > 0)THEN
308#include "lockon.inc"
309 mcpn=mcpc(n)
310 mcp(n1)=max(zero,mcp(n1)-mcpn)
311 mcp(n2)=max(zero,mcp(n2)-mcpn)
312 mcp(n3)=max(zero,mcp(n3)-mcpn)
313 mcp(n4)=max(zero,mcp(n4)-mcpn)
314#include "lockoff.inc"
315 END IF
316 ELSE
317 nskyml=nskyml+1
318 msh4sky(nskyml)=-n
319 END IF
320C
321C goes to sleep
322 lsh4act(nn) =0
323 sh4tree(3,n)=-(sh4tree(3,n)+1)
324
325 END DO
326
327
328 DO nn=sh3ft,sh3lt
329 n =lsh3act(nn)
330
331 IF( kdivide3(n) == 0 ) cycle
332
333#include "lockon.inc"
334 iadmesh=1
335 IF(iparit/=0)THEN
336 nskyml=nskymsh3
337 nskymsh3 =nskymsh3+5
338 END IF
339#include "lockoff.inc"
340C---
341C Divide elt N
342C---
343 DO ib=1,4
344
345 m = sh3tree(2,n)+ib-1
346C
347 n1 = ixtg(2,m)
348 n2 = ixtg(3,m)
349 n3 = ixtg(4,m)
350C
351C wake up the son
352 sh3tree(3,m)=-sh3tree(3,m)-1
353#include "lockon.inc"
354 nsh3act=nsh3act+1
355 lsh3act(nsh3act)=m
356#include "lockoff.inc"
357C
358C 1/4 of the element mass has been stored
359 IF(iparit==0)THEN
360 IF(istatcnd==0)THEN
361#include "lockon.inc"
362 ms(n1)=ms(n1)+mstg(m)*ptg(1,m)
363 ms(n2)=ms(n2)+mstg(m)*ptg(2,m)
364 ms(n3)=ms(n3)+mstg(m)*ptg(3,m)
365 in(n1)=in(n1)+intg(m)*ptg(1,m)
366 in(n2)=in(n2)+intg(m)*ptg(2,m)
367 in(n3)=in(n3)+intg(m)*ptg(3,m)
368#include "lockoff.inc"
369 ELSE
370#include "lockon.inc"
371 msbig=mstg(m)
372 mscnd(n1)=mscnd(n1)+msbig
373 mscnd(n2)=mscnd(n2)+msbig
374 mscnd(n3)=mscnd(n3)+msbig
375 inbig=intg(m)
376 incnd(n1)=incnd(n1)+inbig
377 incnd(n2)=incnd(n2)+inbig
378 incnd(n3)=incnd(n3)+inbig
379#include "lockoff.inc"
380 END IF
381C
382 IF(itherm_fe > 0)THEN
383#include "lockon.inc"
384 mcp(n1)=mcp(n1)+mcptg(m)*ptg(1,m)
385 mcp(n2)=mcp(n2)+mcptg(m)*ptg(2,m)
386 mcp(n3)=mcp(n3)+mcptg(m)*ptg(3,m)
387#include "lockoff.inc"
388 END IF
389 ELSE
390 nskyml=nskyml+1
391 msh3sky(nskyml)=m
392 END IF
393C
394C map fields to the son
395 ng1 =sh3tree(4,m)
396 iparg(8,ng1)=0
397 END DO
398C
399 CALL admmap3(n, ixtg, x, iparg, elbuf_tab,
400 . igeo, ipm , sh3tree)
401C
402 n1 = ixtg(2,n)
403 n2 = ixtg(3,n)
404 n3 = ixtg(4,n)
405 IF(iparit==0)THEN
406 IF(istatcnd==0)THEN
407#include "lockon.inc"
408 ms(n1)=max(zero,ms(n1)-mstg(n)*ptg(1,n))
409 ms(n2)=max(zero,ms(n2)-mstg(n)*ptg(2,n))
410 ms(n3)=max(zero,ms(n3)-mstg(n)*ptg(3,n))
411 in(n1)=max(zero,in(n1)-intg(n)*ptg(1,n))
412 in(n2)=max(zero,in(n2)-intg(n)*ptg(2,n))
413 in(n3)=max(zero,in(n3)-intg(n)*ptg(3,n))
414#include "lockoff.inc"
415 ELSE
416#include "lockon.inc"
417 msbig=mstg(n)
418 mscnd(n1)=max(zero,mscnd(n1)-msbig)
419 mscnd(n2)=max(zero,mscnd(n2)-msbig)
420 mscnd(n3)=max(zero,mscnd(n3)-msbig)
421 inbig=intg(n)
422 incnd(n1)=max(zero,incnd(n1)-inbig)
423 incnd(n2)=max(zero,incnd(n2)-inbig)
424 incnd(n3)=max(zero,incnd(n3)-inbig)
425#include "lockoff.inc"
426 END IF
427C
428 IF(itherm_fe > 0)THEN
429#include "lockon.inc"
430 mcp(n1)=max(zero,mcp(n1)-mcptg(n)*ptg(1,n))
431 mcp(n2)=max(zero,mcp(n2)-mcptg(n)*ptg(2,n))
432 mcp(n3)=max(zero,mcp(n3)-mcptg(n)*ptg(3,n))
433#include "lockoff.inc"
434 END IF
435 ELSE
436 nskyml=nskyml+1
437 msh3sky(nskyml)=-n
438 END IF
439C
440C goes to sleep
441 lsh3act(nn) =0
442 sh3tree(3,n)=-(sh3tree(3,n)+1)
443
444 END DO
445C
446 CALL my_barrier
447C--
448 IF(iparit/=0 .AND. itask==0 .AND. nskymsh4 > 0)THEN
449 DO i = 1, nskymsh4
450 itri(i) = ixc(nixc,abs(msh4sky(i)))
451 ENDDO
452 CALL my_orders(0,work,itri,index1,nskymsh4,1)
453 IF(istatcnd==0)THEN
454 DO j = 1, nskymsh4
455 n=msh4sky(index1(j))
456 IF(n < 0)THEN
457 n=-n
458 DO k=1,4
459 i = ixc(k+1,n)
460 ms(i) = max(zero , ms(i) - msc(n))
461 in(i) = max(zero , in(i) - inc(n))
462 END DO
463 ELSE
464 DO k=1,4
465 i = ixc(k+1,n)
466 ms(i) = ms(i) + msc(n)
467 in(i) = in(i) + inc(n)
468 END DO
469 END IF
470 END DO
471 ELSE
472 DO j = 1, nskymsh4
473 n=msh4sky(index1(j))
474 IF(n < 0)THEN
475 n=-n
476 msbig=msc(n)
477 inbig=inc(n)
478 DO k=1,4
479 i = ixc(k+1,n)
480 mscnd(i) = max(zero , mscnd(i) - msbig)
481 incnd(i) = max(zero , incnd(i) - inbig)
482 END DO
483 ELSE
484 msbig=msc(n)
485 inbig=inc(n)
486 DO k=1,4
487 i = ixc(k+1,n)
488 mscnd(i) = mscnd(i) + msbig
489 incnd(i) = incnd(i) + inbig
490 END DO
491 END IF
492 END DO
493 END IF
494C
495 IF(itherm_fe > 0)THEN
496 DO j = 1, nskymsh4
497 n=msh4sky(index1(j))
498 IF(n < 0)THEN
499 n=-n
500 DO k=1,4
501 i = ixc(k+1,n)
502 mcp(i) = max(zero , mcp(i) - mcpc(n))
503 END DO
504 ELSE
505 DO k=1,4
506 i = ixc(k+1,n)
507 mcp(i) = mcp(i) + mcpc(n)
508 END DO
509 END IF
510 END DO
511 END IF
512C
513 END IF
514C--
515 IF(iparit/=0 .AND. itask==0 .AND. nskymsh3 > 0)THEN
516 DO i = 1, nskymsh3
517 itri(i) = ixtg(nixtg,abs(msh3sky(i)))
518 ENDDO
519 CALL my_orders(0,work,itri,index1,nskymsh3,1)
520 IF(istatcnd==0)THEN
521 DO j = 1, nskymsh3
522 n=msh3sky(index1(j))
523 IF(n < 0)THEN
524 n=-n
525 DO k=1,3
526 i = ixtg(k+1,n)
527 ms(i) = max(zero , ms(i) - mstg(n)*ptg(k,n))
528 in(i) = max(zero , in(i) - intg(n)*ptg(k,n))
529 END DO
530 ELSE
531 DO k=1,3
532 i = ixtg(k+1,n)
533 ms(i) = ms(i) + mstg(n)*ptg(k,n)
534 in(i) = in(i) + intg(n)*ptg(k,n)
535 END DO
536 END IF
537 END DO
538 ELSE
539 DO j = 1, nskymsh3
540 n=msh3sky(index1(j))
541 IF(n < 0)THEN
542 n=-n
543 msbig=mstg(n)
544 inbig=intg(n)
545 DO k=1,3
546 i = ixtg(k+1,n)
547 mscnd(i) = max(zero , mscnd(i) - msbig)
548 incnd(i) = max(zero , incnd(i) - inbig)
549 END DO
550 ELSE
551 msbig=mstg(n)
552 inbig=intg(n)
553 DO k=1,3
554 i = ixtg(k+1,n)
555 mscnd(i) = mscnd(i) + msbig
556 incnd(i) = incnd(i) + inbig
557 END DO
558 END IF
559 END DO
560 END IF
561C
562 IF(itherm_fe > 0)THEN
563 DO j = 1, nskymsh3
564 n=msh3sky(index1(j))
565 IF(n < 0)THEN
566 n=-n
567 DO k=1,3
568 i = ixtg(k+1,n)
569 mcp(i) = max(zero , mcp(i) - mcptg(n)*ptg(k,n))
570 END DO
571 ELSE
572 DO k=1,3
573 i = ixtg(k+1,n)
574 mcp(i) = mcp(i) + mcptg(n)*ptg(k,n)
575 END DO
576 END IF
577 END DO
578 END IF
579C
580 END IF
581C
582C compaction of LSH4ACT
583 IF(itask==0)THEN
584 ntmp =nsh4act
585 nsh4act=0
586 DO nn=1,ntmp
587 n=lsh4act(nn)
588 IF(n/=0)THEN
589 nsh4act=nsh4act+1
590 lsh4act(nsh4act)=n
591 END IF
592 END DO
593
594 END IF
595C
596C compaction of LSH3ACT
597 IF(itask==0)THEN
598 ntmp =nsh3act
599 nsh3act=0
600 DO nn=1,ntmp
601 n=lsh3act(nn)
602 IF(n/=0)THEN
603 nsh3act=nsh3act+1
604 lsh3act(nsh3act)=n
605 END IF
606 END DO
607 END IF
608
609 GO TO 10
610C----6---------------------------------------------------------------7---------8
611 DEALLOCATE(kdivide4)
612 DEALLOCATE(kdivide3)
613 DEALLOCATE(itri)
614 DEALLOCATE(index1)
615 RETURN
admmap3
subroutine admmap3(n, ixtg, x, iparg, elbuf_tab, igeo, ipm, sh3tree)
Definition admmap3.F:36
admmap4
subroutine admmap4(n, ixc, x, iparg, elbuf_tab, igeo, ipm, sh4tree)
Definition admmap4.F:36
my_real
#define my_real
Definition cppsort.cpp:32
sync_data
subroutine sync_data(ii)
Definition machine.F:383
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
remesh_mod
Definition remesh_mod.F:50
remesh_mod::lsh3act
integer, dimension(:), allocatable lsh3act
Definition remesh_mod.F:62
remesh_mod::msh3sky
integer, dimension(:), allocatable msh3sky
Definition remesh_mod.F:56
remesh_mod::ilevnod
integer, dimension(:), allocatable ilevnod
Definition remesh_mod.F:76
remesh_mod::msh4sky
integer, dimension(:), allocatable msh4sky
Definition remesh_mod.F:56
remesh_mod::nsh3act
integer nsh3act
Definition remesh_mod.F:66
remesh_mod::nsh4act
integer nsh4act
Definition remesh_mod.F:66
remesh_mod::lsh4act
integer, dimension(:), allocatable lsh4act
Definition remesh_mod.F:62
my_barrier
subroutine my_barrier
Definition machine.F:31