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 39 of file admdiv.F.

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