OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
admdiv.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 admdiv (ixc, ipartc, ixtg, iparttg, ipart, itask, icontact, iparg, x, ms, in, rcontact, elbuf_tab, nodft, nodlt, igeo, ipm, sh4tree, padmesh, msc, inc, sh3tree, mstg, intg, ptg, acontact, pcontact, err_thk_sh4, err_thk_sh3, mscnd, incnd, pm, mcp, mcpc, mcptg, itherm_fe)

Function/Subroutine Documentation

◆ admdiv()

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

Definition at line 40 of file admdiv.F.

48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE remesh_mod
52 USE elbufdef_mod
53 USE my_alloc_mod
54 use element_mod , only : nixc,nixtg
55C-----------------------------------------------
56C I m p l i c i t T y p e s
57C-----------------------------------------------
58#include "implicit_f.inc"
59#include "comlock.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "com01_c.inc"
64#include "com04_c.inc"
65#include "param_c.inc"
66#include "parit_c.inc"
67#include "remesh_c.inc"
68#include "task_c.inc"
69#include "scr17_c.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73 INTEGER IXC(NIXC,*),IPARTC(*),IXTG(NIXTG,*),IPARTTG(*),
74 . IPART(LIPART1,*),ITASK,ICONTACT(*),IPARG(NPARG,*),
75 . NODFT, NODLT, IGEO(NPROPGI,*), IPM(NPROPMI,*),
76 . SH4TREE(KSH4TREE,*), SH3TREE(KSH3TREE,*)
77 INTEGER ,INTENT(IN) :: ITHERM_FE
78 my_real
79 . x(3,*),ms(*),in(*),rcontact(*),
80 . padmesh(kpadmesh,*), msc(*), inc(*),
81 . mstg(*), intg(*), ptg(3,*), acontact(*), pcontact(*),
82 . err_thk_sh4(*), err_thk_sh3(*), mscnd(*), incnd(*),
83 . pm(npropm,*), mcp(*), mcpc(*), mcptg(*)
84 TYPE(ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
85C-----------------------------------------------
86C L o c a l V a r i a b l e s
87C-----------------------------------------------
88 INTEGER SH4FT, SH4LT, SH3FT, SH3LT
89 INTEGER NN,N,IB,M,N1,N2,N3,N4,M1,M2,M3,M4,NG1
90 INTEGER LEVEL,KDIV,NTMP,L,LLNOD,
91 . LE,LELT,LEV,NE,SON,LELT1,LELT2,
92 . NI,IP,MYLEV
93 INTEGER NSKYML, WORK(70000), I, J, K
94 INTEGER,DIMENSION(:),ALLOCATABLE :: NELT
95 INTEGER,DIMENSION(:),ALLOCATABLE :: LNOD
96 INTEGER,DIMENSION(:),ALLOCATABLE :: ITRI
97 INTEGER,DIMENSION(:),ALLOCATABLE :: INDEX1
98 my_real
99 . nx,ny,nz,aaa,
100 . x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
101 . al1,al2,al3,al4,al,
102 . x13,y13,z13,x24,y24,z24,x12,y12,z12,
103 . cc,cmax,pp,rr,msbig,inbig,
104 . mcpm, mcpn
105 my_real
106 . tn1,tn2,tn3,tn4,unt,err
107C-----------------------------------------------
108 CALL my_alloc(nelt,2*(4**levelmax))
109 CALL my_alloc(lnod,numnod)
110 CALL my_alloc(itri,max(numelc,numeltg))
111 CALL my_alloc(index1,2*max(numelc,numeltg))
112C-----------------------------------------------
113 IF(ichkadm /= 0)THEN
114
115 IF(itask==0)THEN
116
117 tagnod = 0
118 nodnorm= zero
119c
120C traversal of the leaves
121 level=levelmax
122 DO nn=psh4kin(level)+1,psh4kin(level+1)
123 n =lsh4kin(nn)
124 CALL admnorm4(n,ixc,x)
125 END DO
126
127 DO nn=psh3kin(level)+1,psh3kin(level+1)
128 n =lsh3kin(nn)
129 CALL admnorm3(n,ixtg,x)
130 END DO
131c
132 END IF
133C
134 CALL my_barrier
135C
136 DO n=nodft,nodlt
137
138 IF(tagnod(n)/=0)THEN
139
140 nx=nodnorm(1,n)
141 ny=nodnorm(2,n)
142 nz=nodnorm(3,n)
143
144 aaa=one/max(em30,sqrt(nx*nx+ny*ny+nz*nz))
145 nx = nx * aaa
146 ny = ny * aaa
147 nz = nz * aaa
148
149 nodnorm(1,n)=nx
150 nodnorm(2,n)=ny
151 nodnorm(3,n)=nz
152 END IF
153
154 END DO
155
156 END IF
157
158 nskymsh4=0
159 nskymsh3=0
160C
161 sh4ft = 1+itask*nsh4act/ nthread
162 sh4lt = (itask+1)*nsh4act/nthread
163C
164 sh3ft = 1+itask*nsh3act/ nthread
165 sh3lt = (itask+1)*nsh3act/nthread
166C
167 CALL my_barrier
168C
169 DO nn=sh4ft,sh4lt
170 n =lsh4act(nn)
171
172 level=sh4tree(3,n)
173 IF( level == levelmax ) cycle
174
175 kdiv=0
176C---
177C KDIV=1 if elt needs to be divided
178C---
179 n1 = ixc(2,n)
180 n2 = ixc(3,n)
181 n3 = ixc(4,n)
182 n4 = ixc(5,n)
183
184 x1=x(1,n1)
185 y1=x(2,n1)
186 z1=x(3,n1)
187 x2=x(1,n2)
188 y2=x(2,n2)
189 z2=x(3,n2)
190 x3=x(1,n3)
191 y3=x(2,n3)
192 z3=x(3,n3)
193 x4=x(1,n4)
194 y4=x(2,n4)
195 z4=x(3,n4)
196 al1=(x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1)
197 al2=(x3-x2)*(x3-x2)+(y3-y2)*(y3-y2)+(z3-z2)*(z3-z2)
198 al3=(x4-x3)*(x4-x3)+(y4-y3)*(y4-y3)+(z4-z3)*(z4-z3)
199 al4=(x1-x4)*(x1-x4)+(y1-y4)*(y1-y4)+(z1-z4)*(z1-z4)
200 al =max(al1,al2,al3,al4)
201
202 lelt =1
203 nelt(1)=n
204
205 lelt1 =0
206 lelt2 =1
207
208 lev=level
209 DO WHILE (lev < levelmax)
210 DO le=lelt1+1,lelt2
211
212 ne =nelt(le)
213 son=sh4tree(2,ne)
214
215 lelt=lelt+1
216 nelt(lelt)=son
217
218 lelt=lelt+1
219 nelt(lelt)=son+1
220
221 lelt=lelt+1
222 nelt(lelt)=son+2
223
224 lelt=lelt+1
225 nelt(lelt)=son+3
226
227 END DO
228
229 lev =lev+1
230 lelt1 =lelt2
231 lelt2 =lelt
232
233 END DO
234
235 llnod=0
236 DO le=lelt1+1,lelt2
237
238 ne=nelt(le)
239 llnod=llnod+1
240 lnod(llnod)=ixc(2,ne)
241 llnod=llnod+1
242 lnod(llnod)=ixc(3,ne)
243 llnod=llnod+1
244 lnod(llnod)=ixc(4,ne)
245 llnod=llnod+1
246 lnod(llnod)=ixc(5,ne)
247
248 END DO
249
250 DO l=1,llnod
251
252 ni=lnod(l)
253
254 pp=pcontact(ni)
255 cc=acontact(ni)
256 IF(pp > one .AND. cc < zep9999)THEN
257 kdiv=1
258 EXIT
259 END IF
260
261 rr=rcontact(ni)
262 IF(al > half*rr*rr)THEN
263 kdiv=1
264 EXIT
265 END IF
266
267 END DO
268
269 IF(kdiv==0.AND.ichkadm/=0)THEN
270
271
272C
273C Angle criteria
274 ip =ipartc(n)
275 cmax =padmesh(1,ip)
276
277 x13 = x3 - x1
278 y13 = y3 - y1
279 z13 = z3 - z1
280
281 x24 = x4 - x2
282 y24 = y4 - y2
283 z24 = z4 - z2
284
285 nx = y13*z24 - z13*y24
286 ny = z13*x24 - x13*z24
287 nz = x13*y24 - y13*x24
288
289 aaa=one/max(em30,sqrt(nx*nx+ny*ny+nz*nz))
290 nx = nx * aaa
291 ny = ny * aaa
292 nz = nz * aaa
293
294 DO l=1,llnod
295 ni=lnod(l)
296 cc=nodnorm(1,ni)*nx+nodnorm(2,ni)*ny+nodnorm(3,ni)*nz
297 IF(cc <= cmax)THEN
298 kdiv=1
299 EXIT
300 END IF
301 END DO
302
303C
304C Criteria / Error on thickness
305 IF(iadmerrt /= 0)THEN
306 err=err_thk_sh4(n)
307 IF(err >= padmesh(2,ip))THEN
308 kdiv=1
309 END IF
310 END IF
311 END IF
312
313 IF( kdiv == 0 ) cycle
314
315#include "lockon.inc"
316 iadmesh=1
317 IF(iparit/=0)THEN
318 nskyml =nskymsh4
319 nskymsh4 =nskymsh4+5
320 END IF
321#include "lockoff.inc"
322C---
323C Divide elt N
324C---
325 DO ib=1,4
326
327 m = sh4tree(2,n)+ib-1
328C
329 m1 = ixc(2,m)
330 m2 = ixc(3,m)
331 m3 = ixc(4,m)
332 m4 = ixc(5,m)
333C
334C wake up the son
335 sh4tree(3,m)=-sh4tree(3,m)-1
336#include "lockon.inc"
337 nsh4act=nsh4act+1
338 lsh4act(nsh4act)=m
339#include "lockoff.inc"
340C
341C 1/4 of the element mass has been stored
342 IF(iparit==0)THEN
343 IF(istatcnd==0)THEN
344#include "lockon.inc"
345 ms(m1)=ms(m1)+msc(m)
346 ms(m2)=ms(m2)+msc(m)
347 ms(m3)=ms(m3)+msc(m)
348 ms(m4)=ms(m4)+msc(m)
349 in(m1)=in(m1)+inc(m)
350 in(m2)=in(m2)+inc(m)
351 in(m3)=in(m3)+inc(m)
352 in(m4)=in(m4)+inc(m)
353#include "lockoff.inc"
354 ELSE
355#include "lockon.inc"
356 msbig=msc(m)
357 mscnd(m1)=mscnd(m1)+msbig
358 mscnd(m2)=mscnd(m2)+msbig
359 mscnd(m3)=mscnd(m3)+msbig
360 mscnd(m4)=mscnd(m4)+msbig
361 inbig=inc(m)
362 incnd(m1)=incnd(m1)+inbig
363 incnd(m2)=incnd(m2)+inbig
364 incnd(m3)=incnd(m3)+inbig
365 incnd(m4)=incnd(m4)+inbig
366#include "lockoff.inc"
367 END IF
368C
369 IF(itherm_fe > 0)THEN
370#include "lockon.inc"
371 mcpm=mcpc(m)
372 mcp(m1)=mcp(m1)+mcpm
373 mcp(m2)=mcp(m2)+mcpm
374 mcp(m3)=mcp(m3)+mcpm
375 mcp(m4)=mcp(m4)+mcpm
376#include "lockoff.inc"
377 END IF
378C
379 ELSE
380 nskyml=nskyml+1
381 msh4sky(nskyml)=m
382 END IF
383C
384C map fields to the son
385 ng1 =sh4tree(4,m)
386 iparg(8,ng1)=0
387
388 END DO
389C
390 CALL admmap4(n, ixc, x, iparg, elbuf_tab,
391 . igeo, ipm ,sh4tree)
392C
393 IF(iparit==0)THEN
394 IF(istatcnd==0)THEN
395#include "lockon.inc"
396 ms(n1)=max(zero,ms(n1)-msc(n))
397 ms(n2)=max(zero,ms(n2)-msc(n))
398 ms(n3)=max(zero,ms(n3)-msc(n))
399 ms(n4)=max(zero,ms(n4)-msc(n))
400 in(n1)=max(zero,in(n1)-inc(n))
401 in(n2)=max(zero,in(n2)-inc(n))
402 in(n3)=max(zero,in(n3)-inc(n))
403 in(n4)=max(zero,in(n4)-inc(n))
404#include "lockoff.inc"
405 ELSE
406#include "lockon.inc"
407 msbig=msc(n)
408 mscnd(n1)=max(zero,mscnd(n1)-msbig)
409 mscnd(n2)=max(zero,mscnd(n2)-msbig)
410 mscnd(n3)=max(zero,mscnd(n3)-msbig)
411 mscnd(n4)=max(zero,mscnd(n4)-msbig)
412 inbig=inc(n)
413 incnd(n1)=max(zero,incnd(n1)-inbig)
414 incnd(n2)=max(zero,incnd(n2)-inbig)
415 incnd(n3)=max(zero,incnd(n3)-inbig)
416 incnd(n4)=max(zero,incnd(n4)-inbig)
417#include "lockoff.inc"
418 END IF
419C
420 IF(itherm_fe > 0)THEN
421#include "lockon.inc"
422 mcpn=mcpc(n)
423 mcp(n1)=max(zero,mcp(n1)-mcpn)
424 mcp(n2)=max(zero,mcp(n2)-mcpn)
425 mcp(n3)=max(zero,mcp(n3)-mcpn)
426 mcp(n4)=max(zero,mcp(n4)-mcpn)
427#include "lockoff.inc"
428 END IF
429C
430 ELSE
431 nskyml=nskyml+1
432 msh4sky(nskyml)=-n
433 END IF
434C
435C goes to sleep
436 lsh4act(nn) =0
437 sh4tree(3,n)=-(sh4tree(3,n)+1)
438
439 END DO
440C
441 DO nn=sh3ft,sh3lt
442 n =lsh3act(nn)
443
444 level=sh3tree(3,n)
445 IF( level == levelmax ) cycle
446
447 kdiv=0
448C---
449C KDIV=1 if elt needs to be divided
450C---
451 n1 = ixtg(2,n)
452 n2 = ixtg(3,n)
453 n3 = ixtg(4,n)
454 x1=x(1,n1)
455 y1=x(2,n1)
456 z1=x(3,n1)
457 x2=x(1,n2)
458 y2=x(2,n2)
459 z2=x(3,n2)
460 x3=x(1,n3)
461 y3=x(2,n3)
462 z3=x(3,n3)
463 al1=(x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1)
464 al2=(x3-x2)*(x3-x2)+(y3-y2)*(y3-y2)+(z3-z2)*(z3-z2)
465 al3=(x1-x3)*(x1-x3)+(y1-y3)*(y1-y3)+(z1-z3)*(z1-z3)
466 al =max(al1,al2,al3)
467
468
469 lelt =1
470 nelt(1)=n
471
472 lelt1 =0
473 lelt2 =1
474
475 lev=level
476 DO WHILE (lev < levelmax)
477 DO le=lelt1+1,lelt2
478
479 ne =nelt(le)
480 son=sh3tree(2,ne)
481
482 lelt=lelt+1
483 nelt(lelt)=son
484
485 lelt=lelt+1
486 nelt(lelt)=son+1
487
488 lelt=lelt+1
489 nelt(lelt)=son+2
490
491 lelt=lelt+1
492 nelt(lelt)=son+3
493
494 END DO
495
496 lev =lev+1
497 lelt1 =lelt2
498 lelt2 =lelt
499
500 END DO
501
502 llnod=0
503 DO le=lelt1+1,lelt2
504
505 ne=nelt(le)
506 llnod=llnod+1
507 lnod(llnod)=ixtg(2,ne)
508 llnod=llnod+1
509 lnod(llnod)=ixtg(3,ne)
510 llnod=llnod+1
511 lnod(llnod)=ixtg(4,ne)
512
513 END DO
514
515 DO l=1,llnod
516
517 ni=lnod(l)
518
519 pp=pcontact(ni)
520 cc=acontact(ni)
521 IF(pp > one .AND. cc < zep9999)THEN
522 kdiv=1
523 EXIT
524 END IF
525
526 rr=rcontact(ni)
527 IF(al > half*rr*rr)THEN
528 kdiv=1
529 EXIT
530 END IF
531
532 END DO
533
534
535 IF(kdiv==0.AND.ichkadm/=0)THEN
536
537 ip =iparttg(n)
538 cmax =padmesh(1,ip)
539
540 x12 = x2 - x1
541 y12 = y2 - y1
542 z12 = z2 - z1
543
544 x13 = x3 - x1
545 y13 = y3 - y1
546 z13 = z3 - z1
547
548 nx = y12*z13 - z12*y13
549 ny = z12*x13 - x12*z13
550 nz = x12*y13 - y12*x13
551
552 aaa=one/max(em30,sqrt(nx*nx+ny*ny+nz*nz))
553 nx = nx * aaa
554 ny = ny * aaa
555 nz = nz * aaa
556
557 DO l=1,llnod
558 ni=lnod(l)
559 cc=nodnorm(1,ni)*nx+nodnorm(2,ni)*ny+nodnorm(3,ni)*nz
560 IF(cc <= cmax)THEN
561 kdiv=1
562 EXIT
563 END IF
564 END DO
565
566 END IF
567
568 IF( kdiv == 0 ) cycle
569
570#include "lockon.inc"
571 iadmesh=1
572 IF(iparit/=0)THEN
573 nskyml=nskymsh3
574 nskymsh3 =nskymsh3+5
575 END IF
576#include "lockoff.inc"
577C---
578C Divide elt N
579C---
580 DO ib=1,4
581
582 m = sh3tree(2,n)+ib-1
583C
584 m1 = ixtg(2,m)
585 m2 = ixtg(3,m)
586 m3 = ixtg(4,m)
587C
588C wake up the son
589 sh3tree(3,m)=-sh3tree(3,m)-1
590#include "lockon.inc"
591 nsh3act=nsh3act+1
592 lsh3act(nsh3act)=m
593#include "lockoff.inc"
594C
595C 1/4 of the element mass has been stored
596 IF(iparit==0)THEN
597 IF(istatcnd==0)THEN
598#include "lockon.inc"
599 ms(m1)=ms(m1)+mstg(m)*ptg(1,m)
600 ms(m2)=ms(m2)+mstg(m)*ptg(2,m)
601 ms(m3)=ms(m3)+mstg(m)*ptg(3,m)
602 in(m1)=in(m1)+intg(m)*ptg(1,m)
603 in(m2)=in(m2)+intg(m)*ptg(2,m)
604 in(m3)=in(m3)+intg(m)*ptg(3,m)
605#include "lockoff.inc"
606 ELSE
607#include "lockon.inc"
608 mylev=sh3tree(3,n)
609 msbig=mstg(m)
610 mscnd(m1)=mscnd(m1)+msbig
611 mscnd(m2)=mscnd(m2)+msbig
612 mscnd(m3)=mscnd(m3)+msbig
613 inbig=intg(m)
614 incnd(m1)=incnd(m1)+inbig
615 incnd(m2)=incnd(m2)+inbig
616 incnd(m3)=incnd(m3)+inbig
617#include "lockoff.inc"
618 END IF
619C
620 IF(itherm_fe > 0)THEN
621#include "lockon.inc"
622 mcp(m1)=mcp(m1)+mcptg(m)*ptg(1,m)
623 mcp(m2)=mcp(m2)+mcptg(m)*ptg(2,m)
624 mcp(m3)=mcp(m3)+mcptg(m)*ptg(3,m)
625#include "lockoff.inc"
626 END IF
627C
628 ELSE
629 nskyml=nskyml+1
630 msh3sky(nskyml)=m
631 END IF
632C
633C map fields to the son
634 ng1 =sh3tree(4,m)
635 iparg(8,ng1)=0
636 END DO
637C
638 CALL admmap3(n, ixtg, x, iparg,elbuf_tab,
639 . igeo, ipm ,sh3tree )
640C
641 IF(iparit==0)THEN
642 IF(istatcnd==0)THEN
643#include "lockon.inc"
644 ms(n1)=max(zero,ms(n1)-mstg(n)*ptg(1,n))
645 ms(n2)=max(zero,ms(n2)-mstg(n)*ptg(2,n))
646 ms(n3)=max(zero,ms(n3)-mstg(n)*ptg(3,n))
647 in(n1)=max(zero,in(n1)-intg(n)*ptg(1,n))
648 in(n2)=max(zero,in(n2)-intg(n)*ptg(2,n))
649 in(n3)=max(zero,in(n3)-intg(n)*ptg(3,n))
650#include "lockoff.inc"
651 ELSE
652#include "lockon.inc"
653 msbig=mstg(n)
654 mscnd(n1)=max(zero,mscnd(n1)-msbig)
655 mscnd(n2)=max(zero,mscnd(n2)-msbig)
656 mscnd(n3)=max(zero,mscnd(n3)-msbig)
657 inbig=intg(n)
658 incnd(n1)=max(zero,incnd(n1)-inbig)
659 incnd(n2)=max(zero,incnd(n2)-inbig)
660 incnd(n3)=max(zero,incnd(n3)-inbig)
661#include "lockoff.inc"
662 END IF
663C
664 IF(itherm_fe > 0)THEN
665#include "lockon.inc"
666 mcp(n1)=max(zero,mcp(n1)-mcptg(n)*ptg(1,n))
667 mcp(n2)=max(zero,mcp(n2)-mcptg(n)*ptg(2,n))
668 mcp(n3)=max(zero,mcp(n3)-mcptg(n)*ptg(3,n))
669#include "lockoff.inc"
670 END IF
671C
672 ELSE
673 nskyml=nskyml+1
674 msh3sky(nskyml)=-n
675 END IF
676C
677C goes to sleep
678 lsh3act(nn) =0
679 sh3tree(3,n)=-(sh3tree(3,n)+1)
680
681 END DO
682C
683 CALL my_barrier
684C
685 IF(iparit/=0 .AND. itask==0 .AND. nskymsh4 > 0)THEN
686 DO i = 1, nskymsh4
687 itri(i) = ixc(nixc,abs(msh4sky(i)))
688 ENDDO
689 CALL my_orders(0,work,itri,index1,nskymsh4,1)
690 IF(istatcnd==0)THEN
691 DO j = 1, nskymsh4
692 n=msh4sky(index1(j))
693 IF(n < 0)THEN
694 n=-n
695 DO k=1,4
696 i = ixc(k+1,n)
697 ms(i) = max(zero , ms(i) - msc(n))
698 in(i) = max(zero , in(i) - inc(n))
699 END DO
700 ELSE
701 DO k=1,4
702 i = ixc(k+1,n)
703 ms(i) = ms(i) + msc(n)
704 in(i) = in(i) + inc(n)
705 END DO
706 END IF
707 END DO
708 ELSE
709 DO j = 1, nskymsh4
710 n=msh4sky(index1(j))
711 IF(n < 0)THEN
712 n=-n
713 msbig=msc(n)
714 inbig=inc(n)
715 DO k=1,4
716 i = ixc(k+1,n)
717 mscnd(i) = max(zero , mscnd(i) - msbig)
718 incnd(i) = max(zero , incnd(i) - inbig)
719 END DO
720 ELSE
721 msbig=msc(n)
722 inbig=inc(n)
723 DO k=1,4
724 i = ixc(k+1,n)
725 mscnd(i) = mscnd(i) + msbig
726 incnd(i) = incnd(i) + inbig
727 END DO
728 END IF
729 END DO
730 END IF
731C
732 IF(itherm_fe > 0)THEN
733 DO j = 1, nskymsh4
734 n=msh4sky(index1(j))
735 IF(n < 0)THEN
736 n=-n
737 DO k=1,4
738 i = ixc(k+1,n)
739 mcp(i) = max(zero , mcp(i) - mcpc(n))
740 END DO
741 ELSE
742 DO k=1,4
743 i = ixc(k+1,n)
744 mcp(i) = mcp(i) + mcpc(n)
745 END DO
746 END IF
747 END DO
748 END IF
749C
750 END IF
751C
752 IF(iparit/=0 .AND. itask==0 .AND. nskymsh3 > 0)THEN
753 DO i = 1, nskymsh3
754 itri(i) = ixtg(nixtg,abs(msh3sky(i)))
755 ENDDO
756 CALL my_orders(0,work,itri,index1,nskymsh3,1)
757 IF(istatcnd==0)THEN
758 DO j = 1, nskymsh3
759 n=msh3sky(index1(j))
760 IF(n < 0)THEN
761 n=-n
762 DO k=1,3
763 i = ixtg(k+1,n)
764 ms(i) = max(zero , ms(i) - mstg(n)*ptg(k,n))
765 in(i) = max(zero , in(i) - intg(n)*ptg(k,n))
766 END DO
767 ELSE
768 DO k=1,3
769 i = ixtg(k+1,n)
770 ms(i) = ms(i) + mstg(n)*ptg(k,n)
771 in(i) = in(i) + intg(n)*ptg(k,n)
772 END DO
773 END IF
774 END DO
775 ELSE
776 DO j = 1, nskymsh3
777 n=msh3sky(index1(j))
778 IF(n < 0)THEN
779 n=-n
780 msbig=mstg(n)
781 inbig=intg(n)
782 DO k=1,3
783 i = ixtg(k+1,n)
784 mscnd(i) = max(zero , mscnd(i) - msbig)
785 incnd(i) = max(zero , incnd(i) - inbig)
786 END DO
787 ELSE
788 msbig=mstg(n)
789 inbig=intg(n)
790 DO k=1,3
791 i = ixtg(k+1,n)
792 mscnd(i) = mscnd(i) + msbig
793 incnd(i) = incnd(i) + inbig
794 END DO
795 END IF
796 END DO
797 END IF
798C
799 IF(itherm_fe > 0)THEN
800 DO j = 1, nskymsh3
801 n=msh3sky(index1(j))
802 IF(n < 0)THEN
803 n=-n
804 DO k=1,3
805 i = ixtg(k+1,n)
806 mcp(i) = max(zero , mcp(i) - mcptg(n)*ptg(k,n))
807 END DO
808 ELSE
809 DO k=1,3
810 i = ixtg(k+1,n)
811 mcp(i) = mcp(i) + mcptg(n)*ptg(k,n)
812 END DO
813 END IF
814 END DO
815 END IF
816C
817 END IF
818C
819C compaction of LSH4ACT
820 IF(iadmesh==1)THEN
821 IF(itask==0)THEN
822 ntmp =nsh4act
823 nsh4act=0
824 DO nn=1,ntmp
825 n=lsh4act(nn)
826 IF(n/=0)THEN
827 nsh4act=nsh4act+1
828 lsh4act(nsh4act)=n
829 END IF
830 END DO
831
832 ntmp =nsh3act
833 nsh3act=0
834 DO nn=1,ntmp
835 n=lsh3act(nn)
836 IF(n/=0)THEN
837 nsh3act=nsh3act+1
838 lsh3act(nsh3act)=n
839 END IF
840 END DO
841 END IF
842 END IF
843C
844 DEALLOCATE(nelt)
845 DEALLOCATE(lnod)
846 DEALLOCATE(itri)
847 DEALLOCATE(index1)
848C----6---------------------------------------------------------------7---------8
849 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
admnorm4
subroutine admnorm4(n, ixc, x)
Definition admnorm.F:32
admnorm3
subroutine admnorm3(n, ixtg, x)
Definition admnorm.F:110
my_real
#define my_real
Definition cppsort.cpp:32
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::lsh4kin
integer, dimension(:), allocatable lsh4kin
Definition remesh_mod.F:62
remesh_mod::lsh3kin
integer, dimension(:), allocatable lsh3kin
Definition remesh_mod.F:62
remesh_mod::psh4kin
integer, dimension(:), allocatable psh4kin
Definition remesh_mod.F:62
remesh_mod::psh3kin
integer, dimension(:), allocatable psh3kin
Definition remesh_mod.F:62
remesh_mod::tagnod
integer, dimension(:), allocatable tagnod
Definition remesh_mod.F:77
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