38 SUBROUTINE admregul(IXC ,IPARTC ,IXTG ,IPARTTG,IPART,
39 . ITASK,IPARG ,X ,MS ,IN ,
40 . ELBUF_TAB,NODFT ,NODLT ,IGEO ,IPM ,
41 . SH4TREE,MSC ,INC ,SH3TREE,MSTG ,
42 . INTG ,PTG ,MSCND ,INCND ,PM ,
43 . MCP ,MCPC ,MCPTG ,ITHERM_FE)
53#include "implicit_f.inc"
62#include "remesh_c.inc"
68 INTEGER IXC(,*),IPARTC(*),IXTG(NIXTG,*),IPARTTG(*),
69 . IPART(LIPART1,*),ITASK,IPARG(NPARG,*),
70 . NODFT, NODLT, IGEO(NPROPGI,*), IPM(NPROPMI,*),
71 . SH4TREE(KSH4TREE,*),SH3TREE(KSH3TREE,*)
72 integer ,
INTENT(IN) :: ITHERM_FE
74 . x(3,*),ms(*),in(*),msc(*), inc(*),
75 . mstg(*), intg(*), ptg(3,*), mscnd(*), incnd(*),
76 . pm(npropm,*), mcp(*), mcpc(*), mcptg(*)
77 TYPE(elbuf_struct_),
DIMENSION(NGROUP) :: ELBUF_TAB
81 INTEGER SH4FT, SH4LT, SH3FT, SH3LT
82 INTEGER NN,N,IB,M,N1,N2,N3,N4
84 . NA1, NA2, NA3, NA4, NA5, NA6, NA7, NA8, NA9, NA10, NA11,
85 . NA12, NA13,NA14,NA15,NA16,NA17,NA18,NA19,NA20,NA21,NA22,
86 . na17a,na17b,nb17a,nb17b,lll,
87 . matly,my_nuvar,my_nuvarr,nuvar,nuvarr,ii,ivar,
88 . na16a,nb16a,mpt,nptm,nam_s,nbm_s,ig,ih,is,
89 . ptf,ptm,pte,ptp,pts,qtf,qtm,qte,qtp,qts,npg
90 INTEGER LEVEL,NTMP,LEV,P,NI,MYLEV,IP
91 INTEGER NSKYML, WORK(70000)
92 INTEGER,
DIMENSION(:),
ALLOCATABLE :: KDIVIDE4
93 INTEGER,
DIMENSION(:),
ALLOCATABLE :: KDIVIDE3
94 INTEGER,
DIMENSION(:),
ALLOCATABLE :: ITRI
95 INTEGER,
DIMENSION(:),
ALLOCATABLE :: INDEX1
97 . msbig, inbig, mcpm, mcpn
99 CALL my_alloc(kdivide4,numelc)
100 CALL my_alloc(kdivide3,numeltg)
101 CALL my_alloc(itri,
max(numelc,numeltg))
102 CALL my_alloc(index1,2*
max(numelc,numeltg))
136 sh4ft = 1+itask*
nsh4act/ nthread
137 sh4lt = (itask+1)*
nsh4act/nthread
144 IF( level >= levelmax-1 ) cycle
149 IF(lev-level > 1)
THEN
163 sh3ft = 1+itask*
nsh3act/ nthread
164 sh3lt = (itask+1)*
nsh3act/nthread
171 IF( level >= levelmax-1 ) cycle
176 IF(lev-level > 1)
THEN
192 IF(kadmrule==0)
RETURN
196 IF( kdivide4(n) == 0 ) cycle
204#include "lockoff.inc"
210 m = sh4tree(2,n)+ib-1
218 sh4tree(3,m)=-sh4tree(3,m)-1
222#include "lockoff.inc"
236#include "lockoff.inc"
240 mscnd(n1)=mscnd(n1)+msbig
241 mscnd(n2)=mscnd(n2)+msbig
242 mscnd(n3)=mscnd(n3)+msbig
243 mscnd(n4)=mscnd(n4)+msbig
245 incnd(n1)=incnd(n1)+inbig
246 incnd(n2)=incnd(n2)+inbig
247 incnd(n3)=incnd(n3)+inbig
248 incnd(n4)=incnd(n4)+inbig
249#include "lockoff.inc"
252 IF(itherm_fe > 0)
THEN
259#include "lockoff.inc"
271 CALL admmap4(n, ixc, x, iparg, elbuf_tab,
272 . igeo, ipm ,sh4tree)
281 ms(n1)=
max(zero,ms(n1)-msc(n))
282 ms(n2)=
max(zero,ms(n2)-msc(n))
283 ms(n3)=
max(zero,ms(n3)-msc(n))
284 ms(n4)=
max(zero,ms(n4)-msc(n))
285 in(n1)=
max(zero,in(n1)-inc(n))
286 in(n2)=
max(zero,in(n2)-inc(n))
287 in(n3)=
max(zero,in(n3)-inc(n))
288 in(n4)=
max(zero,in(n4)-inc(n))
289#include "lockoff.inc"
293 mscnd(n1)=
max(zero,mscnd(n1)-msbig)
294 mscnd(n2)=
max(zero,mscnd(n2)-msbig)
295 mscnd(n3)=
max(zero,mscnd(n3)-msbig)
296 mscnd(n4)=
max(zero,mscnd(n4)-msbig)
298 incnd(n1)=
max(zero,incnd(n1)-inbig)
299 incnd(n2)=
max(zero,incnd(n2)-inbig)
300 incnd(n3)=
max(zero,incnd(n3)-inbig)
301 incnd(n4)=
max(zero,incnd(n4)-inbig)
302#include "lockoff.inc"
305 IF(itherm_fe > 0)
THEN
308 mcp(n1)=
max(zero,mcp(n1)-mcpn)
309 mcp(n2)=
max(zero,mcp(n2)-mcpn)
310 mcp(n3)=
max(zero,mcp(n3)-mcpn)
311 mcp(n4)=
max(zero,mcp(n4)-mcpn)
312#include "lockoff.inc"
321 sh4tree(3,n)=-(sh4tree(3,n)+1)
329 IF( kdivide3(n) == 0 ) cycle
337#include "lockoff.inc"
343 m = sh3tree(2,n)+ib-1
350 sh3tree(3,m)=-sh3tree(3,m)-1
354#include "lockoff.inc"
360 ms(n1)=ms(n1)+mstg(m)*ptg(1,m)
361 ms(n2)=ms(n2)+mstg(m)*ptg(2,m)
362 ms(n3)=ms(n3)+mstg(m)*ptg(3,m)
363 in(n1)=in(n1)+intg(m)*ptg(1,m)
364 in(n2)=in(n2)+intg(m)*ptg(2,m)
365 in(n3)=in(n3)+intg(m)*ptg(3,m)
366#include "lockoff.inc"
370 mscnd(n1)=mscnd(n1)+msbig
371 mscnd(n2)=mscnd(n2)+msbig
372 mscnd(n3)=mscnd(n3)+msbig
374 incnd(n1)=incnd(n1)+inbig
375 incnd(n2)=incnd(n2)+inbig
376 incnd(n3)=incnd(n3)+inbig
377#include "lockoff.inc"
380 IF(itherm_fe > 0)
THEN
382 mcp(n1)=mcp(n1)+mcptg(m)*ptg(1,m)
383 mcp(n2)=mcp(n2)+mcptg(m)*ptg(2,m)
384 mcp(n3)=mcp(n3)+mcptg(m)*ptg(3,m)
385#include "lockoff.inc"
397 CALL admmap3(n, ixtg, x, iparg, elbuf_tab,
398 . igeo, ipm , sh3tree)
406 ms(n1)=
max(zero,ms(n1)-mstg(n)*ptg(1,n))
407 ms(n2)=
max(zero,ms(n2)-mstg(n)*ptg(2,n))
408 ms(n3)=
max(zero,ms(n3)-mstg(n)*ptg(3,n))
409 in(n1)=
max(zero,in(n1)-intg(n)*ptg(1,n))
410 in(n2)=
max(zero,in(n2)-intg(n)*ptg(2,n))
411 in(n3)=
max(zero,in(n3)-intg(n)*ptg(3,n))
412#include "lockoff.inc"
416 mscnd(n1)=
max(zero,mscnd(n1)-msbig)
417 mscnd(n2)=
max(zero,mscnd(n2)-msbig)
418 mscnd(n3)=
max(zero,mscnd(n3)-msbig)
420 incnd(n1)=
max(zero,incnd(n1)-inbig)
422 incnd(n3)=
max(zero,incnd(n3)-inbig)
423#include "lockoff.inc"
426 IF(itherm_fe > 0)
THEN
428 mcp(n1)=
max(zero,mcp(n1)-mcptg(n)*ptg(1,n))
429 mcp(n2)=
max(zero,mcp(n2)-mcptg(n)*ptg(2,n))
430 mcp(n3)=
max(zero,mcp(n3)-mcptg(n)*ptg(3,n))
431#include "lockoff.inc"
440 sh3tree(3,n)=-(sh3tree(3,n)+1)
446 IF(iparit/=0 .AND. itask==0 .AND. nskymsh4 > 0)
THEN
448 itri(i) = ixc(nixc,abs(
msh4sky(i)))
450 CALL my_orders(0,work,itri,index1,nskymsh4,1)
458 ms(i) =
max(zero , ms(i) - msc(n))
459 in(i) =
max(zero , in(i) - inc(n))
464 ms(i) = ms(i) + msc(n)
465 in(i) = in(i) + inc(n)
478 mscnd(i) =
max(zero , mscnd(i) - msbig)
479 incnd(i) =
max(zero , incnd(i) - inbig)
486 mscnd(i) = mscnd(i) + msbig
487 incnd(i) = incnd(i) + inbig
493 IF(itherm_fe > 0)
THEN
500 mcp(i) =
max(zero , mcp(i) - mcpc(n))
505 mcp(i) = mcp(i) + mcpc(n)
513 IF(iparit/=0 .AND. itask==0 .AND. nskymsh3 > 0)
THEN
515 itri(i) = ixtg(nixtg,abs(
msh3sky(i)))
517 CALL my_orders(0,work,itri,index1,nskymsh3,1)
525 ms(i) =
max(zero , ms(i) - mstg
526 in(i) =
max(zero , in(i) - intg(n)*ptg(k
531 ms(i) = ms(i) + mstg(n)*ptg(k,n)
532 in(i) = in(i) + intg(n)*ptg(k,n)
545 mscnd(i) =
max(zero , mscnd(i) - msbig)
546 incnd(i) =
max(zero , incnd(i) - inbig)
553 mscnd(i) = mscnd(i) + msbig
554 incnd(i) = incnd(i) + inbig
560 IF(itherm_fe > 0)
THEN
567 mcp(i) =
max(zero , mcp(i) - mcptg(n)*ptg(k,n))
572 mcp(i) = mcp(i) + mcptg(n)*ptg(k,n)