39 SUBROUTINE admregul(IXC ,IPARTC ,IXTG ,IPARTTG,IPART,
40 . ITASK,IPARG ,X ,MS ,IN ,
41 . ELBUF_TAB,NODFT ,NODLT ,IGEO ,IPM ,
42 . SH4TREE,MSC ,INC ,SH3TREE,MSTG ,
43 . INTG ,PTG ,MSCND ,INCND ,PM ,
44 . MCP ,MCPC ,MCPTG ,ITHERM_FE)
51 use element_mod ,
only : nixc,nixtg
55#include "implicit_f.inc"
64#include "remesh_c.inc"
70 INTEGER IXC(NIXC,*),IPARTC(*),IXTG(NIXTG,*),IPARTTG(*),
71 . IPART(,*),ITASK,IPARG(NPARG,*),
72 . NODFT, NODLT, IGEO(NPROPGI,*), IPM(NPROPMI,*),
73 . SH4TREE(KSH4TREE,*),SH3TREE(KSH3TREE,*)
74 integer ,
INTENT(IN) :: ITHERM_FE
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
83 INTEGER SH4FT, SH4LT, SH3FT, SH3LT
84 INTEGER NN,N,IB,M,N1,N2,N3,N4
86 . NA1, NA2, NA3, NA4, NA5, NA6, NA7, NA8, NA9, NA10, NA11,
87 . NA12, NA13,NA14,NA15,NA16,NA17,NA18,NA19,NA20,NA21,NA22,
88 . na17a,na17b,nb17a,nb17b,lll,
89 . matly,my_nuvar,my_nuvarr,nuvar,nuvarr,ii,ivar,
90 . na16a,nb16a,mpt,nptm,nam_s,nbm_s,ig,ih,is,
91 . ptf,ptm,pte,ptp,pts,qtf,qtm,qte,qtp,qts,npg
92 INTEGER LEVEL,NTMP,LEV,P,NI,MYLEV,IP
93 INTEGER NSKYML, WORK(70000)
94 INTEGER,
DIMENSION(:),
ALLOCATABLE :: KDIVIDE4
95 INTEGER,
DIMENSION(:),
ALLOCATABLE :: KDIVIDE3
96 INTEGER,
DIMENSION(:),
ALLOCATABLE :: ITRI
97 INTEGER,
DIMENSION(:),
ALLOCATABLE :: INDEX1
99 . msbig, inbig, mcpm, mcpn
101 CALL my_alloc(kdivide4,numelc)
102 CALL my_alloc(kdivide3,numeltg)
103 CALL my_alloc(itri,
max(numelc,numeltg))
104 CALL my_alloc(index1,2*
max(numelc,numeltg))
138 sh4ft = 1+itask*
nsh4act/ nthread
139 sh4lt = (itask+1)*
nsh4act/nthread
146 IF( level >= levelmax-1 ) cycle
151 IF(lev-level > 1)
THEN
165 sh3ft = 1+itask*
nsh3act/ nthread
166 sh3lt = (itask+1)*
nsh3act/nthread
173 IF( level >= levelmax-1 ) cycle
178 IF(lev-level > 1)
THEN
194 IF(kadmrule==0)
RETURN
198 IF( kdivide4(n) == 0 ) cycle
206#include "lockoff.inc"
212 m = sh4tree(2,n)+ib-1
220 sh4tree(3,m)=-sh4tree(3,m)-1
224#include "lockoff.inc"
238#include "lockoff.inc"
242 mscnd(n1)=mscnd(n1)+msbig
243 mscnd(n2)=mscnd(n2)+msbig
244 mscnd(n3)=mscnd(n3)+msbig
245 mscnd(n4)=mscnd(n4)+msbig
247 incnd(n1)=incnd(n1)+inbig
248 incnd(n2)=incnd(n2)+inbig
249 incnd(n3)=incnd(n3)+inbig
250 incnd(n4)=incnd(n4)+inbig
251#include "lockoff.inc"
254 IF(itherm_fe > 0)
THEN
261#include "lockoff.inc"
273 CALL admmap4(n, ixc, x, iparg, elbuf_tab,
274 . igeo, ipm ,sh4tree)
283 ms(n1)=
max(zero,ms(n1)-msc(n))
284 ms(n2)=
max(zero,ms(n2)-msc(n))
285 ms(n3)=
max(zero,ms(n3)-msc(n))
286 ms(n4)=
max(zero,ms(n4)-msc(n))
287 in(n1)=
max(zero,in(n1)-inc(n))
288 in(n2)=
max(zero,in(n2)-inc(n))
289 in(n3)=
max(zero,in(n3)-inc(n))
290 in(n4)=
max(zero,in(n4)-inc(n))
291#include "lockoff.inc"
295 mscnd(n1)=
max(zero,mscnd(n1)-msbig)
296 mscnd(n2)=
max(zero,mscnd(n2)-msbig)
297 mscnd(n3)=
max(zero,mscnd(n3)-msbig)
298 mscnd(n4)=
max(zero,mscnd(n4)-msbig)
300 incnd(n1)=
max(zero,incnd(n1)-inbig)
301 incnd(n2)=
max(zero,incnd(n2)-inbig)
302 incnd(n3)=
max(zero,incnd(n3)-inbig)
303 incnd(n4)=
max(zero,incnd(n4)-inbig)
304#include "lockoff.inc"
307 IF(itherm_fe > 0)
THEN
310 mcp(n1)=
max(zero,mcp(n1)-mcpn)
311 mcp(n2)=
max(zero,mcp(n2)-mcpn)
312 mcp(n3)=
max(zero,mcp(n3)-mcpn)
313 mcp(n4)=
max(zero,mcp(n4)-mcpn)
314#include "lockoff.inc"
323 sh4tree(3,n)=-(sh4tree(3,n)+1)
331 IF( kdivide3(n) == 0 ) cycle
339#include "lockoff.inc"
345 m = sh3tree(2,n)+ib-1
352 sh3tree(3,m)=-sh3tree(3,m)-1
356#include "lockoff.inc"
362 ms(n1)=ms(n1)+mstg(m)*ptg(1,m)
363 ms(n2)=ms(n2)+mstg(m)*ptg(2,m)
364 ms(n3)=ms(n3)+mstg(m)*ptg(3,m)
365 in(n1)=in(n1)+intg(m)*ptg(1,m)
366 in(n2)=in(n2)+intg(m)*ptg(2,m)
367 in(n3)=in(n3)+intg(m)*ptg(3,m)
368#include "lockoff.inc"
372 mscnd(n1)=mscnd(n1)+msbig
373 mscnd(n2)=mscnd(n2)+msbig
374 mscnd(n3)=mscnd(n3)+msbig
376 incnd(n1)=incnd(n1)+inbig
377 incnd(n2)=incnd(n2)+inbig
378 incnd(n3)=incnd(n3)+inbig
379#include "lockoff.inc"
382 IF(itherm_fe > 0)
THEN
384 mcp(n1)=mcp(n1)+mcptg(m)*ptg(1,m)
385 mcp(n2)=mcp(n2)+mcptg(m)*ptg(2,m)
386 mcp(n3)=mcp(n3)+mcptg(m)*ptg(3,m)
387#include "lockoff.inc"
399 CALL admmap3(n, ixtg, x, iparg, elbuf_tab,
400 . igeo, ipm , sh3tree)
408 ms(n1)=
max(zero,ms(n1)-mstg(n)*ptg(1,n))
409 ms(n2)=
max(zero,ms(n2)-mstg(n)*ptg(2,n))
410 ms(n3)=
max(zero,ms(n3)-mstg(n)*ptg(3,n))
411 in(n1)=
max(zero,in(n1)-intg(n)*ptg(1,n))
412 in(n2)=
max(zero,in(n2)-intg(n)*ptg(2,n))
413 in(n3)=
max(zero,in(n3)-intg(n)*ptg(3,n))
414#include "lockoff.inc"
418 mscnd(n1)=
max(zero,mscnd(n1)-msbig)
419 mscnd(n2)=
max(zero,mscnd(n2)-msbig)
420 mscnd(n3)=
max(zero,mscnd(n3)-msbig)
422 incnd(n1)=
max(zero,incnd(n1)-inbig)
423 incnd(n2)=
max(zero,incnd(n2)-inbig)
424 incnd(n3)=
max(zero,incnd(n3)-inbig)
425#include "lockoff.inc"
428 IF(itherm_fe > 0)
THEN
430 mcp(n1)=
max(zero,mcp(n1)-mcptg(n)*ptg(1,n))
431 mcp(n2)=
max(zero,mcp(n2)-mcptg(n)*ptg(2,n))
432 mcp(n3)=
max(zero,mcp(n3)-mcptg(n)*ptg(3,n))
433#include "lockoff.inc"
448 IF(iparit/=0 .AND. itask==0 .AND. nskymsh4 > 0)
THEN
450 itri(i) = ixc(nixc,abs(
msh4sky(i)))
452 CALL my_orders(0,work,itri,index1,nskymsh4,1)
460 ms(i) =
max(zero , ms(i) - msc(n))
461 in(i) =
max(zero , in(i) - inc(n))
466 ms(i) = ms(i) + msc(n)
467 in(i) = in(i) + inc(n)
480 mscnd(i) =
max(zero , mscnd(i) - msbig)
481 incnd(i) =
max(zero , incnd(i) - inbig)
488 mscnd(i) = mscnd(i) + msbig
489 incnd(i) = incnd(i) + inbig
495 IF(itherm_fe > 0)
THEN
502 mcp(i) =
max(zero , mcp(i) - mcpc(n))
507 mcp(i) = mcp(i) + mcpc(n)
515 IF(iparit/=0 .AND. itask==0 .AND. nskymsh3 > 0)
THEN
517 itri(i) = ixtg(nixtg,abs(
msh3sky(i)))
519 CALL my_orders(0,work,itri,index1,nskymsh3,1)
527 ms(i) =
max(zero , ms(i) - mstg(n)*ptg(k,n))
528 in(i) =
max(zero , in(i) - intg(n)*ptg(k,n))
533 ms(i) = ms(i) + mstg(n)*ptg(k,n)
534 in(i) = in(i) + intg(n)*ptg(k,n)
547 mscnd(i) =
max(zero , mscnd(i) - msbig)
548 incnd(i) =
max(zero , incnd(i) - inbig)
555 mscnd(i) = mscnd(i) + msbig
556 incnd(i) = incnd(i) + inbig
562 IF(itherm_fe > 0)
THEN
569 mcp(i) =
max(zero , mcp(i) - mcptg(n)*ptg(k,n))
574 mcp(i) = mcp(i) + mcptg(n)*ptg(k,n)