OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25buc_vox1.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"
#include "com04_c.inc"
#include "scr06_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine i25buc_vox1 (x, irect, nsv, bumult, nmn, nrtm, nsn, intbuf_tab, gap, i_stok, dist, tzinf, maxbox, minbox, msr, stf, stfn, iddlevel, gap_s, gap_m, igap, gapmin, gapmax, inacti, gap_s_l, gap_m_l, marge, id, titr, nbinflg, mbinflg, ilev, msegtyp, gap_n, bgapsmx, iparts, knod2els, nod2els, kremnode, remnode, ixs, ixs10, ixs16, ixs20, icode, iskew, drad, dgapload, nrtmt, flag_removed_node, ielem_m, nin, npari, ipari)
subroutine insol25 (irect, ixs, ixs10, ixs16, ixs20, knod2els, nod2els, nel, i)

Function/Subroutine Documentation

◆ i25buc_vox1()

subroutine i25buc_vox1 ( x,
integer, dimension(4,*) irect,
integer, dimension(*) nsv,
bumult,
integer nmn,
integer nrtm,
integer nsn,
type(intbuf_struct_), intent(inout) intbuf_tab,
gap,
integer i_stok,
dist,
tzinf,
maxbox,
minbox,
integer, dimension(*) msr,
stf,
stfn,
integer iddlevel,
gap_s,
gap_m,
integer igap,
gapmin,
gapmax,
integer inacti,
gap_s_l,
gap_m_l,
marge,
integer id,
character(len=nchartitle) titr,
integer, dimension(*) nbinflg,
integer, dimension(*) mbinflg,
integer ilev,
integer, dimension(*) msegtyp,
gap_n,
bgapsmx,
integer, dimension(*) iparts,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer, dimension(*) kremnode,
integer, dimension(*) remnode,
integer, dimension(*) ixs,
integer, dimension(*) ixs10,
integer, dimension(*) ixs16,
integer, dimension(*) ixs20,
integer, dimension(*) icode,
integer, dimension(*) iskew,
intent(in) drad,
intent(in) dgapload,
integer, intent(in) nrtmt,
logical, intent(in) flag_removed_node,
integer, dimension(2,nrtm), intent(in) ielem_m,
integer, intent(in) nin,
integer, intent(in) npari,
integer, dimension(npari), intent(inout) ipari )
Parameters
[in]flag_removed_nodeflag to remove some S node from the list of candidates
[in]nininterface index
[in]nparifirst dim of ipari
[in,out]ipariinterface data
[in,out]intbuf_tabinterface data

Definition at line 37 of file i25buc_vox1.F.

52C-----------------------------------------------
53C M o d u l e s
54C-----------------------------------------------
55 USE message_mod
56 USE tri7box
57 USE names_and_titles_mod , ONLY : nchartitle
58 USE intbufdef_mod
59 use margin_reduction_mod
60C-----------------------------------------------
61C I m p l i c i t T y p e s
62C-----------------------------------------------
63#include "implicit_f.inc"
64C-----------------------------------------------
65C C o m m o n B l o c k s
66C-----------------------------------------------
67#include "units_c.inc"
68#include "com04_c.inc"
69#include "scr06_c.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73 INTEGER NMN, NRTM, NSN, I_STOK,IGAP,
74 . INACTI,
75 . IPARTS(*), KNOD2ELS(*), NOD2ELS(*)
76 INTEGER IRECT(4,*),NSV(*),ICODE(*),ISKEW(*)
77 INTEGER MSR(*),IDDLEVEL
78 INTEGER NBINFLG(*),MBINFLG(*),ILEV,MSEGTYP(*)
79 INTEGER KREMNODE(*),REMNODE(*)
80 INTEGER IXS(*), IXS10(*), IXS16(*), IXS20(*)
81 LOGICAL, INTENT(in) :: FLAG_REMOVED_NODE !< flag to remove some S node from the list of candidates
82 INTEGER, INTENT(IN) :: IELEM_M(2,NRTM)
83 integer, intent(in) :: nin !< interface index
84 integer, intent(in) :: npari !< first dim of ipari
85 integer, dimension(npari), intent(inout) :: ipari !< interface data
86C REAL
87 my_real
88 . stf(*),stfn(*),x(3,*),gap_s(*),gap_m(*),
89 . dist,bumult,gap,tzinf,maxbox,minbox,gapmin,gapmax,
90 . gap_s_l(*),gap_m_l(*),marge,gap_n(4,*)
91 my_real
92 . bgapsmx
93 my_real , INTENT(IN) :: drad, dgapload
94 INTEGER ID
95 CHARACTER(LEN=NCHARTITLE) :: TITR
96
97 INTEGER , INTENT(IN) :: NRTMT
98 type(intbuf_struct_), intent(inout) :: intbuf_tab !< interface data
99 integer :: candidate_count
100C-----------------------------------------------
101C L o c a l V a r i a b l e s
102C-----------------------------------------------
103 INTEGER I, J, L, N1, N2, N3, N4,N_SOL, ESHIFT
104 INTEGER IBID, NELS
105 INTEGER, DIMENSION(:),ALLOCATABLE :: IIX,IIY,IIZ
106C REAL
107 my_real
108 . dx1,dy1,dz1,
109 . dx3,dy3,dz3,
110 . dx4,dy4,dz4,
111 . dx6,dy6,dz6,
112 . dd1,dd2,dd3,dd4,dd,dd0,xmin,ymin,zmin,
113 . xmax,ymax,zmax,tzinf0,minbox0,maxbox0,
114 . bid,tzinf_st,marge_st,dd_st,d_max,pensol,d_moy,
115 . xyzm(6),bminma(6),aaa,ledgmax
116 my_real,
117 . DIMENSION(:), ALLOCATABLE :: edge_l2,edge_l2_tmp
118 INTEGER TAGP(NPART),IAD,N,IE,IL,IP
119 INTEGER, DIMENSION(:), ALLOCATABLE :: NPARTNS,IELEM,LPARTNS
120 INTEGER NBX,NBY,NBZ
121 INTEGER, DIMENSION(:), ALLOCATABLE :: IS_LARGE_NODE,LARGE_NODE, TAGNOD,LOCAL_NEXT_NOD
122 INTEGER :: NB_LARGE_NODES
123 INTEGER (KIND=8) :: NBX8,NBY8,NBZ8,RES8,LVOXEL8
124 INTEGER (KIND=8) :: IONE,IHUNDRED !< Integer constants in INTEGER 8 for comparisions
125 my_real :: xmin_base, ymin_base, zmin_base, xmax_base, ymax_base, zmax_base
126C-----------------------------------------------
127 ione=1
128 ihundred=100
129 gapmax=ep30
130 gapmin=zero
131
132C-------use temporarily GAP_N(1,*)=V/A
133C Not used :: MVOISN(1,*)-> MTYPE(solid),MVOISN(2,*)-> E_id
134C
135C
136C 1-CALCULATION TAILLE DES ZONES INFLUENCES
137C dd is the average element length
138C dd_st is the max element length
139 dd=zero
140 dd_st=zero
141 pensol=ep30
142 d_moy = zero
143 n_sol = 0
144 DO 10 l=1,nrtm
145C ELEMENT CONNECTIVITIES
146 n1=irect(1,l)
147 n2=irect(2,l)
148 n3=irect(3,l)
149 n4=irect(4,l)
150C LONGUEUR COTE 1
151 dx1=(x(1,n1)-x(1,n2))
152 dy1=(x(2,n1)-x(2,n2))
153 dz1=(x(3,n1)-x(3,n2))
154 dd1=sqrt(dx1**2+dy1**2+dz1**2)
155C LONGUEUR COTE 2
156 dx3=(x(1,n1)-x(1,n4))
157 dy3=(x(2,n1)-x(2,n4))
158 dz3=(x(3,n1)-x(3,n4))
159 dd2=sqrt(dx3**2+dy3**2+dz3**2)
160C LONGUEUR COTE 3
161 dx4=(x(1,n3)-x(1,n2))
162 dy4=(x(2,n3)-x(2,n2))
163 dz4=(x(3,n3)-x(3,n2))
164 dd3=sqrt(dx4**2+dy4**2+dz4**2)
165C LONGUEUR COTE 4
166 dx6=(x(1,n4)-x(1,n3))
167 dy6=(x(2,n4)-x(2,n3))
168 dz6=(x(3,n4)-x(3,n3))
169 dd4=sqrt(dx6**2+dy6**2+dz6**2)
170 dd=dd+ (dd1+dd2+dd3+dd4)
171C-------only for solid--- and coating shell
172 IF (msegtyp(l)==0.OR.msegtyp(l)>nrtmt) THEN
173 d_max=max(dd1,dd2,dd3,dd4)
174 d_max=min(d_max,gap_n(1,l))
175C--------correction of too huge GAP_N(1,L) w/ irregular mesh
176 gap_n(1,l)=d_max
177 dd_st=max(dd_st,d_max)
178 n_sol = n_sol + 1
179 d_moy = d_moy + d_max
180 END IF
181C IF (MSEGTYP(L)==0) DD_ST=MAX(DD_ST,DD1,DD2,DD3,DD4)
182 10 CONTINUE
183C TAILLE ZINF = .1*TAILLE MOYENNE ELEMENT DE CHAQUE COTE
184C TAILLE BUCKET MIN = TZINF * BUMULT
185 dd0=dd/nrtm/four
186 IF(nrtm > 0 .AND. nrtm <= 3) THEN
187 call margin_reduction(x,numnod,irect,nrtm,nsv,nsn,drad,gap,dgapload,bumult,stfn,dd0)
188! special case for floor and wall with only one element
189! the margin may be too large when a wall is modeled with only one element
190 END IF
191
192 dd=dd0
193
194C TZINF = BUMULT*DD
195 marge = bumult*dd
196
197C calculation of tzinf based on the margin and not the other way around
198 tzinf = marge + max(gap+dgapload,drad)
199C marge_st: margin independent of bumult as input to find the same initial penalties (delete or coordinate change cases)
200 marge_st = bmul0*dd
201
202C if iddlevel = 0, then 1st pass here, with the engine's margin to find the same candidates
203 IF(iddlevel==0) marge_st = marge
204 tzinf_st = marge_st + max(gap+dgapload,drad)
205 bid = four_over_5*dd
206 IF (inacti/=7.AND.tzinf>bid) THEN
207 ibid = nint(tzinf/dd0)
208 ibid =(2*ibid+4)*ibid*2
209 ENDIF
210C MAXBOX= ZEP9*(DD - TZINF)
211C DD + 2*Tzinfo: Size element increased in influence zone
212 maxbox= half*(dd + 2*tzinf)
213 minbox= half*maxbox
214 tzinf0 = tzinf
215 minbox0 = minbox
216 maxbox0 = maxbox
217C SET TO ZERO TO PERFORM COMPLETE SEARCH CYCLE 0 ENGINE
218 dist = zero
219
220C--------------------------------
221C calculation of the domain boundaries
222C--------------------------------
223 bminma(1)=-ep30
224 bminma(2)=-ep30
225 bminma(3)=-ep30
226 bminma(4)= ep30
227 bminma(5)= ep30
228 bminma(6)= ep30
229C
230 xmin=ep30
231 xmax=-ep30
232 ymin=ep30
233 ymax=-ep30
234 zmin=ep30
235 zmax=-ep30
236C
237 DO 20 i=1,nmn
238 j=msr(i)
239 xmin= min(xmin,x(1,j))
240 ymin= min(ymin,x(2,j))
241 zmin= min(zmin,x(3,j))
242 xmax= max(xmax,x(1,j))
243 ymax= max(ymax,x(2,j))
244 zmax= max(zmax,x(3,j))
245 20 CONTINUE
246C
247 xmin=xmin-tzinf_st
248 ymin=ymin-tzinf_st
249 zmin=zmin-tzinf_st
250 xmax=xmax+tzinf_st
251 ymax=ymax+tzinf_st
252 zmax=zmax+tzinf_st
253C
254 DO 25 i=1,nsn
255 j=nsv(i)
256 xmin= min(xmin,x(1,j))
257 ymin= min(ymin,x(2,j))
258 zmin= min(zmin,x(3,j))
259 xmax= max(xmax,x(1,j))
260 ymax= max(ymax,x(2,j))
261 zmax= max(zmax,x(3,j))
262 25 CONTINUE
263C
264 bminma(1) = max(bminma(1),xmax)
265 bminma(2) = max(bminma(2),ymax)
266 bminma(3) = max(bminma(3),zmax)
267 bminma(4) = min(bminma(4),xmin)
268 bminma(5) = min(bminma(5),ymin)
269 bminma(6) = min(bminma(6),zmin)
270
271 xyzm(1) = bminma(4)
272 xyzm(2) = bminma(5)
273 xyzm(3) = bminma(6)
274 xyzm(4) = bminma(1)
275 xyzm(5) = bminma(2)
276 xyzm(6) = bminma(3)
277
278 aaa = sqrt(nmn /
279 . ((bminma(1)-bminma(4))*(bminma(2)-bminma(5))
280 . +(bminma(2)-bminma(5))*(bminma(3)-bminma(6))
281 . +(bminma(3)-bminma(6))*(bminma(1)-bminma(4))))
282
283 aaa = 0.75*aaa
284
285 nbx = nint(aaa*(bminma(1)-bminma(4)))
286 nby = nint(aaa*(bminma(2)-bminma(5)))
287 nbz = nint(aaa*(bminma(3)-bminma(6)))
288 nbx = max(nbx,1)
289 nby = max(nby,1)
290 nbz = max(nbz,1)
291
292 nbx8=nbx
293 nby8=nby
294 nbz8=nbz
295 res8=(nbx8+2)*(nby8+2)*(nbz8+2)
296 lvoxel8 = lvoxel
297
298 IF(res8 > lvoxel8) THEN
299 aaa = lvoxel
300 aaa = aaa/((nbx8+2)*(nby8+2)*(nbz8+2))
301 aaa = aaa**(third)
302 nbx = int((nbx+2)*aaa)-2
303 nby = int((nby+2)*aaa)-2
304 nbz = int((nbz+2)*aaa)-2
305 nbx = max(nbx,1)
306 nby = max(nby,1)
307 nbz = max(nbz,1)
308 ENDIF
309
310 nbx8=nbx
311 nby8=nby
312 nbz8=nbz
313 res8=(nbx8+2)*(nby8+2)*(nbz8+2)
314
315 IF(res8 > lvoxel8) THEN
316 nbx = min(ihundred,max(nbx8,ione))
317 nby = min(ihundred,max(nby8,ione))
318 nbz = min(ihundred,max(nbz8,ione))
319 END IF
320
321C--------------------------------
322C Initializations case of IDDLEVEL=0 or INACTI/=5 and INACTI/=-1
323C--------------------------------
324 ALLOCATE(npartns(nsn+1),ielem(nrtm),edge_l2(nsn))
325
326 npartns(1:nsn+1) = 0
327 ielem(1:nrtm) = 0
328 edge_l2(1:nsn) = zero
329 ledgmax = zero
330C--------------------------------
331
332
333
334 nb_large_nodes = 0
335 ALLOCATE(large_node(nsn))
336 ALLOCATE(is_large_node(nsn))
337 ALLOCATE(tagnod(numnod))
338 is_large_node(1:nsn) = 0
339 large_node(1:nsn) = 0
340 nb_large_nodes = 0
341 tagnod(1:numnod) = 0
342
343 IF(iddlevel==1)THEN
344 ! Looking for initial penetration (vs solids) if and only if IDDLEVEL=1
345C
346 DO ie=1,nrtm
347 ! looks for solid element supporting the segment (cf initial penetrations vs solids)
348 IF(ielem_m(1,ie)<=numels) THEN
349 ielem(ie)= ielem_m(1,ie)
350 ELSE
351 CALL insol25(irect ,ixs ,ixs10,ixs16,ixs20,
352 . knod2els ,nod2els ,nels ,ie )
353 ielem(ie)=nels
354 ENDIF
355 END DO
356C
357 IF(inacti==5.OR.inacti==-1)THEN
358
359 ALLOCATE(edge_l2_tmp(numnod))
360 edge_l2_tmp(1:numnod)=zero
361 n_sol = 0
362 DO ie=1,nrtm
363 IF(stf(ie)> zero)THEN ! Solids only
364 DO il=1,4
365 n1=irect(il,ie)
366 n2=irect(mod(il,4)+1,ie)
367
368 aaa = (x(1,n2)-x(1,n1))*(x(1,n2)-x(1,n1))
369 . + (x(2,n2)-x(2,n1))*(x(2,n2)-x(2,n1))
370 . + (x(3,n2)-x(3,n1))*(x(3,n2)-x(3,n1))
371 edge_l2_tmp(n1) = max(edge_l2_tmp(n1), aaa )
372 edge_l2_tmp(n2) = max(edge_l2_tmp(n2), aaa )
373 IF (msegtyp(ie)==0.OR.msegtyp(ie)>nrtmt) THEN ! Solids only
374 IF(tagnod(n1)==0) THEN
375 n_sol= n_sol + 1
376 tagnod(n1) = 1
377 ENDIF
378 IF(tagnod(n2)==0) THEN
379 n_sol= n_sol + 1
380 tagnod(n2) = 1
381 ENDIF
382 ENDIF
383 END DO
384 ENDIF
385
386 END DO
387C
388
389 DO i=1,nsn
390 n=nsv(i)
391 IF(stfn(i)/=zero) THEN
392 edge_l2(i) = half*sqrt(edge_l2_tmp(n))
393 IF(tagnod(n)==1) ledgmax=ledgmax+edge_l2(i)!MAX(LEDGMAX,EDGE_L2(I))
394 END IF
395 END DO
396
397 IF(n_sol > 0) ledgmax=half*ledgmax/n_sol
398
399
400 DEALLOCATE(edge_l2_tmp)
401
402 ENDIF
403
404c IF(INACTI==5.OR.INACTI==-1)THEN ! Do it for all Inacti ( warnings initial penetrations)
405 tagp(1:npart) =0
406C
407 DO i=1,nsn
408 n=nsv(i)
409 DO iad=knod2els(n)+1,knod2els(n+1)
410 ie=nod2els(iad)
411 ip=iparts(ie)
412 IF(tagp(ip)==0)THEN
413 npartns(i)=npartns(i)+1
414 tagp(ip) =1
415 END IF
416 END DO
417 DO iad=knod2els(n)+1,knod2els(n+1)
418 ie=nod2els(iad)
419 ip=iparts(ie)
420 tagp(ip) =0 ! Reset
421 END DO
422 END DO
423C
424 DO i=1,nsn
425 npartns(i+1) = npartns(i+1) + npartns(i)
426 END DO
427 DO i=nsn,1,-1
428 npartns(i+1) = npartns(i)
429 END DO
430 npartns(1)=0
431C
432 ALLOCATE(lpartns(npartns(nsn+1)))
433C
434 DO i=1,nsn
435 n=nsv(i)
436 DO iad=knod2els(n)+1,knod2els(n+1)
437 ie=nod2els(iad)
438 ip=iparts(ie)
439 IF(tagp(ip)==0)THEN
440 npartns(i)=npartns(i)+1
441 lpartns(npartns(i))=ip
442 tagp(ip) =1
443 END IF
444 END DO
445 DO iad=knod2els(n)+1,knod2els(n+1)
446 ie=nod2els(iad)
447 ip=iparts(ie)
448 tagp(ip) =0 ! Reset
449 END DO
450 END DO
451C
452 DO i=nsn,1,-1
453 npartns(i+1) = npartns(i)
454 END DO
455 npartns(1)=0
456C
457c ELSE
458c ALLOCATE(LPARTNS(0))
459c END IF
460 ELSE
461 ALLOCATE(lpartns(0))
462 END IF
463C
464
465C complete initialization of voxel
466 DO i=inivoxel,(nbx+2)*(nby+2)*(nbz+2)
467 voxel1(i)=0
468 ENDDO
469 inivoxel = max(inivoxel,(nbx+2)*(nby+2)*(nbz+2)+1)
470C
471 eshift=0
472C
473 i_stok = 0
474
475 ALLOCATE(local_next_nod(nsn))
476 ALLOCATE(iix(nsn))
477 ALLOCATE(iiy(nsn))
478 ALLOCATE(iiz(nsn))
479C
480!$OMP PARALLEL
481 CALL i25trivox1(
482 1 nsn ,irect ,x ,
483 2 stfn ,xyzm ,nsv ,i_stok ,
484 3 eshift ,bgapsmx ,
485 4 voxel1 ,nbx ,nby ,nbz ,nrtm ,
486 5 gap_s ,gap_m ,marge_st,
487 6 nbinflg ,mbinflg ,ilev ,msegtyp ,
488 7 igap ,gap_s_l ,gap_m_l ,edge_l2 ,ledgmax ,
489 8 kremnode,remnode,
490 9 iparts ,npartns ,lpartns ,ielem ,icode ,
491 a iskew ,drad, is_large_node, large_node, nb_large_nodes,
492 b dgapload,nrtmt,flag_removed_node,
493 c ielem_m,local_next_nod,iix,iiy,iiz,
494 d intbuf_tab,ipari,nin)
495!$OMP END PARALLEL
496 DEALLOCATE(local_next_nod)
497 DEALLOCATE(iix)
498 DEALLOCATE(iiy)
499 DEALLOCATE(iiz)
500
501 DEALLOCATE(edge_l2,npartns,ielem,lpartns)
502 DEALLOCATE(is_large_node,large_node,tagnod)
503C
504 IF(nsn/=0)THEN
505 WRITE(iout,*)' POSSIBLE IMPACT NUMBER, NSN:',i_stok,nsn
506C
507 ELSE
508 CALL ancmsg(msgid=552,
509 . msgtype=msgwarning,
510 . anmode=aninfo_blind_2,
511 . i1=id,
512 . c1=titr)
513 ENDIF
514C
515 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
insol25
subroutine insol25(irect, ixs, ixs10, ixs16, ixs20, knod2els, nod2els, nel, i)
Definition i25buc_vox1.F:526
i25trivox1
subroutine i25trivox1(nsn, irect, x, stfn, xyzm, nsv, ii_stok, eshift, bgapsmx, voxel, nbx, nby, nbz, nrtm, gap_s, gap_m, marge, nbinflg, mbinflg, ilev, msegtyp, igap, gap_s_l, gap_m_l, edge_l2, ledgmax, kremnode, remnode, iparts, npartns, lpartns, ielem, icode, iskew, drad, is_large_node, large_node, nb_large_nodes, dgapload, nrtmt, flag_removed_node, ielem_m, local_next_nod, iix, iiy, iiz, intbuf_tab, ipari, nin)
Definition i25trivox1.F:46
ymax
subroutine ymax(idn, fac, npc, pld, stiffmin, stiffmax, stiffini, stiffavg)
Definition law100_upd.F:274
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
tri7box::voxel1
integer, dimension(lvoxel) voxel1
Definition tri7box.F:53
tri7box::inivoxel
integer inivoxel
Definition tri7box.F:53
tri7box::lvoxel
integer lvoxel
Definition tri7box.F:51
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:895
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29

◆ insol25()

subroutine insol25 ( integer, dimension(4,*) irect,
integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer nel,
integer i )

Definition at line 524 of file i25buc_vox1.F.

526 use element_mod , only :nixs
527C-----------------------------------------------
528C I m p l i c i t T y p e s
529C-----------------------------------------------
530#include "implicit_f.inc"
531C-----------------------------------------------
532C C o m m o n B l o c k s
533C-----------------------------------------------
534#include "com04_c.inc"
535C-----------------------------------------------
536C D u m m y A r g u m e n t s
537C-----------------------------------------------
538 INTEGER NEL, I
539 INTEGER IRECT(4,*), IXS(NIXS,*), KNOD2ELS(*), NOD2ELS(*),
540 . IXS10(6,*), IXS16(8,*), IXS20(12,*)
541C-----------------------------------------------
542C L o c a l V a r i a b l e s
543C-----------------------------------------------
544 INTEGER N, JJ, II, K, IC, IAD,
545 . NUSER, NUSERM
546C-----------------------------------------------
547C E x t e r n a l F u n c t i o n s
548C-----------------------------------------------
549C
550 nel=0
551
552 IF(numels==0) RETURN
553
554 IF(irect(1,i)>numnod) RETURN
555
556 ic=0
557 nuserm = -1
558 DO 230 iad=knod2els(irect(1,i))+1,knod2els(irect(1,i)+1)
559 n = nod2els(iad)
560 IF(n <= numels8)THEN
561 DO 210 jj=1,4
562 ii=irect(jj,i)
563 DO k=1,8
564 IF(ixs(k+1,n)==ii) GOTO 210
565 ENDDO
566 GOTO 230
567 210 CONTINUE
568 ic=ic+1
569 nuser = ixs(11,n)
570 IF (nuser>nuserm) THEN
571 nel = n
572 nuserm = nuser
573 ENDIF
574 ELSEIF(n <= numels8+numels10)THEN
575 DO 220 jj=1,4
576 ii=irect(jj,i)
577 DO k=1,8
578 IF(ixs(k+1,n)==ii) GOTO 220
579 ENDDO
580 DO k=1,6
581 IF(ixs10(k,n-numels8)==ii) GOTO 220
582 ENDDO
583 GOTO 230
584 220 CONTINUE
585 ic=ic+1
586 nuser = ixs(11,n)
587 IF (nuser>nuserm) THEN
588 nel = n
589 nuserm = nuser
590 ENDIF
591 ELSEIF(n <= numels8+numels10+numels20)THEN
592 DO 222 jj=1,4
593 ii=irect(jj,i)
594 DO k=1,8
595 IF(ixs(k+1,n)==ii) GOTO 222
596 ENDDO
597 DO k=1,12
598 IF(ixs20(k,n-numels8-numels10)==ii) GOTO 222
599 ENDDO
600 GOTO 230
601 222 CONTINUE
602 ic=ic+1
603 nuser = ixs(11,n)
604 IF (nuser>nuserm) THEN
605 nel = n
606 nuserm = nuser
607 ENDIF
608 ELSEIF(n <= numels8+numels10+numels20+numels16)THEN
609 DO 224 jj=1,4
610 ii=irect(jj,i)
611 DO k=1,8
612 IF(ixs(k+1,n)==ii) GOTO 224
613 ENDDO
614 DO k=1,8
615 IF(ixs16(k,n-numels8-numels10-numels20)==ii) GOTO 224
616 ENDDO
617 GOTO 230
618 224 CONTINUE
619 ic=ic+1
620 nuser = ixs(11,n)
621 IF (nuser>nuserm) THEN
622 nel = n
623 nuserm = nuser
624 ENDIF
625 ELSE
626 GOTO 230
627 END IF
628 230 CONTINUE
629 RETURN