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 38 of file admregul.F.

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