OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25remlin.F File Reference
#include "implicit_f.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine i25remline (x, nedge, ledge, numnod, gap_e, gap_e_l, igap0, igap, drad, bgapemx, bgapemx_l, kremnode, remnode, nremnode, i_start, i_mem_rem, inod2lin, tagsecnd, nod2lin, dgapload, perm, perm_inv, gap_maxneigh)
subroutine remn_i2op_edg25 (n, flagremnode, ipari, intbuf_tab, i2node, points_i2n, i2node_size, nom_opt, itab, flag_output)

Function/Subroutine Documentation

◆ i25remline()

subroutine i25remline ( x,
integer nedge,
integer, dimension(nledge,*) ledge,
integer numnod,
gap_e,
gap_e_l,
integer igap0,
integer igap,
drad,
bgapemx,
bgapemx_l,
integer, dimension(*) kremnode,
integer, dimension(*) remnode,
integer nremnode,
integer i_start,
integer i_mem_rem,
integer, dimension(numnod+1) inod2lin,
integer, dimension(numnod) tagsecnd,
integer, dimension(2*nedge) nod2lin,
intent(in) dgapload,
integer, dimension(nedge), intent(inout) perm,
integer, dimension(nedge), intent(inout) perm_inv,
dimension(nedge), intent(inout) gap_maxneigh )

Definition at line 31 of file i25remlin.F.

37C-----------------------------------------------
38C I m p l i c i t T y p e s
39C-----------------------------------------------
40#include "implicit_f.inc"
41C-----------------------------------------------
42C C o m m o n B l o c k s
43C-----------------------------------------------
44#include "param_c.inc"
45C-----------------------------------------------
46C D u m m y A r g u m e n t s
47C-----------------------------------------------
48 INTEGER NEDGE, NUMNOD,IGAP0,IGAP, NREMNODE
49 INTEGER LEDGE(NLEDGE,*),KREMNODE(*),REMNODE(*),I_START,I_MEM_REM
50 INTEGER INOD2LIN(NUMNOD+1),TAGSECND(NUMNOD),NOD2LIN(2*NEDGE)
51 INTEGER , INTENT(INOUT) :: PERM(NEDGE),PERM_INV(NEDGE)
52 my_real
53 . x(3,*),gap_e(*),gap_e_l(*),drad,bgapemx,bgapemx_l
54 my_real , INTENT(IN) :: dgapload
55 my_real , INTENT(INOUT) :: gap_maxneigh(nedge)
56C-----------------------------------------------
57C L o c a l V a r i a b l e s
58C-----------------------------------------------
59 INTEGER I,II,J,JJ,K,LIN,ILIN,LEVEL,CPT,NBLIN,LIN1,L,CPT1,CPT2,N,NBLIN_MAX,CPT_TOTAL
60 INTEGER :: IM1,IM2,FOUND,LL,TOT_SYM
61 INTEGER, DIMENSION(:),ALLOCATABLE ::
62 . KNOD2LIN,TAGNOD,ORIGIN,ITAG,LISTLIN,LISTLINTMP,LISTLINTOTAL,
63 . REM_TMP,KREM_TMP
64 INTEGER, DIMENSION(:,:),ALLOCATABLE :: TAG_SYM
65 my_real
66 . dmax,new_dist,pene,i11pene_lin,xl,gapv,gap,drad2
67 my_real, DIMENSION(:),ALLOCATABLE ::
68 . dist1,gap_e_sort
69C-----------------------------------------------
70c Build inverse connectivity for segments - only at first pass (I_START=1)
71C-----------------------------------------------
72C
73 drad2 = zero !no thermal exchange for E2E
74 IF (i_start ==1) THEN
75C
76 ALLOCATE(knod2lin(numnod+1),gap_e_sort(nedge))
77C
78 kremnode(1) = 1
79 nod2lin(1:2*nedge) = 0
80 knod2lin(1:numnod+1) = 0
81 inod2lin(1:numnod+1) = 0
82 tagsecnd(1:numnod) = 0
83 cpt = nedge
84C
85 DO i=1,nedge
86 tagsecnd(ledge(5,i)) = 1
87 tagsecnd(ledge(6,i)) = 1
88 ENDDO
89 gap_maxneigh(1:nedge) = gap_e(1:nedge)
90C
91C edges are sorted by increasing gap
92 DO i=1,nedge
93 perm(i) =i
94 gap_e_sort(i) = gap_e(i)
95 ENDDO
96 CALL stlsort_real_int(nedge,gap_e_sort,perm)
97 IF(ALLOCATED(gap_e_sort)) DEALLOCATE(gap_e_sort)
98 DO ii=1,nedge
99 i=perm(nedge - ii + 1)
100 perm_inv(i) =ii
101 ENDDO
102
103C-----------------------------------------------
104C Definition of node to segment connections
105C-----------------------------------------------
106C
107 DO i=1,nedge
108 n = ledge(5,i)
109 knod2lin(n) = knod2lin(n) + 1
110 n = ledge(6,i)
111 knod2lin(n) = knod2lin(n) + 1
112 END DO
113C
114 inod2lin(1) = 1
115 DO i=1,numnod
116 inod2lin(i+1) = inod2lin(i) + knod2lin(i)
117 END DO
118 knod2lin(1:numnod+1) = inod2lin(1:numnod+1)
119C
120 DO i=1,nedge
121 n = ledge(5,i)
122 nod2lin(knod2lin(n)) = i
123 knod2lin(n) = knod2lin(n) + 1
124 n = ledge(6,i)
125 nod2lin(knod2lin(n)) = i
126 knod2lin(n) = knod2lin(n) + 1
127 END DO
128C
129 DEALLOCATE(knod2lin)
130C
131 ENDIF
132C
133C
134 IF (i_start>=1) THEN
135C
136C-----------------------------------------------
137C Searching Algorithm Connected nodes : D < SQRT(2.) * GAP
138C-----------------------------------------------
139C
140 ALLOCATE(tagnod(numnod),origin(numnod),dist1(numnod))
141 tagnod(1:numnod) = 0
142 origin(1:numnod) = 0
143 dist1(1:numnod) = ep30
144 ALLOCATE(itag(nedge),listlin(nedge),listlintmp(nedge),listlintotal(nedge))
145
146 itag(1:nedge) = 0
147 listlin(1:nedge) = 0
148 listlintmp(1:nedge)=0
149 listlintotal(1:nedge) = 0
150 cpt_total = 0
151C
152C loop on edges with decreasing gap
153 DO ii=i_start,nedge
154
155 i=perm(nedge - ii + 1)
156 level = 1
157 lin = i
158
159 itag(lin) = level
160 listlin(1)=lin
161 nblin=1
162 nblin_max=1
163 cpt = 0
164 cpt_total = 0
165 xl = (x(1,ledge(5,i))-x(1,ledge(6,i)))**2+(x(2,ledge(5,i))-x(2,ledge(6,i)))**2+(x(3,ledge(5,i))-x(3,ledge(6,i)))**2
166 xl = sqrt(xl)
167C
168 IF(igap0 == 0) THEN
169 gap = gap_maxneigh(i)+two*gap_e(i)
170 ELSE
171 gap = two*(gap_maxneigh(i)+gap_e(i))
172 ENDIF
173 IF(igap==3) gap = min(gap,gap_e_l(i)+bgapemx_l)
174
175 dmax = sqrt(two) * max(gap+dgapload,drad2)
176C
177 tagnod(ledge(5,lin)) = 1
178 dist1(ledge(5,lin)) = zero
179
180 tagnod(ledge(6,lin)) = 1
181 dist1(ledge(6,lin)) = zero
182C
183 DO WHILE (nblin/=0)
184C
185 level = level+1
186 cpt = 0
187 DO ilin=1,nblin
188 lin=listlin(ilin)
189
190 tagnod(ledge(5,lin)) = 2
191 tagnod(ledge(6,lin)) = 2
192C
193 pene = zero
194 IF ((dist1(ledge(5,lin)) > dmax).AND.(dist1(ledge(6,lin)) > dmax).AND.(level>2)) THEN
195 pene = i11pene_lin(x,ledge(5,lin),ledge(6,lin),ledge(5,i),ledge(6,i),dmax)
196 ENDIF
197C
198 IF ((level <= 2).OR.(dist1(ledge(5,lin)) <= dmax).OR.(dist1(ledge(6,lin)) <= dmax).OR.(pene > zero)) THEN
199 DO j=5,6
200 DO k=inod2lin(ledge(j,lin)),inod2lin(ledge(j,lin)+1)-1
201 lin1 = nod2lin(k)
202 IF( (itag(lin1) == 0 .OR. itag(lin1) == level)) THEN
203 IF(itag(lin1) == 0)THEN
204 cpt = cpt + 1
205 listlintmp(cpt)=lin1
206 ENDIF
207 itag(lin1)=level
208 DO l=5,6
209
210 IF ((tagsecnd(ledge(l,lin1))== 1).AND.(origin(ledge(l,lin1)) /= ledge(j,lin))
211 . .AND.((ledge(l,lin1)) /= ledge(j,lin)).AND.(tagnod(ledge(l,lin1)) /= 2)) THEN
212C
213 new_dist=dist1(ledge(j,lin))+
214 . sqrt((x(1,ledge(l,lin1))-x(1,ledge(j,lin)))**2 +
215 . (x(2,ledge(l,lin1)) - x(2,ledge(j,lin)))**2 +
216 . (x(3,ledge(l,lin1)) - x(3,ledge(j,lin)))**2 )
217C
218 IF (new_dist < dist1(ledge(l,lin1))) THEN
219 dist1(ledge(l,lin1)) = new_dist
220 ENDIF
221C
222 IF(tagnod(ledge(l,lin1))==0) THEN
223 tagnod(ledge(l,lin1)) = 1
224 ENDIF
225C
226 ENDIF
227 ENDDO
228 ENDIF
229 ENDDO
230 ENDDO
231 ENDIF
232C
233 tagnod(ledge(5:6,lin))=1
234 ENDDO
235C
236 nblin = cpt
237C
238 nblin_max = max(nblin_max,nblin)
239 IF(nblin ==0)EXIT
240 DO j=1,cpt
241 listlin(j)=listlintmp(j)
242 listlintmp(j) = 0
243 listlintotal(j+cpt_total) = listlin(j)
244 ENDDO
245 cpt_total = cpt_total + cpt
246C
247C----------------
248 ENDDO
249C
250CC END DO WHILE
251C
252C-- Check memory for data storage
253C
254 i_start = ii
255 IF (kremnode(ii)+cpt_total > nremnode) THEN
256C-- Not enough memory - upgrade_remnode
257 i_mem_rem = 1
258 EXIT
259 ENDIF
260C
261 cpt1 = 0
262 im1 = ledge(5,i)
263 im2 = ledge(6,i)
264C
265 DO l=1,cpt_total
266 lin = listlintotal(l)
267 IF ((im1 /= ledge(5,lin)).AND.(im1 /= ledge(6,lin))
268 . .AND.(im2 /= ledge(5,lin)).AND.(im2 /= ledge(6,lin))) THEN
269C--- lines with common nodes with main lines are already removed - no need to store them in remnode
270 IF(igap0 == 0) THEN
271 gapv = gap_e(lin)+two*gap_e(i)
272 ELSE
273 gapv = two*(gap_e(lin)+gap_e(i))
274 ENDIF
275 IF(igap==3) gapv = min(gapv,gap_e_l(lin)+gap_e_l(i))
276
277 gapv = sqrt(two)*max(drad2,gapv+dgapload)
278 IF ((dist1(ledge(5,lin)) <= gapv).OR.(dist1(ledge(6,lin)) <= gapv)) THEN
279 remnode(kremnode(ii)+cpt1) = lin
280 cpt1 = cpt1 + 1
281 gap_maxneigh(lin) = max(gap_maxneigh(lin),gap_e(i))
282 ELSE
283 pene = i11pene_lin(x,ledge(5,lin),ledge(6,lin),ledge(5,i),ledge(6,i),gapv)
284 IF (pene > 0) THEN
285 remnode(kremnode(ii)+cpt1) = lin
286 cpt1 = cpt1 + 1
287 gap_maxneigh(lin) = max(gap_maxneigh(lin),gap_e(i))
288 ENDIF
289 ENDIF
290 ENDIF
291 ENDDO
292 kremnode(ii+1) = kremnode(ii) + cpt1
293
294C
295C-----------------------------------------------
296C Clean of used arrays
297C-----------------------------------------------
298C
299 dist1(ledge(5,i)) = ep30
300 dist1(ledge(6,i)) = ep30
301 origin(ledge(5,i)) = 0
302 origin(ledge(6,i)) = 0
303 tagnod(ledge(5,i)) = 0
304 tagnod(ledge(6,i)) = 0
305 itag(i) = 0
306C
307 DO l=1,cpt_total
308 lin = listlintotal(l)
309 itag(lin) = 0
310 listlintotal(l) = 0
311 tagnod(ledge(5,lin)) = 0
312 tagnod(ledge(6,lin)) = 0
313 dist1(ledge(5,lin)) = ep30
314 dist1(ledge(6,lin)) = ep30
315 origin(ledge(5,lin)) = 0
316 origin(ledge(6,lin)) = 0
317 ENDDO
318 listlintmp(1:nblin_max)=0
319 listlin(1:nblin_max)=0
320C
321 ENDDO
322CC END DO NEDGE
323C
324 IF (i_mem_rem == 0) THEN
325C Symmetry check
326 ALLOCATE(tag_sym(2,nedge))
327 tag_sym(1:2,1:nedge) = 0
328 tot_sym = 0
329 DO i=1,nedge
330 ii = perm_inv(i)
331 cpt1 = kremnode(ii+1) - kremnode(ii)
332 DO l=1,cpt1
333 jj = remnode(kremnode(ii)+l-1)
334 lin = perm_inv(remnode(kremnode(ii)+l-1))
335 cpt2 = kremnode(lin+1) - kremnode(lin)
336 found = 0
337 DO ll=1,cpt2
338 j = remnode(kremnode(lin)+ll-1)
339 IF (i==j) found = 1
340 ENDDO
341 IF (found == 0) THEN
342 tot_sym = tot_sym + 1
343 tag_sym(2,jj) = tag_sym(2,jj) + 1
344 tag_sym(1,i) = 1
345 ENDIF
346 ENDDO
347 ENDDO
348c
349 IF (kremnode(nedge+1)+tot_sym > nremnode) THEN
350C-- Not enough memory to store missing symetrised connections - upgrade_remnode
351 i_mem_rem = 1
352 i_start = nedge
353 i_mem_rem = 1
354 ENDIF
355 ENDIF
356c
357 IF (i_mem_rem == 0) THEN
358C
359 ALLOCATE(rem_tmp(nremnode),krem_tmp(nedge+1))
360 rem_tmp(1:nremnode) = remnode(1:nremnode)
361 krem_tmp(1:nedge+1) = kremnode(1:nedge+1)
362 kremnode(1) = 1
363C
364 DO i=1,nedge
365 ii = perm_inv(i)
366 cpt1 = krem_tmp(ii+1) - krem_tmp(ii)
367 kremnode(i+1) = kremnode(i) + cpt1 + tag_sym(2,i)
368 ENDDO
369C
370C REMNODE is reorganized in edge order
371 DO i=1,nedge
372 ii = perm_inv(i)
373 cpt1 = krem_tmp(ii+1) - krem_tmp(ii)
374 DO l=1,cpt1
375 lin = rem_tmp(krem_tmp(ii)+l-1)
376 remnode(kremnode(i)+l-1) = lin
377 ENDDO
378 ENDDO
379C
380 IF (tot_sym > 0) THEN
381 tag_sym(2,1:nedge) = 0
382C Missing connections are added for symetrization
383 DO i=1,nedge
384 IF (tag_sym(1,i) > 0) THEN
385 ii = perm_inv(i)
386 cpt1 = krem_tmp(ii+1) - krem_tmp(ii)
387 DO l=1, cpt1
388 lin = remnode(kremnode(i)+l-1)
389 jj = perm_inv(lin)
390 cpt2 = krem_tmp(jj+1) - krem_tmp(jj)
391 found = 0
392 DO ll=1,cpt2
393 IF (i==remnode(kremnode(lin)+ll-1)) found = 1
394 ENDDO
395 IF (found == 0) THEN
396 tag_sym(2,lin) = tag_sym(2,lin) + 1
397 remnode(kremnode(lin)+cpt2 + tag_sym(2,lin)-1) = i
398 ENDIF
399 ENDDO
400 ENDIF
401 ENDDO
402 ENDIF
403C
404 DEALLOCATE(rem_tmp,krem_tmp,tag_sym)
405
406 ENDIF
407C
408 ENDIF
409C
410 DEALLOCATE(dist1,tagnod,origin)
411 IF(ALLOCATED(itag)) DEALLOCATE(itag)
412 IF(ALLOCATED(listlintotal)) DEALLOCATE(listlintotal)
413 IF(ALLOCATED(listlin)) DEALLOCATE(listlin)
414 IF(ALLOCATED(listlintmp)) DEALLOCATE(listlintmp)
415C
416 RETURN
origin
integer function origin(nn, ixc, ipartc, ipart)
Definition build_admesh.F:70
stlsort_real_int
void stlsort_real_int(int *len, my_real *keys, int *values)
Definition cppsort.cpp:95
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29

◆ remn_i2op_edg25()

subroutine remn_i2op_edg25 ( integer, intent(in) n,
integer, intent(in) flagremnode,
integer, dimension(npari,ninter), intent(inout) ipari,
type(intbuf_struct_), dimension(ninter), intent(inout) intbuf_tab,
integer, dimension(i2node_size,3), intent(in) i2node,
integer, dimension(numnod,2), intent(in) points_i2n,
integer, intent(in) i2node_size,
integer, dimension(lnopt1,ninter), intent(in) nom_opt,
integer, dimension(numnod), intent(in) itab,
integer, intent(in) flag_output )
Parameters
[in]flag_outputflag to print the message/warning

Definition at line 432 of file i25remlin.F.

434C-----------------------------------------------
435C M o d u l e s
436C-----------------------------------------------
437 USE my_alloc_mod
438 USE message_mod
439 USE intbufdef_mod
440 USE names_and_titles_mod , ONLY : nchartitle
441 USE intbufdef_mod
442C-----------------------------------------------
443C I m p l i c i t T y p e s
444C-----------------------------------------------
445#include "implicit_f.inc"
446C-----------------------------------------------
447C A n a l y s e M o d u l e
448C-----------------------------------------------
449#include "param_c.inc"
450C-----------------------------------------------
451C D u m m y A r g u m e n t s
452C-----------------------------------------------
453 INTEGER , INTENT(IN) :: N , FLAGREMNODE, I2NODE_SIZE
454 INTEGER , INTENT(INOUT) :: IPARI(NPARI,NINTER)
455 INTEGER , INTENT(IN) :: I2NODE(I2NODE_SIZE,3),POINTS_I2N(NUMNOD,2)
456 INTEGER , INTENT(IN) :: NOM_OPT(LNOPT1,NINTER),ITAB(NUMNOD)
457 INTEGER, INTENT(in) :: FLAG_OUTPUT !< flag to print the message/warning
458
459 TYPE(INTBUF_STRUCT_) , INTENT(INOUT) :: INTBUF_TAB(NINTER)
460C-----------------------------------------------
461C C o m m o n B l o c k s
462C-----------------------------------------------
463#include "com04_c.inc"
464#include "scr17_c.inc"
465C-----------------------------------------------
466C L o c a l V a r i a b l e s
467C-----------------------------------------------
468 INTEGER II,J,K,IE,NN, NM,N2,ND,NES,NM2,M,
469 . NN2,NNOD,NNREM_EDG,KI,KL,JJ,IEDG,IEDGS,ES,
470 . COMPTEUR,I,L,L1,IS,IIS,NS,IADA,III,JJJ,NNOD_2,
471 . FIRST,LAST,NNREM_EDG_SAVE,
472 . OFFSET, NBR_INTRA,NBR_EXTRA,TOTAL_INSERTED,
473 . OLDSIZE,
474 . NREMOV_EDG,NEDGE,MAX_INSERTED_I2,ND_TAG,
475 . SOL_EDGE,SH_EDGE,IEDGE,NRTM
476 INTEGER(8) :: SIZE_INSERTED_EDG,MAX_INSERTED_EDG,DIFF_INT8
477 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGD_EDG
478 INTEGER ID
479 CHARACTER(LEN=NCHARTITLE) :: TITR
480 INTEGER, DIMENSION(:), ALLOCATABLE :: NBR_INSERT_II,ADRESS_II
481 INTEGER, DIMENSION(:), ALLOCATABLE :: KREMNODE_EDG_SAVE,INSERTED_EDG,REMNODE_EDG,TMP_EDG
482 INTEGER, DIMENSION(:),ALLOCATABLE :: INOD2LIN,NOD2LIN,KNOD2LIN
483 INTEGER, DIMENSION(:),ALLOCATABLE :: TAG_ND,IDX_ND,TAG_NDE
484! -------------------------------
485! FIRST : integer , first block of inserted edges
486! LAST : integer , last block of inserted edges
487! NNREM_edg_SAVE : integer , internal counter
488! OFFSET : integer , internal offset for the REMNODE_EDG array
489! NBR_INTRA : integer , number of old EDGES between 2 blocks
490! NBR_EXTRA : integer , number of old remaining edges
491! TOTAL_INSERTED : integer , total number of inserted edgees
492! NBR_INSERT_II : integer, dimension = nedge , number of inserted edges for each ii edge
493! ADRESS_II : integer, dimension = NEDGE , adress of the first inserted edges for each II segment
494! KREMNODE_EDG_SAVE : integer, dimension = NEDGE+1 , list of old edges
495! SIZE_INSERTED_EDG : integer, size of the INSERTED_EDG array ; SIZE_INSERTED_EDG is an upper bound,
496! can be optimized!
497! INSERTED_EDG : integer, dimension = SIZE_INSERTED_EDG, list inserted edges
498! REMNODE_EDG : integer, dimension = NEDGE + TOTAL_INSERTED, new array with old and inserted edges
499! -------------------------------
500
501 INTEGER :: LIMIT
502C-----------------------------------------------
503
504 id=nom_opt(1,n)
505 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
506
507 nedge =ipari(68,n)
508 iedge = ipari(58,n)
509 nrtm = ipari(4,n)
510C
511 ALLOCATE(inod2lin(numnod+1),nod2lin(2*nedge))
512 ALLOCATE(knod2lin(numnod+1))
513C
514 nod2lin(1:2*nedge) = 0
515 knod2lin(1:numnod+1) = 0
516 inod2lin(1:numnod+1) = 0
517C-----------------------------------------------
518C Definition of node to line connections
519C-----------------------------------------------
520C
521 DO i=1,nedge
522 nn = intbuf_tab(n)%LEDGE(5+(i-1)*nledge)
523 knod2lin(nn) = knod2lin(nn) + 1
524 nn = intbuf_tab(n)%LEDGE(6+(i-1)*nledge)
525 knod2lin(nn) = knod2lin(nn) + 1
526 END DO
527C
528 inod2lin(1) = 1
529 DO i=1,numnod
530 inod2lin(i+1) = inod2lin(i) + knod2lin(i)
531 END DO
532 knod2lin(1:numnod+1) = inod2lin(1:numnod+1)
533C
534 DO i=1,nedge
535 nn = intbuf_tab(n)%LEDGE(5+(i-1)*nledge)
536 nod2lin(knod2lin(nn)) = i
537 knod2lin(nn) = knod2lin(nn) + 1
538 nn = intbuf_tab(n)%LEDGE(6+(i-1)*nledge)
539 nod2lin(knod2lin(nn)) = i
540 knod2lin(nn) = knod2lin(nn) + 1
541 END DO
542
543 ALLOCATE(tagd_edg(nedge))
544
545 sol_edge =iedge/10 ! solids
546 sh_edge =iedge-10*sol_edge ! shells
547
548C---------------------------------------------------------------------
549C Main solids : build tables for deleted edges for each NRTM
550C Use tabs of N2S : edge is deactivated if 1 node is deactivated
551C--------------------------------------------------------------------
552 IF(sol_edge > 0 .AND. ipari(63,n) == 2) THEN
553
554 max_inserted_edg = 0
555 DO i=1,numnod
556 diff_int8 = inod2lin(i+1)-inod2lin(i)
557 max_inserted_edg = max(max_inserted_edg,diff_int8)
558 ENDDO
559
560 ALLOCATE( nbr_insert_ii(nrtm) )
561 ALLOCATE( kremnode_edg_save(nrtm+1) )
562 size_inserted_edg = max_inserted_edg*ipari(62,n)
563 CALL my_alloc(inserted_edg,size_inserted_edg)
564 tagd_edg(1:nedge)=0
565 kremnode_edg_save(1:nrtm+1) = 0
566 nbr_insert_ii(1:nrtm) = 0
567 jjj = 0
568 nnrem_edg = 0
569 DO ii=1,nrtm
570 k = intbuf_tab(n)%KREMNODE(ii)+1
571 l = intbuf_tab(n)%KREMNODE(ii+1)
572 DO m=k,l
573 nn = intbuf_tab(n)%REMNODE(m)
574 IF ((inod2lin(nn+1)-inod2lin(nn))/=0) THEN
575 DO ie=inod2lin(nn),inod2lin(nn+1)-1
576 iedgs = nod2lin(ie)
577 IF (tagd_edg(iedgs)==0) THEN
578 nnrem_edg = nnrem_edg + 1
579 tagd_edg(iedgs)=1
580 jjj = jjj + 1
581 inserted_edg(jjj) = iedgs
582 nbr_insert_ii(ii) = nbr_insert_ii(ii) +1
583 ENDIF
584 ENDDO
585 ENDIF
586 ENDDO
587 kremnode_edg_save(ii+1) = kremnode_edg_save(ii)+nbr_insert_ii(ii)
588 DO m=k,l
589 nn = intbuf_tab(n)%REMNODE(m)
590 IF ((inod2lin(nn+1)-inod2lin(nn))/=0) THEN
591 DO ie=inod2lin(nn),inod2lin(nn+1)-1
592 iedgs = nod2lin(ie)
593 IF (tagd_edg(iedgs)==1) tagd_edg(iedgs)=0
594 ENDDO
595 ENDIF
596 ENDDO
597 ENDDO
598
599 CALL upgrade_remnode_e2s(ipari(1,n),nnrem_edg,intbuf_tab(n))
600
601 intbuf_tab(n)%REMNODE_E2S(1:nnrem_edg) = inserted_edg(1:nnrem_edg)
602 intbuf_tab(n)%KREMNODE_E2S(1:nrtm+1) = kremnode_edg_save(1:nrtm+1)
603 intbuf_tab(n)%KREMNODE_E2S(1)=0
604 DO ii=1,nrtm+1
605 intbuf_tab(n)%KREMNODE_E2S(ii) =intbuf_tab(n)%KREMNODE_E2S(ii)+1
606 ENDDO
607
608 DEALLOCATE(nbr_insert_ii,kremnode_edg_save,inserted_edg)
609
610 ! ---------
611 IF(flag_output>0) THEN
612 ! Output message
613 CALL ancmsg(msgid=2067,
614 . msgtype=msgwarning,
615 . anmode=aninfo_blind_1,
616 . i1=id,
617 . c1=titr,
618 . i2=nnrem_edg)
619 ENDIF
620 ! ---------
621 ENDIF
622
623C---------------------------------------------------------------------
624C Main shells : same algorithm like N2S
625C--------------------------------------------------------------------
626
627 IF(sh_edge > 0) THEN
628
629
630 ALLOCATE(tag_nd(numnod))
631 ALLOCATE(idx_nd(numnod))
632 ALLOCATE(tag_nde(numnod))
633
634 ALLOCATE( nbr_insert_ii(nedge) )
635 ALLOCATE( adress_ii(nedge) )
636 ALLOCATE( kremnode_edg_save(nedge+1) )
637 nbr_insert_ii(1:nedge) = 0
638 adress_ii(1:nedge) = 0
639 kremnode_edg_save(1:nedge+1) = 0
640
641C---------
642 jjj = 0
643 nnrem_edg = 0
644
645 tagd_edg(1:nedge)=0
646 tag_nd(1:numnod) = 0
647 idx_nd(1:numnod) = 0
648 tag_nde(1:numnod) = 0
649 nremov_edg = ipari(94,n)
650 iada= 1
651 IF(nremov_edg>0) kremnode_edg_save(1:nedge+1) = intbuf_tab(n)%KREMNODE_EDG(1:nedge+1)
652
653 size_inserted_edg = 1
654 max_inserted_edg = 1
655 max_inserted_i2 = 1
656 DO ii=1,nedge
657 DO j=5,6
658 nm = intbuf_tab(n)%LEDGE(j+(ii-1)*nledge)
659 IF (points_i2n(nm,1)/=0) THEN
660 max_inserted_i2 = max( max_inserted_i2,points_i2n(nm,2)-points_i2n(nm,1) )
661 DO i=points_i2n(nm,1),points_i2n(nm,2)
662 max_inserted_edg = max( max_inserted_edg,(inod2lin(nm+1)-inod2lin(nm)) )
663 ENDDO
664 ENDIF
665 ENDDO
666 ENDDO
667
668 ! We need an overstimation of the size of INSERTED_EDG, the following code
669 ! overestimate the required size, avoiding integer overflow
670 limit = huge(nedge) / 8
671 IF( nedge > limit ) THEN ! NEDGE cannot be multiplied by 8
672 size_inserted_edg = huge(nedge)
673 ELSE IF ( max_inserted_edg > limit / (nedge)) THEN ! MAX_INSERTED_EDG cannot be multiplied by 8*NEDGE
674 size_inserted_edg = huge(nedge)
675 ELSE IF (max_inserted_i2 > limit / (nedge*max_inserted_edg)) THEN ! MAX_INSERTED_I2, cannot be multiplied by 8*NEDGE*MAX_INSERTED_EDG
676 size_inserted_edg = huge(nedge)
677 ELSE ! no integer overflow
678 size_inserted_edg = 8 * nedge *max_inserted_edg *max_inserted_i2
679 ENDIF
680
681 CALL my_alloc(inserted_edg,size_inserted_edg)
682
683 DO ii=1,nedge
684 nnrem_edg_save = nnrem_edg
685C
686C Do not add nodes already stored w/IREM_GAP
687 IF(flagremnode==2)THEN
688 ki = intbuf_tab(n)%KREMNODE_EDG(ii)
689 kl = intbuf_tab(n)%KREMNODE_EDG(ii+1) -1
690 DO j=ki,kl
691 es = intbuf_tab(n)%REMNODE_EDG(j)
692 tagd_edg(es)=1
693 END DO
694 ENDIF
695C
696
697 IF(jjj + max_inserted_edg*max_inserted_i2 > size_inserted_edg) THEN
698C extend INSERTED_EDG if needed
699 oldsize = size_inserted_edg
700 size_inserted_edg = size_inserted_edg + max(nedge,max_inserted_edg*max_inserted_i2)
701 CALL my_alloc(tmp_edg,size_inserted_edg)
702 tmp_edg(1:oldsize) = inserted_edg(1:oldsize)
703! move_alloc deallocates TMP
704 CALL move_alloc(tmp_edg,inserted_edg)
705 ENDIF
706
707 nd_tag = 0
708 DO j=5,6
709 nm = intbuf_tab(n)%LEDGE(j+(ii-1)*nledge) !first node of the edge
710! Sort the I2NODE array :
711! | NSM(1) | Inter(1) | SECONDARY(1)
712! | NSM(1) | Inter(1) | SECONDARY(20)
713! | NSM(1) | Inter(1) | SECONDARY(3)
714! | NSM(1) | Inter(2) | SECONDARY(1)
715! | NSM(2) | Inter(4) | SECONDARY(14)
716! | NSM(2) | Inter(5) | SECONDARY(18)
717! | NSM(3) | Inter(1) | SECONDARY(1)
718! | ... | ... | ...
719! Compute the pointer array POINT_I2NODE :
720! | 0 | 0 | if 0,0 --> node not in type2 interface
721! | 1 | 3 |
722! | 4 | 5 |
723! | 0 | 0 |
724
725 IF (points_i2n(nm,1)/=0) THEN
726 DO i=points_i2n(nm,1),points_i2n(nm,2) ! size of the loop: number of type2 interface that have this node
727 n2 = i2node(i,2) !interface id
728 is = i2node(i,3) !node id
729 IF (is >0) THEN ! secondary node?
730 ns = intbuf_tab(n2)%NSV(is) !secondary node of the type2 interface
731 IF (((inod2lin(ns+1)-inod2lin(ns))/=0).AND.(tag_nde(ns)==0)) THEN ! What is NOD2LIN?
732 tag_nde(ns)=1 !thag the node for the first time it found (in what?) Nodes of type2 interface?
733 DO ie=inod2lin(ns),inod2lin(ns+1)-1 !for all edges in what?
734 iedgs = nod2lin(ie) ! IEDGES = all the edges that have NS as node?
735 IF (tagd_edg(iedgs)==0) THEN ! if not already tagged
736 nnrem_edg = nnrem_edg + 1
737 tagd_edg(iedgs)=1
738 jjj = jjj + 1
739 inserted_edg(jjj) = iedgs ! IEDG inserted
740 nes = intbuf_tab(n)%LEDGE(5+(iedgs-1)*nledge)
741 tag_nd(nes) = tag_nd(nes) +1 !Nodes of type25 Edge
742 nd_tag = nd_tag + 1
743 idx_nd( nd_tag)=nes
744 nes = intbuf_tab(n)%LEDGE(6+(iedgs-1)*nledge)
745 tag_nd(nes) = tag_nd(nes) +1
746 nd_tag = nd_tag +1
747 idx_nd( nd_tag)=nes
748 END IF
749 ENDDO
750 ENDIF
751 ELSEIF (is <0) THEN ! node is main?
752 iis = -is
753 l = intbuf_tab(n2)%IRTLM(iis)
754 nnod_2 = 4
755 ! If triangle, NNOD_2 = 3, if quand NNOD_2 = 4
756 IF( intbuf_tab(n2)%IRECTM(4*(l-1)+4)==intbuf_tab(n2)%IRECTM(4*(l-1)+3) ) nnod_2 = 3
757 DO iii = 1,nnod_2 ! for all nodes of the surface
758 nm2 = intbuf_tab(n2)%IRECTM(4*(l-1)+iii) ! NM2 is the id of the IIIth node of the surface
759 IF (((inod2lin(nm2+1)-inod2lin(nm2))/=0).AND.(tag_nde(nm2)==0)) THEN
760 tag_nde(nm2)=1
761 DO ie=inod2lin(nm2),inod2lin(nm2+1)-1
762 iedgs = nod2lin(ie) ! edge id to remove
763 IF (tagd_edg(iedgs)==0) THEN !if not already removed
764 nnrem_edg = nnrem_edg + 1
765 tagd_edg(iedgs)=1 !remove
766 jjj = jjj + 1 !increment the counter
767 inserted_edg(jjj) = iedgs
768 nes = intbuf_tab(n)%LEDGE(5+(iedgs-1)*nledge) ! Node 1 of the edge IEDGS
769 tag_nd(nes) = tag_nd(nes) +1 !TAG_ND(NES) = number of times that the node NES belongs to a removed edge?
770 nd_tag = nd_tag +1 !nb entity to insert to node NM2
771 idx_nd( nd_tag)=nes
772 nes = intbuf_tab(n)%LEDGE(6+(iedgs-1)*nledge) !Node 2 of the edge IEDGS
773 tag_nd(nes) = tag_nd(nes) +1
774 nd_tag = nd_tag +1
775 idx_nd( nd_tag)=nes
776 END IF
777 ENDDO
778 ENDIF
779 ENDDO
780 END IF
781 ENDDO
782 ENDIF
783 END DO !
784
785 ! -------------------
786 ! Adding edges where 2 nodes already tagged
787 ! Two nodes of what? type25 or type2, which tag?
788
789 DO nd = 1,nd_tag
790 nes = idx_nd( nd)
791 IF(tag_nd(nes) ==1)THEN ! to double check, why ==1 and not > 0 ? if the nodes belongs exactly to one removed edge?
792 IF ((inod2lin(nes+1)-inod2lin(nes))/=0) THEN
793 DO ie=inod2lin(nes),inod2lin(nes+1)-1 ! all the edges to remove that have node NES?
794 iedgs = nod2lin(ie)
795 DO j=5,6
796 nm =intbuf_tab(n)%LEDGE(j+(iedgs-1)*nledge)
797 !to double check, why ==1 and not > 0 ?
798 IF(tag_nd(nm)==1.AND.tagd_edg(iedgs) ==0) THEN ! if the node NM, but the edge was not taged
799 nnrem_edg = nnrem_edg + 1
800 tagd_edg(iedgs)=1
801 jjj = jjj + 1
802 inserted_edg(jjj) = iedgs
803 ENDIF
804 ENDDO
805 ENDDO
806 ENDIF
807 ENDIF
808 ENDDO
809
810
811 ! -------------------
812 ! number of inserted edges
813 nbr_insert_ii(ii) = nnrem_edg - nnrem_edg_save
814 kremnode_edg_save(ii) = kremnode_edg_save(ii+1) - kremnode_edg_save(ii)
815 iada = iada + kremnode_edg_save(ii)
816 ! adress of the first inserted node
817 adress_ii(ii) = iada
818 kremnode_edg_save(ii) = iada + nbr_insert_ii(ii) - 1
819 iada = iada + nbr_insert_ii(ii)
820 ! -------------------
821
822C-----reset TAGD_EDG=0
823
824 DO nd = 1,nd_tag
825 nes = idx_nd( nd)
826 IF(tag_nd(nes) ==1)THEN
827 IF ((inod2lin(nes+1)-inod2lin(nes))/=0) THEN
828 DO ie=inod2lin(nes),inod2lin(nes+1)-1
829 iedgs = nod2lin(ie)
830 DO j=5,6
831 nm =intbuf_tab(n)%LEDGE(j+(iedgs-1)*nledge)
832 IF(tagd_edg(iedgs) ==1) tagd_edg(iedgs)=0
833 ENDDO
834 ENDDO
835 ENDIF
836 ENDIF
837 ENDDO
838 DO j=5,6
839 nm = intbuf_tab(n)%LEDGE(j+(ii-1)*nledge)
840 IF (points_i2n(nm,1)/=0) THEN
841 DO i=points_i2n(nm,1),points_i2n(nm,2)
842 n2 = i2node(i,2)
843 is = i2node(i,3)
844 IF (is >0) THEN
845 ns = intbuf_tab(n2)%NSV(is)
846 IF (((inod2lin(ns+1)-inod2lin(ns))/=0).AND.(tag_nde(ns)==1)) THEN
847 tag_nde(ns)=0
848 DO ie=inod2lin(ns),inod2lin(ns+1)-1
849 iedgs = nod2lin(ie)
850 IF (tagd_edg(iedgs)==1) THEN
851 tagd_edg(iedgs)=0
852 nes = intbuf_tab(n)%LEDGE(5+(iedgs-1)*nledge)
853 tag_nd(nes) = 0
854 nes = intbuf_tab(n)%LEDGE(6+(iedgs-1)*nledge)
855 tag_nd(nes) = 0
856 ENDIF
857 ENDDO
858 ENDIF
859 ELSEIF (is <0) THEN
860 iis = -is
861 l = intbuf_tab(n2)%IRTLM(iis)
862 nnod_2 = 4
863 IF( intbuf_tab(n2)%IRECTM(4*(l-1)+4)==intbuf_tab(n2)%IRECTM(4*(l-1)+3) ) nnod_2 = 3
864 DO iii = 1,nnod_2
865 nm2 = intbuf_tab(n2)%IRECTM(4*(l-1)+iii)
866 IF ((inod2lin(nm2+1)-inod2lin(nm2))/=0.AND.(tag_nde(nm2)==1)) THEN
867 tag_nde(nm2)=0
868 DO ie=inod2lin(nm2),inod2lin(nm2+1)-1
869 iedgs = nod2lin(ie)
870 IF (tagd_edg(iedgs)==1) THEN
871 tagd_edg(iedgs)=0
872 nes = intbuf_tab(n)%LEDGE(5+(iedgs-1)*nledge)
873 tag_nd(nes) = 0
874 nes = intbuf_tab(n)%LEDGE(6+(iedgs-1)*nledge)
875 tag_nd(nes) = 0
876 ENDIF
877 ENDDO
878 ENDIF
879 ENDDO
880 END IF
881 END DO
882 ENDIF
883 ENDDO
884
885 IF(flagremnode==2)THEN
886 DO ie=ki,kl
887 iedgs = intbuf_tab(n)%REMNODE_EDG(ie)
888 tagd_edg(iedgs)=0
889 END DO
890 END IF
891C
892 END DO !II=1,NEDGE
893
894 IF(nnrem_edg>0) THEN
895
896 ! get the first and the last inserted node
897 first = 0
898 last = 0
899 DO ii = 1,nedge
900 IF(first==0) THEN
901 IF( nbr_insert_ii(ii)/=0 ) first = ii
902 ENDIF
903 IF(last==0) THEN
904 IF( nbr_insert_ii(nedge+1-ii)/=0 ) last = nedge+1-ii
905 ENDIF
906 ENDDO
907 ! count the total number of inserted edges
908 total_inserted = 0
909 DO ii=1,nedge
910 total_inserted = total_inserted + nbr_insert_ii(ii)
911 ENDDO
912 ! allocate the buffer array
913 ALLOCATE( remnode_edg(nremov_edg+total_inserted) )
914
915 j = 0
916 i = 0
917 offset = 0
918 IF( first>0 ) THEN
919 ! insertion of the first chunk of edge : if ADRESS_II(FIRST) > 1
920 ! --> need to copy the old edges
921 IF( adress_ii(first)>1 ) THEN
922 remnode_edg(1:adress_ii(first)-1) = intbuf_tab(n)%REMNODE_EDG(1:adress_ii(first)-1)
923 offset = offset + adress_ii(first)-1
924 i = i + adress_ii(first)-1
925 ENDIF
926
927 DO ii=first,last
928 ! insertion of the edges
929 IF( nbr_insert_ii(ii)>0 ) THEN
930 DO jj = 1,nbr_insert_ii(ii)
931 j = j + 1
932 remnode_edg(offset+nbr_insert_ii(ii)+1-jj) = inserted_edg(j)
933 ENDDO
934 offset = offset + nbr_insert_ii(ii)
935 ENDIF
936 IF(ii<last.AND.nremov_edg>0) THEN
937 ! copy of the old edges
938 nbr_intra = adress_ii(ii+1) - adress_ii(ii)-nbr_insert_ii(ii)
939 IF( nbr_intra>0 )THEN
940 DO jj = 1,nbr_intra
941 i = i + 1
942 remnode_edg(jj+offset) = intbuf_tab(n)%REMNODE_EDG(i)
943 ENDDO
944 offset = offset + nbr_intra
945 ENDIF
946 ENDIF
947 ENDDO
948 ENDIF
949
950 ! copy of the old edges for the LAST chunk
951 IF( i<nremov_edg ) THEN
952 nbr_extra = nremov_edg - i
953 remnode_edg(offset+1:offset+nbr_extra) = intbuf_tab(n)%REMNODE_EDG(i+1:nremov_edg)
954 ENDIF
955 ! update of NNREM_edg and deallocation / allocation of the new array
956 nnrem_edg = nnrem_edg + nremov_edg
957 CALL upgrade_remnode_edg2(ipari(1,n),nnrem_edg,intbuf_tab(n))
958 intbuf_tab(n)%REMNODE_EDG(1:nnrem_edg) = remnode_edg(1:nnrem_edg)
959 intbuf_tab(n)%KREMNODE_EDG(2:nedge+1) = kremnode_edg_save(1:nedge)
960 intbuf_tab(n)%KREMNODE_EDG(1)=0
961 DO ii=1,nedge+1
962 intbuf_tab(n)%KREMNODE_EDG(ii) =intbuf_tab(n)%KREMNODE_EDG(ii)+1
963 ENDDO
964 ! ---------
965 IF(flag_output>0) THEN
966 ! Output message
967 CALL ancmsg(msgid=2067,
968 . msgtype=msgwarning,
969 . anmode=aninfo_blind_1,
970 . i1=id,
971 . c1=titr,
972 . i2=nnrem_edg)
973 ENDIF
974 ! ---------
975C----------used for Iedge=1
976 nremov_edg = nnrem_edg
977 END IF !IF (NNREM_EDG>0) THEN
978 IF(ALLOCATED(remnode_edg)) DEALLOCATE( remnode_edg )
979 IF(ALLOCATED(inserted_edg)) DEALLOCATE( inserted_edg )
980
981 ! ------------------------------------------------
982
983 DEALLOCATE( nbr_insert_ii )
984 DEALLOCATE( adress_ii )
985 DEALLOCATE( kremnode_edg_save )
986
987 DEALLOCATE(tagd_edg,tag_nd,idx_nd,tag_nde)
988
989 ENDIF ! SHELL_EDG
990
991 DEALLOCATE(inod2lin,nod2lin)
992C----
993 RETURN
id
initmumps id
Definition multiplerhs_example.m:4
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
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:889
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
upgrade_remnode_edg2
subroutine upgrade_remnode_edg2(ipari, nremnode, intbuf_tab)
Definition upgrade_remnode.F:280
upgrade_remnode_e2s
subroutine upgrade_remnode_e2s(ipari, nremnode, intbuf_tab)
Definition upgrade_remnode.F:347