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 37 of file admini.F.

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