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

Go to the source code of this file.

Functions/Subroutines

subroutine admini (ixc, ipartc, ixtg, iparttg, ipart, igeo, ipm, iparg, x, ms, in, elbuf_tab, sh4tree, ipadmesh, msc, inc, sh3tree, mstg, intg, ptg, sh4trim, sh3trim, mscnd, incnd, pm, mcp, mcpc, mcptg, tagtrimc, tagtrimtg, itherm_fe)

Function/Subroutine Documentation

◆ admini()

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

Definition at line 38 of file admini.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE remesh_mod
49 USE message_mod
50 USE elbufdef_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 G l o b a l P a r a m e t e r s
59C-----------------------------------------------
60#include "com01_c.inc"
61#include "com04_c.inc"
62#include "com08_c.inc"
63#include "param_c.inc"
64#include "remesh_c.inc"
65#include "scr17_c.inc"
66#include "vect01_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,*), IPARG(NPARG,*),
72 . IGEO(NPROPGI,*), IPM(NPROPMI,*),
73 . SH4TREE(KSH4TREE,*), IPADMESH(KIPADMESH,*),
74 . SH3TREE(KSH3TREE,*), SH4TRIM(*), SH3TRIM(*),
75 . TAGTRIMC(*), TAGTRIMTG(*)
76 INTEGER ,INTENT(IN) :: ITHERM_FE
77 my_real
78 . x(3,*), ms(*), in(*), msc(*), inc(*),
79 . mstg(*), intg(*), ptg(3,*), mscnd(*), incnd(*),
80 . pm(npropm,*), mcp(*), mcpc(*), mcptg(*)
81 TYPE(ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
82C-----------------------------------------------
83C L o c a l V a r i a b l e s
84C-----------------------------------------------
85 INTEGER N,IP,INILEV,MYLEV,KINILEV,NTMP,IERR,
86 . LEVEL,LE,LELT,NELT(2*(4**LEVELMAX)),LEV,NE,SON,LELT1,LELT2,
87 . CND2MAP(2*(4**LEVELMAX))
88 INTEGER NN,IB,M,N1,N2,N3,N4,NG1
89 INTEGER ITRIM, KTRIM
90 INTEGER I,NG,MLW,KAD,NEL,ISTRA,ISH3N,IEXPAN,LEVSON
91 my_real
92 . mbig, mcpm, mcpn
93C-----------------------------------------------
94 IF(istatcnd/=0.AND.tt==zero)THEN
95 mscnd(1:numnod) =zero
96 incnd(1:numnod) =zero
97
98 DO n=1,numelc
99
100 IF(ipart(10,ipartc(n)) > 0)THEN
101
102 level = sh4tree(3,n)
103 IF(level==0 .OR. level==-1)THEN
104
105 n1 = ixc(2,n)
106 n2 = ixc(3,n)
107 n3 = ixc(4,n)
108 n4 = ixc(5,n)
109 mscnd(n1)=mscnd(n1)+msc(n)
110 mscnd(n2)=mscnd(n2)+msc(n)
111 mscnd(n3)=mscnd(n3)+msc(n)
112 mscnd(n4)=mscnd(n4)+msc(n)
113 incnd(n1)=incnd(n1)+inc(n)
114 incnd(n2)=incnd(n2)+inc(n)
115 incnd(n3)=incnd(n3)+inc(n)
116 incnd(n4)=incnd(n4)+inc(n)
117
118 lelt =1
119 nelt(1)=n
120
121 lelt1 =0
122 lelt2 =1
123
124 lev=0
125
126 cnd2map=0
127 IF(level < 0) cnd2map(1)=1
128
129 DO WHILE (lev < levelmax)
130 DO le=lelt1+1,lelt2
131
132 ne =nelt(le)
133 DO ib=1,4
134
135 m = sh4tree(2,ne)+ib-1
136
137 lelt=lelt+1
138 nelt(lelt)=m
139C
140 IF(cnd2map(le)==1)THEN
141 n1 = ixc(2,m)
142 n2 = ixc(3,m)
143 n3 = ixc(4,m)
144 n4 = ixc(5,m)
145 mbig=msc(n)
146 mscnd(n1)=mscnd(n1)+mbig
147 mscnd(n2)=mscnd(n2)+mbig
148 mscnd(n3)=mscnd(n3)+mbig
149 mscnd(n4)=mscnd(n4)+mbig
150 mbig=inc(n)
151 incnd(n1)=incnd(n1)+mbig
152 incnd(n2)=incnd(n2)+mbig
153 incnd(n3)=incnd(n3)+mbig
154 incnd(n4)=incnd(n4)+mbig
155
156 IF(sh4tree(3,m) < 0) cnd2map(lelt)=1
157 END IF
158
159 END DO
160
161 IF(cnd2map(le)==1)THEN
162 n1 = ixc(2,ne)
163 n2 = ixc(3,ne)
164 n3 = ixc(4,ne)
165 n4 = ixc(5,ne)
166 mbig=msc(n)
167 mscnd(n1)=max(zero,mscnd(n1)-mbig)
168 mscnd(n2)=max(zero,mscnd(n2)-mbig)
169 mscnd(n3)=max(zero,mscnd(n3)-mbig)
170 mscnd(n4)=max(zero,mscnd(n4)-mbig)
171 mbig=inc(n)
172 incnd(n1)=max(zero,incnd(n1)-mbig)
173 incnd(n2)=max(zero,incnd(n2)-mbig)
174 incnd(n3)=max(zero,incnd(n3)-mbig)
175 incnd(n4)=max(zero,incnd(n4)-mbig)
176 END IF
177
178 END DO
179
180 lev =lev+1
181 lelt1 =lelt2
182 lelt2 =lelt
183
184 END DO
185
186 DO le=1,lelt
187 msc(nelt(le))=msc(n)
188 inc(nelt(le))=inc(n)
189 END DO
190 END IF
191
192 END IF
193
194 END DO
195
196
197 DO n=1,numeltg
198
199 IF(ipart(10,iparttg(n)) > 0)THEN
200
201 level = sh3tree(3,n)
202 IF(level==0 .OR. level==-1)THEN
203
204 n1 = ixtg(2,n)
205 n2 = ixtg(3,n)
206 n3 = ixtg(4,n)
207 mscnd(n1)=mscnd(n1)+mstg(n)
208 mscnd(n2)=mscnd(n2)+mstg(n)
209 mscnd(n3)=mscnd(n3)+mstg(n)
210 incnd(n1)=incnd(n1)+intg(n)
211 incnd(n2)=incnd(n2)+intg(n)
212 incnd(n3)=incnd(n3)+intg(n)
213
214 lelt =1
215 nelt(1)=n
216
217 lelt1 =0
218 lelt2 =1
219
220 lev=0
221
222 cnd2map=0
223 IF(level < 0) cnd2map(1)=1
224
225 DO WHILE (lev < levelmax)
226 DO le=lelt1+1,lelt2
227
228 ne =nelt(le)
229
230 DO ib=1,4
231
232 m = sh3tree(2,ne)+ib-1
233
234 lelt=lelt+1
235 nelt(lelt)=m
236
237 IF(cnd2map(le)==1)THEN
238
239 n1 = ixtg(2,m)
240 n2 = ixtg(3,m)
241 n3 = ixtg(4,m)
242 mscnd(n1)=mscnd(n1)+mstg(n)
243 mscnd(n2)=mscnd(n2)+mstg(n)
244 mscnd(n3)=mscnd(n3)+mstg(n)
245 incnd(n1)=incnd(n1)+intg(n)
246 incnd(n2)=incnd(n2)+intg(n)
247 incnd(n3)=incnd(n3)+intg(n)
248
249 IF(sh3tree(3,m) < 0) cnd2map(lelt)=1
250 END IF
251
252 END DO
253
254 IF(cnd2map(le)==1)THEN
255 n1 = ixtg(2,ne)
256 n2 = ixtg(3,ne)
257 n3 = ixtg(4,ne)
258 mbig=mstg(n)
259 mscnd(n1)=max(zero,mscnd(n1)-mbig)
260 mscnd(n2)=max(zero,mscnd(n2)-mbig)
261 mscnd(n3)=max(zero,mscnd(n3)-mbig)
262 mbig=intg(n)
263 incnd(n1)=max(zero,incnd(n1)-mbig)
264 incnd(n2)=max(zero,incnd(n2)-mbig)
265 incnd(n3)=max(zero,incnd(n3)-mbig)
266 END IF
267
268 END DO
269
270 lev =lev+1
271 lelt1 =lelt2
272 lelt2 =lelt
273
274 END DO
275
276 DO le=1,lelt
277 mstg(nelt(le))=mstg(n)
278 intg(nelt(le))=intg(n)
279 END DO
280 END IF
281
282 END IF
283
284 END DO
285
286 END IF
287C-----------------------------------------------
288 nsh4act=0
289 DO n=1,numelc
290 IF(ipart(10,ipartc(n)) > 0 .AND.
291 . sh4tree(3,n) >= 0)THEN
292 nsh4act=nsh4act+1
293 lsh4act(nsh4act)=n
294 END IF
295 END DO
296C-----------------------------------------------
297 IF(lsh4trim > 0)THEN
298
299 5 CONTINUE
300
301 ktrim=0
302 ntmp =nsh4act
303 DO nn=1,ntmp
304 n =lsh4act(nn)
305
306 itrim=sh4trim(n)
307 IF(itrim/=0)THEN
308
309 ktrim=1
310
311 mylev=sh4tree(3,n)
312 IF(mylev == levelmax)THEN
313C
314C destruction
315 IF(itrim/=-1)THEN
316 CALL ancmsg(msgid=154,anmode=aninfo,
317 . i1=ixc(nixc,n),i2=mylev,i3=itrim)
318 CALL arret(2)
319 END IF
320 ng =sh4tree(4,n)
321 mlw = iparg(1,ng)
322 nel = iparg(2,ng)
323 nft = iparg(3,ng)
324 kad = iparg(4,ng)
325 npt = iparg(6,ng)
326 istra= iparg(44,ng)
327 jhbe = iparg(23,ng)
328 igtyp= iparg(38,ng)
329 iexpan=iparg(49,ng)
330 i =n-nft
331 elbuf_tab(ng)%GBUF%OFF(i) = zero ! off
332C
333C goes to sleep
334 lsh4act(nn) =0
335 sh4tree(3,n)=-(sh4tree(3,n)+1)
336
337 ELSE
338C
339C mapping and descent at the next level
340C
341 IF(itrim==-1)THEN
342 ng =sh4tree(4,n)
343 nft = iparg(3,ng)
344 i =n-nft
345 elbuf_tab(ng)%GBUF%OFF(i) = zero ! off
346
347 ENDIF
348 DO ib=1,4
349
350 m = sh4tree(2,n)+ib-1
351C
352 n1 = ixc(2,m)
353 n2 = ixc(3,m)
354 n3 = ixc(4,m)
355 n4 = ixc(5,m)
356C
357C wake up the son
358 sh4tree(3,m)=-sh4tree(3,m)-1
359#include "lockon.inc"
360 nsh4act=nsh4act+1
361 lsh4act(nsh4act)=m
362C
363C 1/4 of the element mass has been stored
364 IF(istatcnd==0)THEN
365 ms(n1)=ms(n1)+msc(m)
366 ms(n2)=ms(n2)+msc(m)
367 ms(n3)=ms(n3)+msc(m)
368 ms(n4)=ms(n4)+msc(m)
369 in(n1)=in(n1)+inc(m)
370 in(n2)=in(n2)+inc(m)
371 in(n3)=in(n3)+inc(m)
372 in(n4)=in(n4)+inc(m)
373 ELSE
374 mbig=msc(m)
375 mscnd(n1)=mscnd(n1)+mbig
376 mscnd(n2)=mscnd(n2)+mbig
377 mscnd(n3)=mscnd(n3)+mbig
378 mscnd(n4)=mscnd(n4)+mbig
379 mbig=inc(m)
380 incnd(n1)=incnd(n1)+mbig
381 incnd(n2)=incnd(n2)+mbig
382 incnd(n3)=incnd(n3)+mbig
383 incnd(n4)=incnd(n4)+mbig
384 END IF
385C
386 IF(itherm_fe > 0)THEN
387 mcpm=mcpc(m)
388 mcp(n1)=mcp(n1)+mcpm
389 mcp(n2)=mcp(n2)+mcpm
390 mcp(n3)=mcp(n3)+mcpm
391 mcp(n4)=mcp(n4)+mcpm
392 END IF
393C
394C map fields to the son
395 ng1 =sh4tree(4,m)
396 iparg(8,ng1)=0
397#include "lockoff.inc"
398 END DO
399C
400 CALL admmap4(n, ixc, x, iparg, elbuf_tab,
401 . igeo, ipm ,sh4tree)
402C
403 n1 = ixc(2,n)
404 n2 = ixc(3,n)
405 n3 = ixc(4,n)
406 n4 = ixc(5,n)
407#include "lockon.inc"
408 IF(istatcnd==0)THEN
409 ms(n1)=max(zero,ms(n1)-msc(n))
410 ms(n2)=max(zero,ms(n2)-msc(n))
411 ms(n3)=max(zero,ms(n3)-msc(n))
412 ms(n4)=max(zero,ms(n4)-msc(n))
413 in(n1)=max(zero,in(n1)-inc(n))
414 in(n2)=max(zero,in(n2)-inc(n))
415 in(n3)=max(zero,in(n3)-inc(n))
416 in(n4)=max(zero,in(n4)-inc(n))
417 ELSE
418 mbig=msc(n)
419 mscnd(n1)=max(zero,mscnd(n1)-mbig)
420 mscnd(n2)=max(zero,mscnd(n2)-mbig)
421 mscnd(n3)=max(zero,mscnd(n3)-mbig)
422 mscnd(n4)=max(zero,mscnd(n4)-mbig)
423 mbig=inc(n)
424 incnd(n1)=max(zero,incnd(n1)-mbig)
425 incnd(n2)=max(zero,incnd(n2)-mbig)
426 incnd(n3)=max(zero,incnd(n3)-mbig)
427 incnd(n4)=max(zero,incnd(n4)-mbig)
428 END IF
429#include "lockoff.inc"
430C
431 IF(itherm_fe > 0)THEN
432#include "lockon.inc"
433 mcpn=mcpc(n)
434 mcp(n1)=max(zero,mcp(n1)-mcpn)
435 mcp(n2)=max(zero,mcp(n2)-mcpn)
436 mcp(n3)=max(zero,mcp(n3)-mcpn)
437 mcp(n4)=max(zero,mcp(n4)-mcpn)
438#include "lockoff.inc"
439 END IF
440C
441C goes to sleep
442 lsh4act(nn) =0
443 sh4tree(3,n)=-(sh4tree(3,n)+1)
444
445 IF(itrim==-1)THEN
446 DO ib=1,4
447 m = sh4tree(2,n)+ib-1
448 IF(sh4trim(m)/=-1)THEN
449 CALL ancmsg(msgid=155,anmode=aninfo,
450 . i1=ixc(nixc,n),i2=itrim,
451 . i3=ixc(nixc,m),i4=sh4trim(m))
452 call arret(2)
453 END IF
454 END DO
455 END IF
456 END IF
457 END IF
458 END DO
459
460 IF(ktrim/=0)THEN
461C
462 idel7nok=1
463C
464C compaction of LSH4ACT
465 ntmp =nsh4act
466 nsh4act=0
467 DO nn=1,ntmp
468 n=lsh4act(nn)
469 IF(n/=0)THEN
470 nsh4act=nsh4act+1
471 lsh4act(nsh4act)=n
472 END IF
473 END DO
474 GOTO 5
475 END IF
476C
477C nothing to trim anymore
478 lsh4trim=-lsh4trim
479 END IF
480
481C-----------------------------------------------
482 nsh4old=nsh4act
483 10 CONTINUE
484
485 kinilev=0
486
487 ntmp =nsh4act
488 DO nn=1,ntmp
489 n =lsh4act(nn)
490 mylev=sh4tree(3,n)
491 ip=ipartc(n)
492 inilev=ipadmesh(1,ip)
493 IF(mylev<inilev)THEN
494 iadmesh=1
495 kinilev=1
496
497 DO ib=1,4
498
499 m = sh4tree(2,n)+ib-1
500C
501 n1 = ixc(2,m)
502 n2 = ixc(3,m)
503 n3 = ixc(4,m)
504 n4 = ixc(5,m)
505C
506C wake up the son
507 sh4tree(3,m)=-sh4tree(3,m)-1
508#include "lockon.inc"
509 nsh4act=nsh4act+1
510 lsh4act(nsh4act)=m
511C
512C 1/4 of the element mass has been stored
513 IF(istatcnd==0)THEN
514 ms(n1)=ms(n1)+msc(m)
515 ms(n2)=ms(n2)+msc(m)
516 ms(n3)=ms(n3)+msc(m)
517 ms(n4)=ms(n4)+msc(m)
518 in(n1)=in(n1)+inc(m)
519 in(n2)=in(n2)+inc(m)
520 in(n3)=in(n3)+inc(m)
521 in(n4)=in(n4)+inc(m)
522 ELSE
523 mbig=msc(m)
524 mscnd(n1)=mscnd(n1)+mbig
525 mscnd(n2)=mscnd(n2)+mbig
526 mscnd(n3)=mscnd(n3)+mbig
527 mscnd(n4)=mscnd(n4)+mbig
528 mbig=inc(m)
529 incnd(n1)=incnd(n1)+mbig
530 incnd(n2)=incnd(n2)+mbig
531 incnd(n3)=incnd(n3)+mbig
532 incnd(n4)=incnd(n4)+mbig
533 END IF
534C
535 IF(itherm_fe > 0)THEN
536 mcpm=mcpc(m)
537 mcp(n1)=mcp(n1)+mcpm
538 mcp(n2)=mcp(n2)+mcpm
539 mcp(n3)=mcp(n3)+mcpm
540 mcp(n4)=mcp(n4)+mcpm
541 END IF
542C
543C
544C map fields to the son
545 ng1 =sh4tree(4,m)
546 iparg(8,ng1)=0
547#include "lockoff.inc"
548 END DO
549C
550 CALL admmap4(n, ixc, x, iparg, elbuf_tab,
551 . igeo, ipm ,sh4tree)
552C
553 n1 = ixc(2,n)
554 n2 = ixc(3,n)
555 n3 = ixc(4,n)
556 n4 = ixc(5,n)
557#include "lockon.inc"
558 IF(istatcnd==0)THEN
559 ms(n1)=max(zero,ms(n1)-msc(n))
560 ms(n2)=max(zero,ms(n2)-msc(n))
561 ms(n3)=max(zero,ms(n3)-msc(n))
562 ms(n4)=max(zero,ms(n4)-msc(n))
563 in(n1)=max(zero,in(n1)-inc(n))
564 in(n2)=max(zero,in(n2)-inc(n))
565 in(n3)=max(zero,in(n3)-inc(n))
566 in(n4)=max(zero,in(n4)-inc(n))
567 ELSE
568 mbig=msc(n)
569 mscnd(n1)=max(zero,mscnd(n1)-mbig)
570 mscnd(n2)=max(zero,mscnd(n2)-mbig)
571 mscnd(n3)=max(zero,mscnd(n3)-mbig)
572 mscnd(n4)=max(zero,mscnd(n4)-mbig)
573 mbig=inc(n)
574 incnd(n1)=max(zero,incnd(n1)-mbig)
575 incnd(n2)=max(zero,incnd(n2)-mbig)
576 incnd(n3)=max(zero,incnd(n3)-mbig)
577 incnd(n4)=max(zero,incnd(n4)-mbig)
578 END IF
579#include "lockoff.inc"
580C
581 IF(itherm_fe > 0)THEN
582#include "lockon.inc"
583 mcpn=mcpc(n)
584 mcp(n1)=max(zero,mcp(n1)-mcpn)
585 mcp(n2)=max(zero,mcp(n2)-mcpn)
586 mcp(n3)=max(zero,mcp(n3)-mcpn)
587 mcp(n4)=max(zero,mcp(n4)-mcpn)
588#include "lockoff.inc"
589 END IF
590C
591C goes to sleep
592 lsh4act(nn) =0
593 sh4tree(3,n)=-(sh4tree(3,n)+1)
594 END IF
595 END DO
596
597 IF(kinilev/=0)THEN
598C
599C compaction of LSH4ACT
600 ntmp =nsh4act
601 nsh4act=0
602 DO nn=1,ntmp
603 n=lsh4act(nn)
604 IF(n/=0)THEN
605 nsh4act=nsh4act+1
606 lsh4act(nsh4act)=n
607 END IF
608 END DO
609 GOTO 10
610 END IF
611
612C----------------------------------------------
613C TRIANGLES
614C----------------------------------------------
615 nsh3act=0
616 DO n=1,numeltg
617 IF(ipart(10,iparttg(n)) > 0 .AND.
618 . sh3tree(3,n) >= 0)THEN
619 nsh3act=nsh3act+1
620 lsh3act(nsh3act)=n
621 END IF
622 END DO
623C-----------------------------------------------
624 IF(lsh3trim > 0)THEN
625
626 15 CONTINUE
627
628 ktrim=0
629 ntmp =nsh3act
630 DO nn=1,ntmp
631 n =lsh3act(nn)
632
633 itrim=sh3trim(n)
634 IF(itrim/=0)THEN
635
636 ktrim=1
637
638 mylev=sh3tree(3,n)
639 IF(mylev == levelmax)THEN
640C
641C destruction
642 IF(itrim/=-1)THEN
643 CALL ancmsg(msgid=156,anmode=aninfo)
644 call arret(2)
645 END IF
646 ng = sh3tree(4,n)
647 mlw = iparg(1,ng)
648 nel = iparg(2,ng)
649 nft = iparg(3,ng)
650 kad = iparg(4,ng)
651 npt = iparg(6,ng)
652 istra= iparg(44,ng)
653 ish3n= iparg(23,ng)
654 igtyp= iparg(38,ng)
655 iexpan=iparg(49,ng)
656 i =n-nft
657 elbuf_tab(ng)%GBUF%OFF(i) = zero ! off
658C
659C goes to sleep
660 lsh3act(nn) =0
661 sh3tree(3,n)=-(sh3tree(3,n)+1)
662
663 ELSE
664C
665C mapping and descent at the next level
666
667 DO ib=1,4
668
669 m = sh3tree(2,n)+ib-1
670C
671 n1 = ixtg(2,m)
672 n2 = ixtg(3,m)
673 n3 = ixtg(4,m)
674C
675C wake up the son
676 sh3tree(3,m)=-sh3tree(3,m)-1
677#include "lockon.inc"
678 nsh3act=nsh3act+1
679 lsh3act(nsh3act)=m
680C
681C 1/4 of the element mass has been stored
682 IF(istatcnd==0)THEN
683 ms(n1)=ms(n1)+mstg(m)*ptg(1,m)
684 ms(n2)=ms(n2)+mstg(m)*ptg(2,m)
685 ms(n3)=ms(n3)+mstg(m)*ptg(3,m)
686 in(n1)=in(n1)+intg(m)*ptg(1,m)
687 in(n2)=in(n2)+intg(m)*ptg(2,m)
688 in(n3)=in(n3)+intg(m)*ptg(3,m)
689 ELSE
690 mbig=mstg(m)
691 mscnd(n1)=mscnd(n1)+mbig
692 mscnd(n2)=mscnd(n2)+mbig
693 mscnd(n3)=mscnd(n3)+mbig
694 mbig=intg(m)
695 incnd(n1)=incnd(n1)+mbig
696 incnd(n2)=incnd(n2)+mbig
697 incnd(n3)=incnd(n3)+mbig
698 END IF
699C
700 IF(itherm_fe > 0)THEN
701 mcp(n1)=mcp(n1)+mcptg(m)*ptg(1,m)
702 mcp(n2)=mcp(n2)+mcptg(m)*ptg(2,m)
703 mcp(n3)=mcp(n3)+mcptg(m)*ptg(3,m)
704 END IF
705C
706C map fields to the son
707 ng1 =sh3tree(4,m)
708 iparg(8,ng1)=0
709#include "lockoff.inc"
710 END DO
711C
712 CALL admmap3(n, ixtg, x, iparg, elbuf_tab,
713 . igeo, ipm ,sh3tree)
714C
715 n1 = ixtg(2,n)
716 n2 = ixtg(3,n)
717 n3 = ixtg(4,n)
718 IF(istatcnd==0)THEN
719 ms(n1)=max(zero,ms(n1)-mstg(n)*ptg(1,n))
720 ms(n2)=max(zero,ms(n2)-mstg(n)*ptg(2,n))
721 ms(n3)=max(zero,ms(n3)-mstg(n)*ptg(3,n))
722 in(n1)=max(zero,in(n1)-intg(n)*ptg(1,n))
723 in(n2)=max(zero,in(n2)-intg(n)*ptg(2,n))
724 in(n3)=max(zero,in(n3)-intg(n)*ptg(3,n))
725 ELSE
726 mbig=mstg(n)
727 mscnd(n1)=max(zero,mscnd(n1)-mbig)
728 mscnd(n2)=max(zero,mscnd(n2)-mbig)
729 mscnd(n3)=max(zero,mscnd(n3)-mbig)
730 mbig=intg(n)
731 incnd(n1)=max(zero,incnd(n1)-mbig)
732 incnd(n2)=max(zero,incnd(n2)-mbig)
733 incnd(n3)=max(zero,incnd(n3)-mbig)
734 END IF
735C
736 IF(itherm_fe > 0)THEN
737#include "lockon.inc"
738 mcp(n1)=max(zero,mcp(n1)-mcptg(n)*ptg(1,n))
739 mcp(n2)=max(zero,mcp(n2)-mcptg(n)*ptg(2,n))
740 mcp(n3)=max(zero,mcp(n3)-mcptg(n)*ptg(3,n))
741#include "lockoff.inc"
742 END IF
743C
744C goes to sleep
745 lsh3act(nn) =0
746 sh3tree(3,n)=-(sh3tree(3,n)+1)
747
748 IF(itrim==-1)THEN
749 DO ib=1,4
750 m = sh3tree(2,n)+ib-1
751 IF(sh3trim(m)/=-1)THEN
752 CALL ancmsg(msgid=156,anmode=aninfo)
753 call arret(2)
754 END IF
755 END DO
756 END IF
757 END IF
758 END IF
759 END DO
760
761 IF(ktrim/=0)THEN
762C
763 idel7nok=1
764C
765C compaction of LSH4ACT
766 ntmp =nsh3act
767 nsh3act=0
768 DO nn=1,ntmp
769 n=lsh3act(nn)
770 IF(n/=0)THEN
771 nsh3act=nsh3act+1
772 lsh3act(nsh3act)=n
773 END IF
774 END DO
775 GOTO 15
776 END IF
777C
778C nothing to trim anymore
779 lsh3trim=-lsh3trim
780 END IF
781C-----------------------------------------------
782 nsh3old=nsh3act
783 20 CONTINUE
784
785 kinilev=0
786
787 ntmp =nsh3act
788 DO nn=1,ntmp
789 n =lsh3act(nn)
790 mylev=sh3tree(3,n)
791 ip =iparttg(n)
792 inilev=ipadmesh(1,ip)
793 IF(mylev<inilev)THEN
794 iadmesh=1
795 kinilev=1
796
797 DO ib=1,4
798
799 m = sh3tree(2,n)+ib-1
800C
801 n1 = ixtg(2,m)
802 n2 = ixtg(3,m)
803 n3 = ixtg(4,m)
804C
805C wake up the son
806 sh3tree(3,m)=-sh3tree(3,m)-1
807#include "lockon.inc"
808 nsh3act=nsh3act+1
809 lsh3act(nsh3act)=m
810C
811C 1/4 of the element mass has been stored
812 IF(istatcnd==0)THEN
813 ms(n1)=ms(n1)+mstg(m)*ptg(1,m)
814 ms(n2)=ms(n2)+mstg(m)*ptg(2,m)
815 ms(n3)=ms(n3)+mstg(m)*ptg(3,m)
816 in(n1)=in(n1)+intg(m)*ptg(1,m)
817 in(n2)=in(n2)+intg(m)*ptg(2,m)
818 in(n3)=in(n3)+intg(m)*ptg(3,m)
819 ELSE
820 mbig=mstg(m)
821 mscnd(n1)=mscnd(n1)+mbig
822 mscnd(n2)=mscnd(n2)+mbig
823 mscnd(n3)=mscnd(n3)+mbig
824 mbig=intg(m)
825 incnd(n1)=incnd(n1)+mbig
826 incnd(n2)=incnd(n2)+mbig
827 incnd(n3)=incnd(n3)+mbig
828 END IF
829C
830 IF(itherm_fe > 0)THEN
831 mcp(n1)=mcp(n1)+mcptg(m)*ptg(1,m)
832 mcp(n2)=mcp(n2)+mcptg(m)*ptg(2,m)
833 mcp(n3)=mcp(n3)+mcptg(m)*ptg(3,m)
834 END IF
835C
836C map fields to the son
837 ng1 =sh3tree(4,m)
838 iparg(8,ng1)=0
839#include "lockoff.inc"
840 END DO
841C
842 CALL admmap3(n, ixtg, x, iparg, elbuf_tab,
843 . igeo, ipm , sh3tree)
844C
845 n1 = ixtg(2,n)
846 n2 = ixtg(3,n)
847 n3 = ixtg(4,n)
848 IF(istatcnd==0)THEN
849 ms(n1)=max(zero,ms(n1)-mstg(n)*ptg(1,n))
850 ms(n2)=max(zero,ms(n2)-mstg(n)*ptg(2,n))
851 ms(n3)=max(zero,ms(n3)-mstg(n)*ptg(3,n))
852 in(n1)=max(zero,in(n1)-intg(n)*ptg(1,n))
853 in(n2)=max(zero,in(n2)-intg(n)*ptg(2,n))
854 in(n3)=max(zero,in(n3)-intg(n)*ptg(3,n))
855 ELSE
856 mbig=mstg(n)
857 mscnd(n1)=max(zero,mscnd(n1)-mbig)
858 mscnd(n2)=max(zero,mscnd(n2)-mbig)
859 mscnd(n3)=max(zero,mscnd(n3)-mbig)
860 mbig=intg(n)
861 incnd(n1)=max(zero,incnd(n1)-mbig)
862 incnd(n2)=max(zero,incnd(n2)-mbig)
863 incnd(n3)=max(zero,incnd(n3)-mbig)
864 END IF
865C
866 IF(itherm_fe > 0)THEN
867#include "lockon.inc"
868 mcp(n1)=max(zero,mcp(n1)-mcptg(n)*ptg(1,n))
869 mcp(n2)=max(zero,mcp(n2)-mcptg(n)*ptg(2,n))
870 mcp(n3)=max(zero,mcp(n3)-mcptg(n)*ptg(3,n))
871#include "lockoff.inc"
872 END IF
873C
874C goes to sleep
875 lsh3act(nn) =0
876 sh3tree(3,n)=-(sh3tree(3,n)+1)
877 END IF
878 END DO
879
880 IF(kinilev/=0)THEN
881C
882C compaction of LSH4ACT
883 ntmp =nsh3act
884 nsh3act=0
885 DO nn=1,ntmp
886 n=lsh3act(nn)
887 IF(n/=0)THEN
888 nsh3act=nsh3act+1
889 lsh3act(nsh3act)=n
890 END IF
891 END DO
892 GOTO 20
893 END IF
894C
895C Tag element that are inactifs and one of its sons is actif for Idel in interface
896 IF(nadmesh/=0.AND.idel7ng>=1.AND.(lsh4trim>0.OR.lsh3trim>0))THEN
897 tagtrimc(1:numelc) = 0
898 tagtrimtg(1:numeltg) = 0
899 IF(lsh4trim>0)THEN
900 DO n=1,numelc
901
902 IF(ipart(10,ipartc(n)) > 0)THEN
903 level = sh4tree(3,n)
904 itrim=sh4trim(n)
905 IF(level <0.AND.level/=(-levelmax-1).AND.itrim >=0) THEN
906 lelt =1
907 nelt(1)=n
908
909 lelt1 =0
910 lelt2 =1
911
912 lev=0
913 DO WHILE (lev < levelmax)
914 DO le=lelt1+1,lelt2
915
916 ne =nelt(le)
917 DO ib=1,4
918
919 m = sh4tree(2,ne)+ib-1
920
921 lelt=lelt+1
922 nelt(lelt)=m
923
924 levson = sh4tree(3,m)
925 IF(levson >= 0) THEN
926 tagtrimc(n) = 1
927 ENDIF
928 ENDDO
929 ENDDO
930 lev =lev+1
931 lelt1 =lelt2
932 lelt2 =lelt
933 ENDDO
934C ELSEIF (LEVEL==(-LEVELMAX-1)) THEN
935 ELSEIF (level <0.AND.itrim == -1) THEN
936 tagtrimc(n) = 1
937 ng =sh4tree(4,n)
938 nft = iparg(3,ng)
939 i =n-nft
940 elbuf_tab(ng)%GBUF%OFF(i) = zero ! off
941 ENDIF
942 ENDIF
943
944 ENDDO
945 ENDIF
946
947 IF(lsh3trim>0)THEN
948 DO n=1,numeltg
949
950 IF(ipart(10,iparttg(n)) > 0)THEN
951 level = sh3tree(3,n)
952 itrim=sh3trim(n)
953 IF(level <0.AND.itrim >=0) THEN
954 lelt =1
955 nelt(1)=n
956
957 lelt1 =0
958 lelt2 =1
959
960 lev=0
961 DO WHILE (lev < levelmax)
962 DO le=lelt1+1,lelt2
963
964 ne =nelt(le)
965 DO ib=1,4
966
967 m = sh3tree(2,ne)+ib-1
968
969 lelt=lelt+1
970 nelt(lelt)=m
971 IF(sh3tree(3,m) >= 0) THEN
972 tagtrimtg(n) = 1
973 ENDIF
974 ENDDO
975 ENDDO
976 lev =lev+1
977 lelt1 =lelt2
978 lelt2 =lelt
979 ENDDO
980 ELSEIF (level <0.AND.itrim == -1) THEN
981 tagtrimtg(n) = 1
982 ng =sh3tree(4,n)
983 nft = iparg(3,ng)
984 i =n-nft
985 elbuf_tab(ng)%GBUF%OFF(i) = zero ! off
986 ENDIF
987 ENDIF
988 ENDDO
989 ENDIF
990 ENDIF
991C
992C working arrays.
993 ALLOCATE(tagnod(numnod),stat=ierr)
994 IF (ierr /= 0) CALL arret(2)
995
996 ALLOCATE(nodnorm(3,numnod),stat=ierr)
997 IF (ierr /= 0) CALL arret(2)
998
999 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
max
#define max(a, b)
Definition macros.h:21
message_mod
Definition message_mod.F:1257
remesh_mod
Definition remesh_mod.F:50
remesh_mod::lsh3act
integer, dimension(:), allocatable lsh3act
Definition remesh_mod.F:62
remesh_mod::tagnod
integer, dimension(:), allocatable tagnod
Definition remesh_mod.F:77
remesh_mod::nsh3old
integer nsh3old
Definition remesh_mod.F:66
remesh_mod::nsh4old
integer nsh4old
Definition remesh_mod.F:66
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
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
arret
subroutine arret(nn)
Definition arret.F:86