OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i7remnode.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| i7remnode ../starter/source/interfaces/inter3d1/i7remnode.F
25!||--- called by ------------------------------------------------------
26!|| inint3 ../starter/source/interfaces/inter3d1/inint3.f
27!||--- calls -----------------------------------------------------
28!|| get_list_remnode ../starter/source/interfaces/inter3d1/get_list_remnode.F90
29!|| i25remnor ../starter/source/interfaces/inter3d1/i7remnode.F
30!|| i7remnode_init ../starter/source/interfaces/inter3d1/i7remnode.F
31!||--- uses -----------------------------------------------------
32!|| get_list_remnode_mod ../starter/source/interfaces/inter3d1/get_list_remnode.F90
33!|| message_mod ../starter/share/message_module/message_mod.F
34!||====================================================================
35 SUBROUTINE i7remnode(
36 1 IREMNODE,NOINT ,TITR ,INTBUF_TAB ,NUMNOD ,
37 1 X ,NRTM ,IRECT ,NSV ,NSN ,
38 2 ITAB ,GAP_S ,GAP_M ,GAPMIN ,GAPMAX ,
39 3 GAP_S_L ,GAP_M_L ,IGAP ,GAP ,DRAD ,
40 4 NREMNODE,NTY ,IPARI ,I_MEM_REM ,GAPM_MX ,
41 5 GAPS_MX ,GAPM_L_MX,GAPS_L_MX ,ILEV ,NBINFLG ,
42 6 MBINFLG ,DGAPLOAD,npari)
43C-----------------------------------------------
44C M o d u l e s
45C-----------------------------------------------
46 USE my_alloc_mod
47 USE message_mod
48 USE intbufdef_mod
49 USE names_and_titles_mod , ONLY : nchartitle
50 use get_list_remnode_mod , only : get_list_remnode
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
54#include "implicit_f.inc"
55C-----------------------------------------------
56C C o m m o n B l o c k s
57C-----------------------------------------------
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 integer, intent(in) :: npari !< dim of IPARI
62 INTEGER IREMNODE, NOINT, NSN, NRTM, NUMNOD,IGAP, NREMNODE ,NTY, I_MEM_REM, ILEV
63 INTEGER IRECT(4,NRTM),ITAB(*),NSV(NSN),IPARI(*),NBINFLG(*),MBINFLG(*)
64 my_real
65 . GAPMIN, GAPMAX, GAP, DRAD, GAPM_MX, GAPS_MX, GAPM_L_MX, GAPS_L_MX
66 my_real , INTENT(IN) :: DGAPLOAD
67 my_real
68 . x(3,*),gap_s(*),gap_m(*),gap_s_l(*),gap_m_l(*)
69 TYPE(intbuf_struct_) INTBUF_TAB
70 CHARACTER(LEN=NCHARTITLE) :: TITR
71C-----------------------------------------------
72C L o c a l V a r i a b l e s
73C-----------------------------------------------
74 INTEGER I,IFIRST,ILAST,ISELF_IMPACTANT
75 INTEGER, DIMENSION(:),ALLOCATABLE ::
76 . knod2seg,nod2seg,noddel,tagnod,id_nod,tagsecnd,itagseg,nod2expand
77 my_real
78 . minseg
79 my_real, DIMENSION(:),ALLOCATABLE ::
80 . dist1,gapv,gapsecnd,gap_s_l_tmp
81C-----------------------------------------------
82C
83 ALLOCATE(knod2seg(numnod+1),nod2seg(4*nrtm),noddel(numnod),
84 . tagnod(numnod),id_nod(numnod),nod2expand(numnod),itagseg(nrtm))
85 ALLOCATE(dist1(numnod),gapv(numnod),tagsecnd(numnod),
86 . gapsecnd(numnod),gap_s_l_tmp(numnod))
87C
88 knod2seg(1:numnod+1) = 0
89 tagsecnd(1:numnod) = 0
90 id_nod(1:numnod) = 0
91 noddel(1:numnod) = 0
92 tagnod(1:numnod) = 0
93 nod2expand(1:numnod) = 0
94 nod2seg(1:4*nrtm) = 0
95 itagseg(1:nrtm) = 0
96 gapv(1:numnod) = zero
97 gapsecnd(1:numnod) = zero
98 dist1(1:numnod) = ep30
99C
100C-----------------------------------------------
101 CALL i7remnode_init(iself_impactant,nty ,
102 1 x ,nrtm ,irect ,nsv ,nsn ,numnod ,
103 2 itab ,gap_s ,gap_m ,gapmin ,gapmax ,
104 3 gap_s_l ,gap_m_l ,igap ,intbuf_tab%KREMNODE,intbuf_tab%REMNODE ,
105 4 gap ,drad ,nremnode ,ilev ,nbinflg ,
106 5 mbinflg ,ipari ,i_mem_rem,gapm_mx ,gaps_mx ,
107 6 gapm_l_mx ,gaps_l_mx ,knod2seg,nod2seg,tagsecnd,
108 7 gapsecnd ,gap_s_l_tmp,minseg )
109C
110 IF(iself_impactant==0) RETURN
111C
112C-----------------------------------------------
113 ifirst=1
114 ilast =nrtm
115 i_mem_rem=1
116 intbuf_tab%kremnode(1) = 0
117!$OMP PARALLEL
118 call get_list_remnode(nrtm,igap ,numnod,npari,irect,intbuf_tab%kremnode,
119 . knod2seg,nod2seg,tagsecnd,
120 . ipari,gapmin,gapmax,gap,drad,
121 . gaps_mx,gaps_l_mx,
122 . minseg,dgapload,x,gap_m,
123 . gap_m_l,gapsecnd,gap_s_l_tmp,
124 . intbuf_tab)
125!$OMP END PARALLEL
126 iremnode = iremnode + 1
127C-----------------------------------------------
128 IF(nty==25)THEN
129 CALL i25remnor(nrtm ,irect ,nsv ,nsn ,numnod ,
130 2 intbuf_tab%KREMNODE,intbuf_tab%REMNODE ,intbuf_tab%KREMNOR ,
131 . intbuf_tab%REMNOR ,ipari ,
132 3 tagsecnd )
133 END IF
134C-----------------------------------------------
135 DEALLOCATE(knod2seg,nod2seg,noddel,id_nod,tagnod,itagseg)
136 DEALLOCATE(dist1,gapv,tagsecnd,gapsecnd,gap_s_l_tmp)
137C-----------------------------------------------
138 RETURN
139 END
140!||====================================================================
141!|| i7remnode_init ../starter/source/interfaces/inter3d1/i7remnode.F
142!||--- called by ------------------------------------------------------
143!|| i7remnode ../starter/source/interfaces/inter3d1/i7remnode.F
144!||--- calls -----------------------------------------------------
145!|| bitget ../starter/source/interfaces/inter3d1/bitget.F
146!||====================================================================
147 SUBROUTINE i7remnode_init(ISELF_IMPACTANT,NTY ,
148 1 X ,NRTM ,IRECT ,NSV ,NSN ,NUMNOD ,
149 2 ITAB ,GAP_S ,GAP_M ,GAPMIN ,GAPMAX ,
150 3 GAP_S_L ,GAP_M_L ,IGAP ,KREMNODE,REMNODE ,
151 4 GAP ,DRAD ,NREMNODE ,ILEV ,NBINFLG ,
152 5 MBINFLG ,IPARI ,I_MEM_REM,GAPM_MX ,GAPS_MX ,
153 6 GAPM_L_MX ,GAPS_L_MX ,KNOD2SEG,NOD2SEG,TAGSECND,
154 7 GAPSECND ,GAP_S_L_TMP,MINSEG )
155C-----------------------------------------------
156C I m p l i c i t T y p e s
157C-----------------------------------------------
158#include "implicit_f.inc"
159C-----------------------------------------------
160C D u m m y A r g u m e n t s
161C-----------------------------------------------
162 INTEGER ISELF_IMPACTANT, NTY, NSN, NRTM, NUMNOD,IGAP, NREMNODE , I_MEM_REM, ILEV
163 INTEGER IRECT(4,*),ITAB(*),NSV(*),KREMNODE(*),REMNODE(*),
164 . IPARI(*),KNOD2SEG(*),NOD2SEG(4*NRTM),TAGSECND(*),NBINFLG(*),MBINFLG(*)
165 my_real
166 . GAPMIN, GAPMAX, GAP, DRAD, GAPM_MX, GAPS_MX, GAPM_L_MX, GAPS_L_MX, MINSEG
167 my_real
168 . X(3,*),GAP_S(*),GAP_M(*),GAP_S_L(*),GAP_M_L(*), GAPSECND(*), GAP_S_L_TMP(*)
169C-----------------------------------------------
170C L o c a l V a r i a b l e s
171C-----------------------------------------------
172 INTEGER I,J,K,L,N,CPT,KMAX,IMS1,IMS2,ISS1,ISS2
173 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGNOD
174C-----------------------------------------------
175 INTEGER BITGET
176 EXTERNAL bitget
177C-----------------------------------------------
178c Build inverse connectivity for segments
179C-----------------------------------------------
180C
181C NOD2SEG(1:4*NRTM) = 0
182C KNOD2SEG(1:NUMNOD+1) = 0
183C TAGSECND(1:NUMNOD) = 0
184C GAPSECND(1:NUMNOD) = ZERO
185C
186C
187 DO i=1,nsn
188 tagsecnd(nsv(i)) = i
189 ENDDO
190C
191 minseg = ep30
192C
193 iself_impactant = 0
194 IF(nty /= 25 .OR. (nty == 25 .AND. ilev /=2))THEN
195 DO i=1,nrtm
196 DO j=1,4
197 IF( tagsecnd(irect(j,i)) /= 0 ) THEN
198 iself_impactant = 1
199 END IF
200 ENDDO
201 END DO
202 ELSE ! NTY == 25 and S1-S2
203 DO i=1,nrtm
204 DO j=1,4
205 n = tagsecnd(irect(j,i))
206 IF( n /= 0 ) THEN
207 ims1 = bitget(mbinflg(i),0)
208 ims2 = bitget(mbinflg(i),1)
209 iss1 = bitget(nbinflg(n),0)
210 iss2 = bitget(nbinflg(n),1)
211 IF(((ims1 == 1 .and. iss2==1).or.
212 . (ims2 == 1 .and. iss1==1)))THEN
213 iself_impactant = 1
214 END IF
215 END IF
216 ENDDO
217 END DO
218 END IF
219C
220 IF (iself_impactant == 0) RETURN
221C
222 DO i=1,nrtm
223 IF( irect(3,i) /= irect(4,i) ) THEN
224
225 minseg = min( minseg,
226 . (x(1,irect(1,i))-x(1,irect(2,i)))**2 +
227 . (x(2,irect(1,i))-x(2,irect(2,i)))**2 +
228 . (x(3,irect(1,i))-x(3,irect(2,i)))**2 ,
229 . (x(1,irect(2,i))-x(1,irect(3,i)))**2 +
230 . (x(2,irect(2,i))-x(2,irect(3,i)))**2 +
231 . (x(3,irect(2,i))-x(3,irect(3,i)))**2 ,
232 . (x(1,irect(3,i))-x(1,irect(4,i)))**2 +
233 . (x(2,irect(3,i))-x(2,irect(4,i)))**2 +
234 . (x(3,irect(3,i))-x(3,irect(4,i)))**2 ,
235 . (x(1,irect(4,i))-x(1,irect(1,i)))**2 +
236 . (x(2,irect(4,i))-x(2,irect(1,i)))**2 +
237 . (x(3,irect(4,i))-x(3,irect(1,i)))**2 )
238 ELSEIF( irect(3,i) == irect(4,i) )THEN
239
240 minseg = min( minseg,
241 . (x(1,irect(1,i))-x(1,irect(2,i)))**2 +
242 . (x(2,irect(1,i))-x(2,irect(2,i)))**2 +
243 . (x(3,irect(1,i))-x(3,irect(2,i)))**2 ,
244 . (x(1,irect(2,i))-x(1,irect(3,i)))**2 +
245 . (x(2,irect(2,i))-x(2,irect(3,i)))**2 +
246 . (x(3,irect(2,i))-x(3,irect(3,i)))**2 ,
247 . (x(1,irect(3,i))-x(1,irect(1,i)))**2 +
248 . (x(2,irect(3,i))-x(2,irect(1,i)))**2 +
249 . (x(3,irect(3,i))-x(3,irect(1,i)))**2 )
250
251 ENDIF
252 ENDDO
253 minseg = sqrt(minseg)
254C
255 DO i=1,nrtm
256 cpt = 0
257 kmax = 4
258 IF(irect(kmax,i) == 0 .OR.
259 . irect(3,i) == irect(4,i) ) kmax = 3
260 DO k=1,kmax
261 IF(tagsecnd(irect(k,i)) /= 0) cpt = cpt + 1
262 END DO
263 IF (cpt /= 0 ) THEN
264 DO k=1,kmax
265 n = irect(k,i)
266 knod2seg(n) = knod2seg(n) + 1
267 END DO
268 ENDIF
269 END DO
270C
271 DO i=1,numnod
272 knod2seg(i+1) = knod2seg(i+1) + knod2seg(i)
273 END DO
274C
275 DO n=numnod,1,-1
276 knod2seg(n+1)=knod2seg(n)
277 END DO
278 knod2seg(1)=0
279C
280 DO i=1,nrtm
281 kmax = 4
282 cpt = 0
283 IF(irect(kmax,i) == 0 .OR.
284 . irect(3,i) == irect(4,i) ) kmax = 3
285 DO k=1,kmax
286 IF(tagsecnd(irect(k,i)) /= 0) cpt = cpt + 1
287 END DO
288 IF (cpt /= 0) THEN
289 DO k=1,kmax
290 n = irect(k,i)
291 knod2seg(n) = knod2seg(n) + 1
292 nod2seg(knod2seg(n)) = i
293 END DO
294 ENDIF
295 END DO
296C
297 DO n=numnod,1,-1
298 knod2seg(n+1)=knod2seg(n)
299 END DO
300 knod2seg(1)=0
301C-----------------------------------------------
302C Searching Algorithm Connected nodes : D < SQRT(2.) * GAP
303C-----------------------------------------------
304 IF(igap >= 1)THEN
305 DO i=1,nsn
306 gapsecnd(nsv(i)) = gap_s(i)
307 ENDDO
308 ENDIF
309C-----------------------------------------------
310 IF(igap==3)THEN
311 DO i=1,nsn
312 gap_s_l_tmp(nsv(i)) = gap_s_l(i)
313 ENDDO
314 END IF
315C-----------------------------------------------
316 RETURN
317 END
318!||====================================================================
319!|| i25remnor ../starter/source/interfaces/inter3d1/i7remnode.F
320!||--- called by ------------------------------------------------------
321!|| i7remnode ../starter/source/interfaces/inter3d1/i7remnode.F
322!||====================================================================
323 SUBROUTINE i25remnor(
324 1 NRTM ,IRECT ,NSV ,NSN ,NUMNOD ,
325 2 KREMNODE,REMNODE ,KREMNOR ,REMNOR ,IPARI ,
326 3 TAGSECND )
327C-----------------------------------------------
328C I m p l i c i t T y p e s
329C-----------------------------------------------
330#include "implicit_f.inc"
331C-----------------------------------------------
332C D u m m y A r g u m e n t s
333C-----------------------------------------------
334 INTEGER NSN, NRTM, NUMNOD
335 INTEGER IRECT(4,*),NSV(*),KREMNODE(*),REMNODE(*),
336 . KREMNOR(*),REMNOR(*),IPARI(*),TAGSECND(*)
337C-----------------------------------------------
338C L o c a l V a r i a b l e s
339C-----------------------------------------------
340 INTEGER I,J,K,L,N,NS,LREMNORMAX
341C-----------------------------------------------
342c T25 :: Build inverse connectivity for vertices
343C-----------------------------------------------
344C
345 DO I=1,nrtm
346 k = kremnode(i)+1
347 l = kremnode(i+1)
348 DO j=k,l
349 ns = tagsecnd(remnode(j))
350 kremnor(ns) = kremnor(ns)+1
351 ENDDO
352 ENDDO
353C
354 DO n=1,nsn
355 kremnor(n+1) = kremnor(n+1) + kremnor(n)
356 END DO
357C
358 DO n=nsn,1,-1
359 kremnor(n+1)=kremnor(n)
360 END DO
361 kremnor(1)=0
362C
363 DO i=1,nrtm
364 k = kremnode(i)+1
365 l = kremnode(i+1)
366 DO j=k,l
367 n = tagsecnd(remnode(j))
368 kremnor(n) = kremnor(n)+1
369 remnor(kremnor(n)) = i
370 ENDDO
371 ENDDO
372C
373 DO n=nsn,1,-1
374 kremnor(n+1)=kremnor(n)
375 END DO
376 kremnor(1)=0
377C
378C----- Compute maximum number of MAIN segments banned for all SECONDARY nodes---
379 lremnormax = 0
380 DO n=1,nsn
381 l = kremnor(n+1)-kremnor(n)
382 IF( l>lremnormax) THEN
383 lremnormax = l
384 ENDIF
385 ENDDO
386 ipari(82) = lremnormax
387
388 RETURN
389 END
390!||====================================================================
391!|| insert_a ../starter/source/interfaces/inter3d1/i7remnode.F
392!||--- called by ------------------------------------------------------
393!|| add_nsfic ../starter/source/interfaces/inter3d1/i7remnode.F
394!||====================================================================
395 SUBROUTINE insert_a(N,IC,IA,ID)
396C----6---------------------------------------------------------------7---------8
397C I m p l i c i t T y p e s
398C-----------------------------------------------
399#include "implicit_f.inc"
400C-----------------------------------------------------------------
401C D u m m y A r g u m e n t s
402C-----------------------------------------------
403 INTEGER N ,IC(*),ID,IA
404C-----------------------------------------------
405C L o c a l V a r i a b l e s
406C-----------------------------------------------
407 INTEGER I,IT,IC_CP
408C
409C----add IA--at IC(ID)--------------------------
410 IF (ID > N+1 ) RETURN
411 DO I =n+1,id+1,-1
412 ic(i) = ic(i-1)
413 ENDDO
414 ic(id)=ia
415 n = n + 1
416C----6---------------------------------------------------------------7---------8
417 RETURN
418 END
419!||====================================================================
420!|| remn_i2_edg ../starter/source/interfaces/inter3d1/i7remnode.F
421!||--- calls -----------------------------------------------------
422!|| add_nsfic ../starter/source/interfaces/inter3d1/i7remnode.F
423!|| dim_iedgn2 ../starter/source/interfaces/inter3d1/i7remnode.F
424!|| ind_iedgn2 ../starter/source/interfaces/inter3d1/i7remnode.F
425!||--- uses -----------------------------------------------------
426!||====================================================================
427 SUBROUTINE remn_i2_edg(IPARI ,INTBUF_TAB ,ITAB, NREMOV,IFLAG )
428C-----------------------------------------------
429C M o d u l e s
430C-----------------------------------------------
431 USE my_alloc_mod
432 USE intbufdef_mod
433C-----------------------------------------------
434C I m p l i c i t T y p e s
435C-----------------------------------------------
436#include "implicit_f.inc"
437C-----------------------------------------------
438C A n a l y s e M o d u l e
439C-----------------------------------------------
440#include "param_c.inc"
441C-----------------------------------------------
442C D u m m y A r g u m e n t s
443C-----------------------------------------------
444 INTEGER IPARI(NPARI,*), ITAB(*),NREMOV(*),IFLAG
445
446 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
447C-----------------------------------------------
448C C o m m o n B l o c k s
449C-----------------------------------------------
450#include "com04_c.inc"
451C-----------------------------------------------
452C L o c a l V a r i a b l e s
453C-----------------------------------------------
454 INTEGER N,NTY,NN,NE2,IE,IE1,IE2,I,NNREM
455 INTEGER II,J,NMN,NSN,NRTS,NRTM,IADA,IEDGE,NSNE,NRTSE
456 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGN
457 INTEGER, DIMENSION(:,:),ALLOCATABLE :: IEDGN2
458C-----------------------------------------------
459C----like Irem_gap of int7, creat list of SECONDARY nodes to be removed per M_seg
460C---------IFLAG=0 : DIM
461 ALLOCATE(tagn(numnod))
462C-----
463 DO n=1,ninter
464 nty=ipari(7,n)
465 nsn =ipari(5,n)
466 nrtm =ipari(4,n)
467 iedge =ipari(59,n)
468 IF (iflag==0) nremov(n) = ipari(62,n)
469 nrtse = ipari(52,n)
470 IF (nremov(n) ==0.OR.iedge==0) cycle
471 nsne = ipari(55,n)
472 tagn(1:numnod)=0
473 DO j=1,intbuf_tab(n)%KREMNODE(nrtm+1)
474 nn = intbuf_tab(n)%REMNODE(j)
475 tagn(nn)=1
476 END DO
477 CALL dim_iedgn2(ne2,nsne,intbuf_tab(n)%IS2SE,intbuf_tab(n)%IRTSE,tagn)
478 IF (ne2==0) cycle
479 ALLOCATE(iedgn2(3,ne2))
480 CALL ind_iedgn2(ne2,nsne,intbuf_tab(n)%IS2SE,intbuf_tab(n)%IRTSE,tagn,iedgn2)
481 CALL add_nsfic(ne2,nrtm,nsne,intbuf_tab(n)%IS2SE,nremov(n),
482 + intbuf_tab(n)%KREMNODE,intbuf_tab(n)%REMNODE,iedgn2,iflag)
483 DEALLOCATE(iedgn2)
484 END DO
485 DEALLOCATE(tagn)
486C----
487 RETURN
488 END
489!||====================================================================
490!|| dim_iedgn2 ../starter/source/interfaces/inter3d1/i7remnode.F
491!||--- called by ------------------------------------------------------
492!|| remn_i2_edg ../starter/source/interfaces/inter3d1/i7remnode.F
493!||====================================================================
494 SUBROUTINE dim_iedgn2(NE2,NSNE,IS2SE,IRTSE,TAGN)
495C----6---------------------------------------------------------------7---------8
496C I m p l i c i t T y p e s
497C-----------------------------------------------
498#include "implicit_f.inc"
499C-----------------------------------------------------------------
500C D u m m y A r g u m e n t s
501C-----------------------------------------------
502 INTEGER NE2,NSNE,IS2SE(2,*),IRTSE(5,*),TAGN(*)
503C-----------------------------------------------
504C L o c a l V a r i a b l e s
505C-----------------------------------------------
506 INTEGER IK1(4),IK2(4),NS1,NS2,IED,I,J,IE1,IE2,IE
507 DATA IK1 /1,2,3,4/
508 DATA IK2 /2,3,4,1/
509C-----
510 NE2 =0
511 DO i=1,nsne
512 ie1 = is2se(1,i)
513 ie2 = is2se(2,i)
514 IF (ie1 > 0) THEN
515 ie = ie1
516 ied=irtse(5,ie)
517 ns1= irtse(ik1(ied),ie)
518 ns2= irtse(ik2(ied),ie)
519 ELSEIF(ie2 > 0) THEN
520 ie = ie2
521 ied=irtse(5,ie)
522 ns1= irtse(ik2(ied),ie)
523 ns2= irtse(ik1(ied),ie)
524 ELSE
525 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
526 END IF
527 IF (tagn(ns1)>0.AND.tagn(ns2)>0) ne2 = ne2 + 1
528 END DO ! I=1,NSNE
529C----6---------------------------------------------------------------7---------8
530 RETURN
531 END
532!||====================================================================
533!|| ind_iedgn2 ../starter/source/interfaces/inter3d1/i7remnode.F
534!||--- called by ------------------------------------------------------
535!|| remn_i2_edg ../starter/source/interfaces/inter3d1/i7remnode.F
536!||====================================================================
537 SUBROUTINE ind_iedgn2(NE2,NSNE,IS2SE,IRTSE,TAGN,IEDGN2)
538C----6---------------------------------------------------------------7---------8
539C I m p l i c i t T y p e s
540C-----------------------------------------------
541#include "implicit_f.inc"
542C-----------------------------------------------------------------
543C D u m m y A r g u m e n t s
544C-----------------------------------------------
545 INTEGER NE2,NSNE,IS2SE(2,*),IRTSE(5,*),TAGN(*),IEDGN2(3,*)
546C-----------------------------------------------
547C L o c a l V a r i a b l e s
548C-----------------------------------------------
549 INTEGER IK1(4),IK2(4),NS1,NS2,IED,I,J,IE1,IE2,IE
550 DATA IK1 /1,2,3,4/
551 DATA IK2 /2,3,4,1/
552C-----
553 NE2 =0
554 DO i=1,nsne
555 ie1 = is2se(1,i)
556 ie2 = is2se(2,i)
557 IF (ie1 > 0) THEN
558 ie = ie1
559 ied=irtse(5,ie)
560 ns1= irtse(ik1(ied),ie)
561 ns2= irtse(ik2(ied),ie)
562 ELSEIF(ie2 > 0) THEN
563 ie = ie2
564 ied=irtse(5,ie)
565 ns1= irtse(ik2(ied),ie)
566 ns2= irtse(ik1(ied),ie)
567 ELSE
568 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
569 END IF
570 IF (tagn(ns1)>0.AND.tagn(ns2)>0) THEN
571 ne2 = ne2 + 1
572 iedgn2(1,ne2) = ns1
573 iedgn2(2,ne2) = ns2
574 iedgn2(3,ne2) = i
575 END IF
576 END DO ! I=1,NSNE
577C----6---------------------------------------------------------------7---------8
578 RETURN
579 END
580!||====================================================================
581!|| add_nsfic ../starter/source/interfaces/inter3d1/i7remnode.F
582!||--- called by ------------------------------------------------------
583!|| remn_i2_edg ../starter/source/interfaces/inter3d1/i7remnode.F
584!||--- calls -----------------------------------------------------
585!|| insert_a ../starter/source/interfaces/inter3d1/i7remnode.F
586!|| intab ../starter/source/interfaces/inter3d1/i24tools.F
587!||====================================================================
588 SUBROUTINE add_nsfic(NE2,NRTM,NSNE,IS2SE,NREMOV,KREMNODE,
589 + REMNODE,IEDGN2,IFLAG)
590C----6---------------------------------------------------------------7---------8
591C I m p l i c i t T y p e s
592C-----------------------------------------------
593#include "implicit_f.inc"
594C-----------------------------------------------------------------
595C D u m m y A r g u m e n t s
596C-----------------------------------------------
597 INTEGER NRTM,NSNE,IS2SE(2,*),NREMOV,KREMNODE(*),REMNODE(*),
598 + IEDGN2(3,*),IFLAG,NE2
599C-----------------------------------------------
600C C o m m o n B l o c k s
601C-----------------------------------------------
602#include "com04_c.inc"
603C-----------------------------------------------
604C L o c a l V a r i a b l e s
605C-----------------------------------------------
606 INTEGER IE,IE1,IE2,I,NNREM,NN,KREMOV_OLD
607 INTEGER NS1,NS2,IED,J,II,IADA,NS,NEW,NR0,IADN
608C-----------------------------------------------
609C External function
610C-----------------------------------------------
611 LOGICAL INTAB
612 EXTERNAL INTAB
613C-----
614 IF (IFLAG==0) then
615 DO ii=1,nrtm
616 IF (kremnode(ii+1)>kremnode(ii)) THEN
617 nnrem = kremnode(ii+1) - kremnode(ii)
618 iada = kremnode(ii)+1
619 DO j=1,ne2
620 ns1= iedgn2(1,j)
621 ns2= iedgn2(2,j)
622 IF (intab(nnrem,remnode(iada),ns1)
623 1 .OR.intab(nnrem,remnode(iada),ns2)) THEN
624 nremov =nremov + 1
625 END IF
626 END DO !J=1,NE2
627 END IF !(KREMNODE(II+1)>KREMNODE(II)) THEN
628 END DO !II=1,NRTM
629 ELSE
630 new = 0
631 DO ii=1,nrtm
632 nr0=nremov
633 kremov_old = kremnode(ii)
634 kremnode(ii) = kremnode(ii) + new
635 IF (kremnode(ii+1)>kremov_old) THEN
636 nnrem = kremnode(ii+1) - kremov_old
637 iada = kremnode(ii)+1
638 iadn = kremnode(ii+1)+new+1
639 DO j=1,ne2
640 ns1= iedgn2(1,j)
641 ns2= iedgn2(2,j)
642 nn = iedgn2(3,j) + numnod
643 IF (intab(nnrem,remnode(iada),ns1)
644 1 .OR.intab(nnrem,remnode(iada),ns2)) THEN
645C------if one of edge nodes in %REMNODE(iad+1:iad+NNREM+1), add fictive nodes
646 CALL insert_a(nremov,remnode,nn ,iadn)
647 new = new + 1
648 END IF !(INTAB(NSREM,INTBUF_TAB(N)%REMNODE(IADA),NS1)
649 END DO ! J=1,NE2
650 END IF !(KREMNODE(II+1)>KREMNODE(II)) THEN
651 END DO !II=1,NRTM
652 kremnode(nrtm+1) = kremnode(nrtm+1) + new
653 END IF !(IFLAG==0) THEN
654C----6---------------------------------------------------------------7---------8
655 RETURN
656 END
657!||====================================================================
658!|| remn_i2op ../starter/source/interfaces/inter3d1/i7remnode.F
659!||--- called by ------------------------------------------------------
660!|| inint3 ../starter/source/interfaces/inter3d1/inint3.F
661!|| inintr ../starter/source/interfaces/interf1/inintr.F
662!|| inintr2 ../starter/source/interfaces/inter3d1/inintr2.F
663!||--- calls -----------------------------------------------------
664!|| ancmsg ../starter/source/output/message/message.F
665!|| fretitl2 ../starter/source/starter/freform.f
666!|| pre_i2 ../starter/source/interfaces/inter3d1/i7remnode.F
667!|| remn_i2op_edg25 ../starter/source/interfaces/int25/i25remlin.F
668!|| upgrade_remnode2 ../starter/source/interfaces/interf1/upgrade_remnode.F
669!|| zeronm_tagd ../starter/source/interfaces/inter3d1/i7remnode.F
670!||--- uses -----------------------------------------------------
671!|| format_mod ../starter/share/modules1/format_mod.F90
672!|| message_mod ../starter/share/message_module/message_mod.F
673!||====================================================================
674 SUBROUTINE remn_i2op(LOWER_BOUND, UPPER_BOUND, IPARI,INTBUF_TAB,ITAB,NOM_OPT,NREMOV,IDDLEVEL,SKIP_TYPE25_EDGE_2_EDGE)
675C-----------------------------------------------
676C M o d u l e s
677C-----------------------------------------------
678 USE my_alloc_mod
679 USE message_mod
680 USE intbufdef_mod
681 USE names_and_titles_mod , ONLY : nchartitle
682 USE format_mod , ONLY : fmw_10i
683C-----------------------------------------------
684C I m p l i c i t T y p e s
685C-----------------------------------------------
686#include "implicit_f.inc"
687C-----------------------------------------------
688C A n a l y s e M o d u l e
689C-----------------------------------------------
690#include "param_c.inc"
691C-----------------------------------------------
692C D u m m y A r g u m e n t s
693C-----------------------------------------------
694 INTEGER IPARI(NPARI,*), ITAB(*),NREMOV(*)
695 INTEGER NOM_OPT(LNOPT1,*)
696 INTEGER, INTENT(in) :: IDDLEVEL
697 INTEGER, INTENT(in) :: SKIP_TYPE25_EDGE_2_EDGE !< flag for interface 25 :( : if edge to edge is used by interface type 25, need to do the computation after the initialization of LEDGE array | (0) no interface 25 with e2e --> nodes can be removed, (1) interface 25 with e2e --> other interfaces can be treated, (2) only the interface type 25 with e2e is treated
698 INTEGER, INTENT(in) :: LOWER_BOUND, UPPER_BOUND !< lower and upper bound of the loop, necessary because this subroutine may be called once for all interface, or interface by interface
699
700 TYPE(intbuf_struct_) INTBUF_TAB(*)
701C-----------------------------------------------
702C C o m m o n B l o c k s
703C-----------------------------------------------
704#include "com04_c.inc"
705#include "scr17_c.inc"
706C-----------------------------------------------
707C L o c a l V a r i a b l e s
708C-----------------------------------------------
709 INTEGER N,NTY,FLAGREMNODE
710 INTEGER ILEV,II,J,NMN,NSN,NRTS,NRTM,LREMNORMAX,K,
711 . NLINS,NLINM,IWOUT,INCOM,NM,N2,IFLAG,NRE,ip,IACT,
712 . if7,if24,if25,nn2,nnod,m1,m2,m3,m4,nnrem,ibit,new,
713 . ki,kl,jj,iedge,nedge
714 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGD
715 INTEGER ID
716 CHARACTER(LEN=NCHARTITLE) :: TITR
717
718 INTEGER :: COMPTEUR,I2NODE_SIZE,I,L,L1,IS,IIS,NS,IADA
719 INTEGER :: TYP25_USE
720 INTEGER, DIMENSION(:,:), ALLOCATABLE :: I2NODE,POINTS_I2N
721 INTEGER, DIMENSION(:), ALLOCATABLE :: TAGNOD
722
723
724 INTEGER :: III,JJJ,NNOD_2
725 INTEGER :: FIRST,LAST,NNREM_SAVE,FLAGREMNODE_SAV
726 INTEGER :: OFFSET, NBR_INTRA,NBR_EXTRA,TOTAL_INSERTED
727 INTEGER :: SIZE_INSERTED_NODE,OLDSIZE,MAX_INSERTED_NODE,LIMIT
728 INTEGER, DIMENSION(:), ALLOCATABLE :: NBR_INSERT_II,ADRESS_II
729 INTEGER, DIMENSION(:), ALLOCATABLE :: KREMNODE_SAVE,INSERTED_NODE,REMNODE,TMP
730! -------------------------------
731! FIRST : integer , first block of inserted nodes
732! LAST : integer , last block of inserted nodes
733! NNREM_SAVE : integer , internal counter
734! offset : integer , internal offset for the REMNODE array
735! NBR_INTRA : integer , number of old nodes between 2 blocks
736! NBR_EXTRA : integer , number of old remaining nodes
737! TOTAL_INSERTED : integer , total number of inserted nodes
738! typ25_use : integer, interface typ25 marker --> TYP25_USE = 1 if
739! an interface 25 is used, O otherwise!
740! NBR_INSERT_II : integer, dimension = NRTM , number of inserted nodes for each II segment
741! ADRESS_II : integer, dimension = NRTM , adress of the first inserted nodes for each II segment
742! KREMNODE_SAVE : integer, dimension = NRTM+1 , list of old nodes
743! SIZE_INSERTED_NODE : integer, size of the INSERTED_NODE array ; SIZE_INSERTED_NODE is an upper bound,
744! can be optimized!
745! INSERTED_NODE : integer, dimension = SIZE_INSERTED_NODE, list inserted nodes
746! REMNODE : integer, dimension = NRTM + TOTAL_INSERTED, new array with old and inserted nodes
747! -------------------------------
748C-----------------------------------------------
749C----like Irem_gap of int7, creat list of SECONDARY nodes to be removed per M_seg
750C----------only during dimensioning
751 iact=0
752 typ25_use = 0
753 DO n=lower_bound,upper_bound
754 nty=ipari(7,n)
755 if7 =ipari(54,n)
756 if24=ipari(63,n)
757 if25=ipari(83,n)
758 IF(nty==7 .AND. if7>0 )THEN
759 iact=1
760 cycle
761 ENDIF
762 IF(nty==24 .AND. if24>0 )THEN
763 iact=1
764 cycle
765 ENDIF
766 IF(nty==25 .AND. if25>0 )THEN
767 iact=1
768 typ25_use = 1
769 cycle
770 ENDIF
771 ENDDO
772 IF (iact==0) THEN
773 DO n=lower_bound,upper_bound
774 nremov(n) = 0
775 ENDDO
776 RETURN
777 END IF
778 IF(typ25_use==1) THEN
779 ALLOCATE( tagnod(numnod) )
780 tagnod(1:numnod) = 0
781 ENDIF
782C-------tag int2 nodes------
783
784! ********************************
785
786! I2NODE : | 1th node surf/MAIN | interface | SECONDARY |
787! | 2nd node surf/MAIN | interface | SECONDARY |
788! | 3tr node surf/MAIN | interface | SECONDARY |
789! | 4th node surf/MAIN | interface | SECONDARY |
790! | secondary node | interface | -secondary |
791
792! Compute the size of I2NODE array
793 i2node_size = 0
794 DO n=1,ninter
795 nty=ipari(7,n)
796 nremov(n) = 0
797 IF(nty==2)THEN
798 nsn =ipari(5,n)
799 DO ii=1,nsn
800 l=intbuf_tab(n)%IRTLM(ii)
801 IF (intbuf_tab(n)%IRECTM(4*(l-1)+3)==intbuf_tab(n)%IRECTM(4*(l-1)+4)) THEN
802 nnod = 3
803 ELSE
804 nnod = 4
805 END IF
806 i2node_size=i2node_size + nnod + 1
807 END DO !II=1,NSN
808 ENDIF
809 ENDDO
810 IF (i2node_size==0) RETURN
811 ALLOCATE(i2node(i2node_size,3))
812 ALLOCATE(points_i2n(numnod,2))
813 ALLOCATE(tagd(numnod))
814
815 CALL pre_i2(ipari ,intbuf_tab ,i2node_size, i2node,points_i2n)
816
817
818! ------------------------------------------------
819
820! remnode :
821! 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
822!
823! inserted nodes :
824! 3 nodes for ii=1 ; adress of the 1st one = 3 ; iad1(1) --> iad1(3)
825! 1 nodes for ii=4 ; adress of the 1st one = 7 ; iad2(1) --> iad2(1)
826! 6 nodes for ii=1 ; adress of the 1st one = 10 ; iad3(1) --> iad3(6)
827!
828! First insertion iad1 :
829! 1 | 2 | iad1(1) | 3 | 4 | 5 | 6 | 7 | 8 | 9
830! 1 | 2 | iad1(2) | iad1(1) | 3 | 4 | 5 | 6 | 7 | 8 | 9
831! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | 4 | 5 | 6 | 7 | 8 | 9
832!
833! iad2 :
834! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | 4 | 5 | 6 | 7 | 8 | 9
835!
836! iad3 :
837! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | 4 | 5 | iad3(1) | 6 | 7 | 8 | 9
838! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | 4 | 5 | iad3(2) | iad3(1) | 6 | 7 | 8 | 9
839! ...
840!
841! Optimization :
842! 1st step :
843! count the total number of inserted nodes --> NNREM
844! get the number of the inserted nodes for each II segment --> NBR_INSERT_II
845! get the address of the first node for each II segment --> ADRESS_II
846! save the inserted node --> INSERTED_NODE
847! 2nd step :
848! allocate the new array REMNODE
849! get the first/last block of inserted node --> FIRST/LAST
850! if ADRESS_II(FIRST) = 1 --> insert the NBR_INSERT_II(FIRST) node in REMNODE(1:NBR_INSERT_II(FIRST))
851! if ADRESS_II(FIRST) > 1 --> copy the old node in the new array
852! copy the inserted nodes in the new array for each II segment
853! copy the old nodes in the new array for each II segment
854! check if every old nodes were copied and if not, copy them!
855!
856! example :
857! old remnode :
858! 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
859! new remnode :
860! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | 4 | 5 | iad3(6) | ... | iad3(2) | iad3(1) | 6 | 7 | 8 | 9
861!
862! ADRESS_II(FIRST) > 1 :
863! new remnode :
864! 1 | 2 | . | . | ...
865! for II=1, insert the iad1 nodes :
866! 1 | 2 | iad1(2) | iad1(1) | . | . | ...
867! for II=1, copy the old nodes :
868! 1 | 2 | iad1(2) | iad1(1) | 3 | . | . |
869! ...
870! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | . | . | ...
871! for II=LAST, insert the iadlast nodes
872! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | 4 | 5 | iad3(6) | ... | iad3(2) | iad3(1) | . | . | ...
873! if there are no old nodes to insert, the treatment is over
874! else insert the remaining old nodes
875! 1 | 2 | iad1(3) | iad1(2) | iad1(1) | 3 | iad2(1) | 4 | 5 | iad3(6) | ... | iad3(2) | iad3(1) | 6 | 7 | 8 | 9
876! ------------------------------------------------
877 limit = huge(n)
878
879C---------
880 DO n=lower_bound,upper_bound
881 nty=ipari(7,n)
882 nsn =ipari(5,n)
883 nrts =ipari(3,n)
884 nrtm =ipari(4,n)
885 if7 =ipari(54,n)
886 if24 =ipari(63,n)
887 if25 =ipari(83,n)
888 iedge = ipari(58,n)
889 IF(iddlevel==0.AND.(nty/=24.AND.nty/=25)) cycle
890 ! special case : interface type 25 with edge to edge
891 ! LEDGE array is initialized during the sorting
892 ! interface type 25 with edge to edge must be treated after the %LEDGE initialization
893 ! type25 + SKIP_TYPE25_EDGE_2_EDGE==1 --> skip the interface type 25 with e2e
894 IF(iddlevel==0.AND.nty==25.AND.skip_type25_edge_2_edge==1) cycle
895 ! type/=25 + SKIP_TYPE25_EDGE_2_EDGE==2 -6> only compute the interface 25 with e2e
896 IF(iddlevel==0.AND.nty/=25.AND.skip_type25_edge_2_edge==2) cycle
897 ALLOCATE( nbr_insert_ii(nrtm) )
898 ALLOCATE( adress_ii(nrtm) )
899 ALLOCATE( kremnode_save(nrtm+1) )
900 nbr_insert_ii(1:nrtm) = 0
901 adress_ii(1:nrtm) = 0
902 kremnode_save(1:nrtm+1) = 0
903
904 id=nom_opt(1,n)
905 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
906C----- --
907 IF((nty==7.AND.if7>0).OR.(nty==24.AND.if24>0).OR.(nty==25.AND.if25>0))THEN
908 tagd(1:numnod)=2
909 jjj = 0
910 flagremnode=ipari(63,n)
911 flagremnode_sav=ipari(63,n)
912C--------dim first
913 nnrem = 0
914 DO jj=1,nsn
915 ns = intbuf_tab(n)%NSV(jj)
916 IF (ns<=numnod) tagd(ns)=0
917 ENDDO
918 iflag =0
919 nremov(n) = ipari(62,n)
920 iada= 1
921 IF(nremov(n)>0) kremnode_save(1:nrtm+1) = intbuf_tab(n)%KREMNODE(1:nrtm+1)
922
923 size_inserted_node = 1
924 max_inserted_node = 1
925 DO ii=1,nrtm
926 IF (intbuf_tab(n)%IRECTM(4*(ii-1)+4)==intbuf_tab(n)%IRECTM(4*(ii-1)+3)) THEN
927 nnod=3
928 ELSE
929 nnod=4
930 END IF
931 DO j=1,nnod
932 nm = intbuf_tab(n)%IRECTM(4*(ii-1)+j)
933 IF (points_i2n(nm,1)==0) cycle
934 max_inserted_node = max( max_inserted_node,points_i2n(nm,2)-points_i2n(nm,1)+1 )
935 ENDDO
936 ENDDO
937
938 IF( max_inserted_node > limit / (4*nrtm) .OR. max_inserted_node > 1000000 / nrtm ) THEN
939 size_inserted_node = 4 * nrtm
940 ELSE
941 size_inserted_node = 4 * nrtm *max_inserted_node
942 ENDIF
943
944 CALL my_alloc(inserted_node,size_inserted_node)
945
946 DO ii=1,nrtm
947 nnrem_save = nnrem
948C
949C Do not add nodes already stored w/IREM_GAP
950 IF(flagremnode==2)THEN
951 ki = intbuf_tab(n)%KREMNODE(ii)+1
952 kl = intbuf_tab(n)%KREMNODE(ii+1)
953 DO j=ki,kl
954 ns = intbuf_tab(n)%REMNODE(j)
955 tagd(ns)=1
956 END DO
957 END IF
958C
959 IF (intbuf_tab(n)%IRECTM(4*(ii-1)+4)==intbuf_tab(n)%IRECTM(4*(ii-1)+3)) THEN
960 nnod=3
961 ELSE
962 nnod=4
963 END IF
964
965 IF(jjj + nnod * max_inserted_node > size_inserted_node) THEN
966C extend INSERTED_NODE if needed
967 oldsize = size_inserted_node
968 size_inserted_node = size_inserted_node + min(nrtm,10*nnod*max_inserted_node)
969 CALL my_alloc(tmp,size_inserted_node)
970 tmp(1:oldsize) = inserted_node(1:oldsize)
971! move_alloc deallocates TMP
972 CALL move_alloc(tmp,inserted_node)
973 ENDIF
974
975 DO j=1,nnod
976 nm = intbuf_tab(n)%IRECTM(4*(ii-1)+j)
977 IF (points_i2n(nm,1)==0) cycle
978 DO i=points_i2n(nm,1),points_i2n(nm,2)
979 n2 = i2node(i,2)
980 is = i2node(i,3)
981 IF (is >0) THEN
982 ns = intbuf_tab(n2)%NSV(is)
983 IF (tagd(ns)==0) THEN
984 nnrem = nnrem + 1
985 tagd(ns)=1
986 jjj = jjj + 1
987 inserted_node(jjj) = ns
988 END IF
989 ELSEIF (is <0) THEN
990 iis = -is
991 l = intbuf_tab(n2)%IRTLM(iis)
992 nnod_2 = 4
993 IF( intbuf_tab(n2)%IRECTM(4*(l-1)+4)==intbuf_tab(n2)%IRECTM(4*(l-1)+3) ) nnod_2 = 3
994 DO iii = 1,nnod_2
995 nm = intbuf_tab(n2)%IRECTM(4*(l-1)+iii)
996 IF(tagd(nm)==0) THEN
997 nnrem = nnrem + 1
998 tagd(nm)=1
999 jjj = jjj + 1
1000 inserted_node(jjj) = nm
1001 ENDIF
1002 ENDDO
1003 END IF
1004 END DO
1005 END DO !DO J=1,4
1006
1007 ! -------------------
1008 ! number of inserted nodes
1009 nbr_insert_ii(ii) = nnrem - nnrem_save
1010 kremnode_save(ii) = kremnode_save(ii+1) - kremnode_save(ii)
1011 iada = iada + kremnode_save(ii)
1012 ! adress of the first inserted node
1013 adress_ii(ii) = iada
1014 kremnode_save(ii) = iada + nbr_insert_ii(ii) - 1
1015 iada = iada + nbr_insert_ii(ii)
1016 ! -------------------
1017
1018C-----reset TAGD=0
1019 DO j=1,nnod
1020 nm = intbuf_tab(n)%IRECTM(4*(ii-1)+j)
1021 IF (points_i2n(nm,1)==0) cycle
1022 DO i=points_i2n(nm,1),points_i2n(nm,2)
1023 n2 = i2node(i,2)
1024 is = i2node(i,3)
1025 IF (is >0) THEN
1026 ns = intbuf_tab(n2)%NSV(is)
1027 IF (tagd(ns)==1) tagd(ns)=0
1028 ELSEIF (is <0) THEN
1029 iis = -is
1030 CALL zeronm_tagd(iis ,intbuf_tab(n2)%IRECTM,
1031 . intbuf_tab(n2)%IRTLM,tagd)
1032 END IF
1033 END DO
1034 END DO !DO J=1,NNOD
1035 IF(flagremnode==2)THEN
1036 DO j=ki,kl
1037 ns = intbuf_tab(n)%REMNODE(j)
1038 tagd(ns)=0
1039 END DO
1040 END IF
1041C
1042 END DO !II=1,NRTM
1043
1044
1045 IF(nnrem>0) THEN
1046
1047 ! get the first and the last inserted node
1048 first = 0
1049 last = 0
1050 DO ii = 1,nrtm
1051 IF(first==0) THEN
1052 IF( nbr_insert_ii(ii)/=0 ) first = ii
1053 ENDIF
1054 IF(last==0) THEN
1055 IF( nbr_insert_ii(nrtm+1-ii)/=0 ) last = nrtm+1-ii
1056 ENDIF
1057 ENDDO
1058 ! count the total number of inserted nodes
1059 total_inserted = 0
1060 DO ii=1,nrtm
1061 total_inserted = total_inserted + nbr_insert_ii(ii)
1062 ENDDO
1063 ! allocate the buffer array
1064 ALLOCATE( remnode(nremov(n)+total_inserted) )
1065
1066 j = 0
1067 i = 0
1068 offset = 0
1069 IF( first>0 ) THEN
1070 ! insertion of the first chunk of node : if ADRESS_II(FIRST) > 1
1071 ! --> need to copy the old nodes
1072 IF( adress_ii(first)>1 ) THEN
1073 remnode(1:adress_ii(first)-1) = intbuf_tab(n)%REMNODE(1:adress_ii(first)-1)
1074 offset = offset + adress_ii(first)-1
1075 i = i + adress_ii(first)-1
1076 ENDIF
1077
1078 DO ii=first,last
1079 ! insertion of the nodes
1080 IF( nbr_insert_ii(ii)>0 ) THEN
1081 DO jj = 1,nbr_insert_ii(ii)
1082 j = j + 1
1083 remnode(offset+nbr_insert_ii(ii)+1-jj) = inserted_node(j)
1084 ENDDO
1085 offset = offset + nbr_insert_ii(ii)
1086 ENDIF
1087 IF(ii<last.AND.nremov(n)>0) THEN
1088 ! copy of the old nodes
1089 nbr_intra = adress_ii(ii+1) - adress_ii(ii)-nbr_insert_ii(ii)
1090 IF( nbr_intra>0 )THEN
1091 DO jj = 1,nbr_intra
1092 i = i + 1
1093 remnode(jj+offset) = intbuf_tab(n)%REMNODE(i)
1094 ENDDO
1095 offset = offset + nbr_intra
1096 ENDIF
1097 ENDIF
1098 ENDDO
1099 ENDIF
1100 ! copy of the old nodes for the LAST chunk
1101
1102 IF( i<nremov(n) ) THEN
1103 nbr_extra = nremov(n) - i
1104 remnode(offset+1:offset+nbr_extra) = intbuf_tab(n)%REMNODE(i+1:nremov(n))
1105 ENDIF
1106 ! update of NNREM and deallocation / allocation of the new array
1107 nnrem = nnrem + nremov(n)
1108 CALL upgrade_remnode2(n,nnrem,intbuf_tab(n),nty)
1109 intbuf_tab(n)%REMNODE(1:nnrem) = remnode(1:nnrem)
1110 intbuf_tab(n)%KREMNODE(2:nrtm+1) = kremnode_save(1:nrtm)
1111 intbuf_tab(n)%KREMNODE(1)=0
1112 ! -----------------
1113 ! only print the message for the 2nd sorting
1114 IF(iddlevel>0) THEN
1115C------------update of IPARI(62,N) is out of subroutine
1116 CALL ancmsg(msgid=1053,
1117 . msgtype=msgwarning,
1118 . anmode=aninfo_blind_1,
1119 . i1=id,
1120 . c1=titr,
1121 . i2=nnrem,
1122 . i3=nom_opt(1,n2))
1123 ENDIF
1124 ! -----------------
1125C----------used for Iedge=1
1126 nremov(n) = nnrem
1127 END IF !IF (NNREM>0) THEN
1128 IF(ALLOCATED(remnode)) DEALLOCATE( remnode )
1129 IF(ALLOCATED(inserted_node)) DEALLOCATE( inserted_node )
1130
1131 ! -------------------
1132 ! ------------------------------------------------
1133 END if!(NTY==7.OR.NTY==24.OR.NTY==25)
1134C
1135 IF(nty==25.AND.if25>0.AND.nnrem>0)THEN
1136C
1137 DO i=1,nsn
1138 tagnod(intbuf_tab(n)%NSV(i))=i
1139 END DO
1140C
1141C----- Inverse table of REMNODE for sliding in int25 : SECONDARY node -> MAIN segments---
1142 DO i=1,nrtm
1143 k = intbuf_tab(n)%KREMNODE(i)+1
1144 l = intbuf_tab(n)%KREMNODE(i+1)
1145 DO j=k,l
1146 ns = tagnod(intbuf_tab(n)%REMNODE(j))
1147 intbuf_tab(n)%KREMNOR(ns) = intbuf_tab(n)%KREMNOR(ns)+1
1148 ENDDO
1149 ENDDO
1150C
1151 DO ns=1,nsn
1152 intbuf_tab(n)%KREMNOR(ns+1) = intbuf_tab(n)%KREMNOR(ns+1) + intbuf_tab(n)%KREMNOR(ns)
1153 END DO
1154C
1155 DO ns=nsn,1,-1
1156 intbuf_tab(n)%KREMNOR(ns+1)=intbuf_tab(n)%KREMNOR(ns)
1157 END DO
1158 intbuf_tab(n)%KREMNOR(1)=0
1159C
1160 DO i=1,nrtm
1161 k = intbuf_tab(n)%KREMNODE(i)+1
1162 l = intbuf_tab(n)%KREMNODE(i+1)
1163 DO j=k,l
1164 ns = tagnod(intbuf_tab(n)%REMNODE(j))
1165 intbuf_tab(n)%KREMNOR(ns) = intbuf_tab(n)%KREMNOR(ns)+1
1166 intbuf_tab(n)%REMNOR(intbuf_tab(n)%KREMNOR(ns)) = i
1167 ENDDO
1168 ENDDO
1169C
1170 DO ns=nsn,1,-1
1171 intbuf_tab(n)%KREMNOR(ns+1)=intbuf_tab(n)%KREMNOR(ns)
1172 END DO
1173 intbuf_tab(n)%KREMNOR(1)=0
1174C
1175C------- Compute maximum number of MAIN segments banned for all SECONDARY nodes---
1176 lremnormax = 0
1177 DO ns=1,nsn
1178 l = intbuf_tab(n)%KREMNOR(ns+1)-intbuf_tab(n)%KREMNOR(ns)
1179 IF( l>lremnormax) THEN
1180 lremnormax = l
1181 ENDIF
1182 ENDDO
1183 ipari(82,n) = lremnormax
1184C
1185C------- Reset IRTLM & PENE_OLD (cf INACTI)
1186
1187 DO ns=1,nsn
1188 DO j=intbuf_tab(n)%KREMNOR(ns)+1,intbuf_tab(n)%KREMNOR(ns+1)
1189 l=intbuf_tab(n)%REMNOR(j)
1190 IF(intbuf_tab(n)%IRTLM(4*(ns-1)+1)==intbuf_tab(n)%MSEGLO(l))THEN
1191 intbuf_tab(n)%IRTLM(4*(ns-1)+1:4*(ns-1)+4) =0
1192 intbuf_tab(n)%TIME_S(2*(ns-1)+1:2*(ns-1)+2) =zero
1193 intbuf_tab(n)%PENE_OLD(5*(ns-1)+1:5*(ns-1)+5)=zero
1194 ENDIF
1195 ENDDO
1196 ENDDO
1197
1198 DO i=1,nsn
1199 tagnod(intbuf_tab(n)%NSV(i))=0
1200 END DO
1201
1202 END IF ! IF(NTY==25.AND.IF25>0)THEN
1203
1204 DEALLOCATE( nbr_insert_ii )
1205 DEALLOCATE( adress_ii )
1206 DEALLOCATE( kremnode_save )
1207C-------------------------------------------------
1208C IremI2 for edge to edge contact type 25
1209C-----------------------------------------------
1210
1211 IF(nty==25.AND.if25>0.AND.iedge>0)THEN
1212 nedge = ipari(68,n)
1213 IF (nedge >0)
1214 . CALL remn_i2op_edg25(n ,flagremnode_sav ,ipari ,intbuf_tab ,i2node,
1215 . points_i2n ,i2node_size ,nom_opt ,itab,iddlevel)
1216 ENDIF
1217 END DO
1218
1219 DEALLOCATE(tagd,i2node,points_i2n)
1220 IF(typ25_use==1) THEN
1221 DEALLOCATE( tagnod )
1222 ENDIF
1223C----
1224 RETURN
1225 END
1226!||====================================================================
1227!|| pre_i2 ../starter/source/interfaces/inter3d1/i7remnode.F
1228!||--- called by ------------------------------------------------------
1229!|| remn_i2op ../starter/source/interfaces/inter3d1/i7remnode.F
1230!||--- calls -----------------------------------------------------
1231!||--- uses -----------------------------------------------------
1232!||====================================================================
1233 SUBROUTINE pre_i2(IPARI ,INTBUF_TAB ,NSIZE, I2NODE,POINT_I2NODE)
1234C-----------------------------------------------
1235C M o d u l e s
1236C-----------------------------------------------
1237 USE my_alloc_mod
1238 USE intbufdef_mod
1239C-----------------------------------------------
1240C I m p l i c i t T y p e s
1241C-----------------------------------------------
1242#include "implicit_f.inc"
1243C-----------------------------------------------
1244C A n a l y s e M o d u l e
1245C-----------------------------------------------
1246#include "param_c.inc"
1247#include "com04_c.inc"
1248C-----------------------------------------------
1249C D u m m y A r g u m e n t s
1250C-----------------------------------------------
1251 INTEGER NSIZE
1252 INTEGER IPARI(NPARI,*), I2NODE(NSIZE,3),POINT_I2NODE(NUMNOD,2)
1253
1254 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1255C-----------------------------------------------
1256C L o c a l V a r i a b l e s
1257C-----------------------------------------------
1258 INTEGER N,NTY
1259 INTEGER ILEV,II,J,NMN,NSN,NRTS,NRTM,
1260 . NLINS,NLINM,IWOUT,INCOM,NM,N2,IFLAG,NRE,ip,IACT,
1261 . IF7,IF24,IF25,NN2,NNOD,M1,M2,M3,M4
1262
1263 INTEGER :: WORK(70000)
1264 INTEGER :: COMPTEUR,I2NODE_SIZE,I,L,L1
1265 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX
1266 INTEGER, DIMENSION(:,:), ALLOCATABLE :: I2NODE_LOC
1267
1268C-----------------------------------------------
1269 i2node_size = nsize
1270! ********************************
1271
1272! I2NODE : | 1th node surf/MAIN | interface | SECONDARY |
1273! | 2nd node surf/MAIN | interface | SECONDARY |
1274! | 3tr node surf/MAIN | interface | SECONDARY |
1275! | 4th node surf/MAIN | interface | SECONDARY |
1276! | SECONDARY node | interface | -SECONDARY |
1277
1278! Compute the size of I2NODE array
1279! Allocate the temporary I2NODE array to I2NODE_SIZE , 3
1280 ALLOCATE(i2node_loc(i2node_size,3))
1281
1282 compteur=1
1283 DO n=1,ninter
1284 nty=ipari(7,n)
1285 IF(nty==2)THEN
1286 nrts =ipari(3,n)
1287 nrtm =ipari(4,n)
1288 nsn =ipari(5,n)
1289 nmn =ipari(6,n)
1290 ilev =ipari(20,n)
1291 DO ii=1,nsn
1292 i=intbuf_tab(n)%NSV(ii)
1293 l=intbuf_tab(n)%IRTLM(ii)
1294 l1 = 4*(l-1)
1295 m1 = intbuf_tab(n)%IRECTM(l1+1)
1296 m2 = intbuf_tab(n)%IRECTM(l1+2)
1297 m3 = intbuf_tab(n)%IRECTM(l1+3)
1298 m4 = intbuf_tab(n)%IRECTM(l1+4)
1299 ! 1
1300 i2node_loc(compteur,1) = m1 ! node surf/main
1301 i2node_loc(compteur,2) = n ! interface
1302 i2node_loc(compteur,3) = ii ! SECONDARY_id
1303 compteur = compteur + 1
1304 ! 2
1305 i2node_loc(compteur,1) = m2
1306 i2node_loc(compteur,2) = n
1307 i2node_loc(compteur,3) = ii
1308 compteur = compteur + 1
1309 ! 3
1310 i2node_loc(compteur,1) = m3
1311 i2node_loc(compteur,2) = n
1312 i2node_loc(compteur,3) = ii
1313 compteur = compteur + 1
1314 ! 4
1315 IF (m4/=m3) THEN
1316 i2node_loc(compteur,1) = m4 ! node surf/MAIN
1317 i2node_loc(compteur,2) = n ! interface
1318 i2node_loc(compteur,3) = ii ! SECONDARY
1319 compteur = compteur + 1
1320 END IF !(M4/=M3) THEN
1321 ! 5
1322 i2node_loc(compteur,1) = i ! SECONDARY node
1323 i2node_loc(compteur,2) = n ! interface
1324 i2node_loc(compteur,3) = -ii ! - SECONDARY
1325 compteur = compteur + 1
1326 ENDDO
1327 ENDIF
1328 ENDDO
1329
1330! Sort the I2NODE array :
1331! | NSM(1) | Inter(1) | SECONDARY(1)
1332! | NSM(1) | Inter(1) | SECONDARY(20)
1333! | NSM(1) | Inter(1) | SECONDARY(3)
1334! | NSM(1) | Inter(2) | SECONDARY(1)
1335! | NSM(2) | Inter(4) | SECONDARY(14)
1336! | NSM(2) | Inter(5) | SECONDARY(18)
1337! | NSM(3) | Inter(1) | SECONDARY(1)
1338! | ... | ... | ...
1339! Compute the pointer array POINT_I2NODE :
1340! | 0 | 0 | if 0,0 --> node not in type2 interface
1341! | 1 | 3 |
1342! | 4 | 5 |
1343! | 0 | 0 |
1344
1345 ALLOCATE( index(2*i2node_size) )
1346 DO i=1,2*i2node_size
1347 index(i)=i
1348 ENDDO
1349c ALLOCATE(I2NODE(I2NODE_SIZE,3))
1350 CALL my_orders( 0, work, i2node_loc(1,1), index, i2node_size , 1)
1351 compteur = 1
1352c ALLOCATE(POINT_I2NODE(NUMNOD,2))
1353 point_i2node(1:numnod,1:2) = 0
1354 point_i2node(i2node_loc(index(1),1),1) = 1
1355 DO i=1,i2node_size
1356! Initialization of I2NODE array
1357 i2node(compteur,1) = i2node_loc(index(i),1)
1358 i2node(compteur,2) = i2node_loc(index(i),2)
1359 i2node(compteur,3) = i2node_loc(index(i),3)
1360! Initialization of POINT_I2NODE array
1361 IF(point_i2node(i2node_loc(index(i),1),1)==0) THEN
1362 point_i2node(i2node_loc(index(i),1),1) = compteur
1363 IF (i>1) point_i2node(i2node_loc(index(i-1),1),2) = compteur - 1
1364 ENDIF
1365 compteur=compteur+1
1366 ENDDO
1367 point_i2node(i2node_loc(index(i2node_size),1),2) = i2node_size
1368! Deallocate the temporary I2NODE_LOC array and the INDEX array
1369 DEALLOCATE(index)
1370 DEALLOCATE(i2node_loc)
1371! ********************************
1372C----
1373 RETURN
1374 END
1375!||====================================================================
1376!|| zeronm_tagd ../starter/source/interfaces/inter3d1/i7remnode.f
1377!||--- called by ------------------------------------------------------
1378!|| remn_i2op ../starter/source/interfaces/inter3d1/i7remnode.F
1379!||====================================================================
1380 SUBROUTINE zeronm_tagd(IS ,IRECT ,IRTL ,TAGD )
1381C-----------------------------------------------
1382C I m p l i c i t T y p e s
1383C-----------------------------------------------
1384#include "implicit_f.inc"
1385C-----------------------------------------------
1386C D u m m y A r g u m e n t s
1387C-----------------------------------------------
1388 INTEGER IRECT(4,*),IRTL(*), TAGD(*) ,IS
1389C----IFLAG=0 -> dim , IREMOV : Global node num. (SECONDARY)
1390C REAL
1391C-----------------------------------------------
1392C L o c a l V a r i a b l e s
1393C-----------------------------------------------
1394 INTEGER II ,I,J ,IL, L,NM,NNOD
1395C-----------------------------------------------
1396 I=is
1397 nnod=4
1398 l=irtl(is)
1399 IF (irect(4,l)==irect(3,l)) nnod=3
1400 DO j=1,nnod
1401 nm =irect(j,l)
1402 IF (tagd(nm)==1) tagd(nm)=0
1403 END DO
1404C----
1405 RETURN
1406 END
1407!||====================================================================
1408!|| remn_i2_edgop ../starter/source/interfaces/inter3d1/i7remnode.F
1409!||--- called by ------------------------------------------------------
1410!|| inintr ../starter/source/interfaces/interf1/inintr.F
1411!|| inintr2 ../starter/source/interfaces/inter3d1/inintr2.F
1412!||--- calls -----------------------------------------------------
1413!|| add_nsfic1 ../starter/source/interfaces/inter3d1/i7remnode.f
1414!|| dim_ptedgn ../starter/source/interfaces/inter3d1/i7remnode.f
1415!|| pre_i2edge ../starter/source/interfaces/inter3d1/i7remnode.F
1416!|| upgrade_remnode2 ../starter/source/interfaces/interf1/upgrade_remnode.F
1417!||--- uses -----------------------------------------------------
1418!||====================================================================
1419 SUBROUTINE remn_i2_edgop(IPARI ,INTBUF_TAB ,ITAB, NREMOV)
1420C-----------------------------------------------
1421C M o d u l e s
1422C-----------------------------------------------
1423 USE my_alloc_mod
1424 USE intbufdef_mod
1425C-----------------------------------------------
1426C I m p l i c i t T y p e s
1427C-----------------------------------------------
1428#include "implicit_f.inc"
1429C-----------------------------------------------
1430C A n a l y s e M o d u l e
1431C-----------------------------------------------
1432#include "param_c.inc"
1433C-----------------------------------------------
1434C D u m m y A r g u m e n t s
1435C-----------------------------------------------
1436 INTEGER IPARI(NPARI,*), ITAB(*),NREMOV(*),IFLAG
1437
1438 TYPE(intbuf_struct_) INTBUF_TAB(*)
1439C-----------------------------------------------
1440C C o m m o n B l o c k s
1441C-----------------------------------------------
1442#include "com04_c.inc"
1443C-----------------------------------------------
1444C L o c a l V a r i a b l e s
1445C-----------------------------------------------
1446 INTEGER N,NTY,NN,NE2,IE,IE1,IE2,I,NNREM,NNREMEG
1447 INTEGER II,J,NMN,NSN,NRTS,NRTM,IADA,IEDGE,NSNE,NRTSE,IACT
1448 INTEGER, DIMENSION(:),ALLOCATABLE :: TAGN,TAGE,E2NODE
1449 INTEGER, DIMENSION(:,:),ALLOCATABLE :: PT_E2NODE
1450C-----------------------------------------------
1451C----like Irem_gap of int7, creat list of SECONDARY nodes to be removed per M_seg
1452 IACT=0
1453 do n=1,ninter
1454 nty=ipari(7,n)
1455 nsne = ipari(55,n)
1456 IF (nty==24.AND.nremov(n) >0.AND.nsne>0) iact=1
1457 END DO
1458 IF (iact==0) RETURN
1459C--------- DIM
1460 ALLOCATE(tagn(numnod))
1461 DO n=1,ninter
1462 nty=ipari(7,n)
1463 nsn =ipari(5,n)
1464 nrtm =ipari(4,n)
1465 iedge =ipari(59,n)
1466 nsne = ipari(55,n)
1467 IF (nty==24.AND.nremov(n) >0.AND.nsne>0) THEN
1468 tagn(1:numnod)=0
1469 DO j=1,intbuf_tab(n)%KREMNODE(nrtm+1)
1470 nn = intbuf_tab(n)%REMNODE(j)
1471 tagn(nn)=1
1472 END DO
1473 CALL dim_ptedgn(ne2,nsne,intbuf_tab(n)%IS2SE,intbuf_tab(n)%IRTSE,tagn)
1474 IF (ne2==0) cycle
1475 ALLOCATE(e2node(ne2),pt_e2node(numnod,2))
1476 CALL pre_i2edge(ne2,nsne,intbuf_tab(n)%IS2SE,intbuf_tab(n)%IRTSE,tagn,
1477 + e2node,pt_e2node)
1478C---- dim
1479 iflag = 0
1480 ALLOCATE(tage(nsne))
1481 tage(1:nsne)=0
1482 nnremeg=0
1483 CALL add_nsfic1(nrtm,nnremeg,intbuf_tab(n)%KREMNODE,intbuf_tab(n)%REMNODE,
1484 + e2node,pt_e2node,tage,iflag)
1485 IF (nnremeg>0) THEN
1486 nnremeg = nnremeg + nremov(n)
1487 CALL upgrade_remnode2(n,nnremeg,intbuf_tab(n),nty)
1488 iflag = 1
1489 CALL add_nsfic1(nrtm,nremov(n),intbuf_tab(n)%KREMNODE,intbuf_tab(n)%REMNODE,
1490 + e2node,pt_e2node,tage,iflag)
1491 END IF !(NNREMEG>0) THEN
1492 DEALLOCATE(e2node,pt_e2node,tage)
1493 END IF !(NTY==24.AND.NREMOV(N) >0.AND.NSNE>0) THEN
1494 END DO
1495C-----
1496 DEALLOCATE(tagn)
1497C----
1498 RETURN
1499 END
1500!||====================================================================
1501!|| dim_ptedgn ../starter/source/interfaces/inter3d1/i7remnode.F
1502!||--- called by ------------------------------------------------------
1503!|| remn_i2_edgop ../starter/source/interfaces/inter3d1/i7remnode.F
1504!||====================================================================
1505 SUBROUTINE dim_ptedgn(NSIZE,NSNE,IS2SE,IRTSE,TAGN)
1506C----6---------------------------------------------------------------7---------8
1507C I m p l i c i t T y p e s
1508C-----------------------------------------------
1509#include "implicit_f.inc"
1510C-----------------------------------------------------------------
1511C D u m m y A r g u m e n t s
1512C-----------------------------------------------
1513 INTEGER NSIZE,NSNE,IS2SE(2,*),IRTSE(5,*),TAGN(*)
1514C-----------------------------------------------
1515C L o c a l V a r i a b l e s
1516C-----------------------------------------------
1517 INTEGER IK1(4),IK2(4),NS1,NS2,IED,I,J,IE1,IE2,IE
1518 DATA IK1 /1,2,3,4/
1519 DATA IK2 /2,3,4,1/
1520C-----
1521 NSIZE =0
1522 do i=1,nsne
1523 ie1 = is2se(1,i)
1524 ie2 = is2se(2,i)
1525 IF (ie1 > 0) THEN
1526 ie = ie1
1527 ied=irtse(5,ie)
1528 ns1= irtse(ik1(ied),ie)
1529 ns2= irtse(ik2(ied),ie)
1530 ELSEIF(ie2 > 0) THEN
1531 ie = ie2
1532 ied=irtse(5,ie)
1533 ns1= irtse(ik2(ied),ie)
1534 ns2= irtse(ik1(ied),ie)
1535 ELSE
1536 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
1537 END IF
1538 IF (tagn(ns1)>0.AND.tagn(ns2)>0) THEN
1539 nsize = nsize + 2
1540 END IF
1541 END DO ! I=1,NSNE
1542C----6---------------------------------------------------------------7---------8
1543 RETURN
1544 END
1545!||====================================================================
1546!|| pre_i2edge ../starter/source/interfaces/inter3d1/i7remnode.F
1547!||--- called by ------------------------------------------------------
1548!|| remn_i2_edgop ../starter/source/interfaces/inter3d1/i7remnode.F
1549!||--- calls -----------------------------------------------------
1550!||====================================================================
1551 SUBROUTINE pre_i2edge(NSIZE,NSNE,IS2SE,IRTSE,TAGN,E2NODE,PT_E2NODE)
1552C----6---------------------------------------------------------------7---------8
1553C I m p l i c i t T y p e s
1554C-----------------------------------------------
1555#include "implicit_f.inc"
1556C-----------------------------------------------
1557C C o m m o n B l o c k s
1558C-----------------------------------------------
1559#include "com04_c.inc"
1560C-----------------------------------------------------------------
1561C D u m m y A r g u m e n t s
1562C-----------------------------------------------
1563 INTEGER NSIZE,NSNE,IS2SE(2,*),IRTSE(5,*),TAGN(*),
1564 . E2NODE(NSIZE),PT_E2NODE(NUMNOD,2)
1565C-----------------------------------------------
1566C L o c a l V a r i a b l e s
1567C-----------------------------------------------
1568 INTEGER IK1(4),IK2(4),NS1,NS2,IED,I,J,IE1,IE2,IE
1569 INTEGER :: WORK(70000)
1570 INTEGER :: COMPTEUR,L,L1
1571 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX
1572 INTEGER, DIMENSION(:,:), ALLOCATABLE :: E2NODE_LOC
1573 DATA IK1 /1,2,3,4/
1574 DATA IK2 /2,3,4,1/
1575C-----
1576! ********************************
1577
1578! E2NODE : | 1th EDGE node ns1 | fictive node |
1579! | 2nd EDGE node ns2 | fictive node |
1580
1581! Compute the size of E2NODE array
1582! Allocate the temporary E2NODE array to I2NODE_SIZE , 2
1583 ALLOCATE(e2node_loc(nsize,2))
1584
1585 compteur=1
1586 DO i=1,nsne
1587 ie1 = is2se(1,i)
1588 ie2 = is2se(2,i)
1589 IF (ie1 > 0) THEN
1590 ie = ie1
1591 ied=irtse(5,ie)
1592 ns1= irtse(ik1(ied),ie)
1593 ns2= irtse(ik2(ied),ie)
1594 ELSEIF(ie2 > 0) THEN
1595 ie = ie2
1596 ied=irtse(5,ie)
1597 ns1= irtse(ik2(ied),ie)
1598 ns2= irtse(ik1(ied),ie)
1599 ELSE
1600 print *,'problem EDGE **** I,IE1,IE2=',i,ie1,ie2
1601 END IF
1602 IF (tagn(ns1)>0.AND.tagn(ns2)>0) THEN
1603 e2node_loc(compteur,1) = ns1 ! node surf/MAIN
1604 e2node_loc(compteur,2) = i ! SECONDARY_id
1605 compteur = compteur + 1
1606 ! 2
1607 e2node_loc(compteur,1) = ns2 ! node surf/MAIN
1608 e2node_loc(compteur,2) = i ! SECONDARY_id
1609 compteur = compteur + 1
1610 END IF
1611 END DO ! I=1,NSNE
1612 ALLOCATE( index(2*nsize) )
1613 DO i=1,2*nsize
1614 index(i)=i
1615 ENDDO
1616 CALL my_orders( 0, work, e2node_loc(1,1), index, nsize , 1)
1617 compteur = 1
1618 pt_e2node(1:numnod,1:2) = 0
1619 pt_e2node(e2node_loc(index(1),1),1) = 1
1620 DO i=1,nsize
1621! Initialization of E2NODE array
1622 e2node(compteur) = e2node_loc(index(i),2)
1623! Initialization of POINT_I2NODE array
1624 IF(pt_e2node(e2node_loc(index(i),1),1)==0) THEN
1625 pt_e2node(e2node_loc(index(i),1),1) = compteur
1626 pt_e2node(e2node_loc(index(i-1),1),2) = compteur - 1
1627 ENDIF
1628 compteur=compteur+1
1629 ENDDO
1630 pt_e2node(e2node_loc(index(nsize),1),2) = nsize
1631! Deallocate the temporary I2NODE_LOC array and the INDEX array
1632 DEALLOCATE(index)
1633 DEALLOCATE(e2node_loc)
1634! ********************************
1635C----6---------------------------------------------------------------7---------8
1636 RETURN
1637 END
1638!||====================================================================
1639!|| add_nsfic1 ../starter/source/interfaces/inter3d1/i7remnode.F
1640!||--- called by ------------------------------------------------------
1641!|| remn_i2_edgop ../starter/source/interfaces/inter3d1/i7remnode.F
1642!||====================================================================
1643 SUBROUTINE add_nsfic1(NRTM,NREMOV,KREMNODE,REMNODE,E2NODE,PT_E2NODE,
1644 + TAGN,IFLAG)
1645C----6---------------------------------------------------------------7---------8
1646C I m p l i c i t T y p e s
1647C-----------------------------------------------
1648#include "implicit_f.inc"
1649C-----------------------------------------------
1650C C o m m o n B l o c k s
1651C-----------------------------------------------
1652#include "com04_c.inc"
1653C-----------------------------------------------------------------
1654C D u m m y A r g u m e n t s
1655C-----------------------------------------------
1656 INTEGER NRTM,NREMOV,KREMNODE(*),REMNODE(*),
1657 + E2NODE(*),PT_E2NODE(NUMNOD,2),TAGN(*),IFLAG
1658C-----------------------------------------------
1659C L o c a l V a r i a b l e s
1660C-----------------------------------------------
1661 INTEGER IE,IE1,IE2,I,NNREM,NN,KREMOV_OLD,NM,NII
1662 INTEGER NS1,NS2,IED,J,II,IADA,NS,NEW,NR0,IADN
1663 INTEGER, DIMENSION(:), ALLOCATABLE :: KREMN_CP,REMN_CP
1664C-----
1665 IF (IFLAG==0) then
1666 DO ii=1,nrtm
1667 DO i = kremnode(ii)+1,kremnode(ii+1)
1668 ns = remnode(i)
1669 IF (pt_e2node(ns,1)==0) cycle
1670 DO j = pt_e2node(ns,1),pt_e2node(ns,2)
1671 nn = e2node(j)
1672 IF (tagn(nn)==0) THEN
1673 nremov = nremov + 1
1674 tagn(nn) = 1
1675 END IF
1676 END DO !J=
1677 END DO
1678C reset TAGN(NN) =0
1679 DO i = kremnode(ii)+1,kremnode(ii+1)
1680 ns = remnode(i)
1681 IF (pt_e2node(ns,1)==0) cycle
1682 DO j = pt_e2node(ns,1),pt_e2node(ns,2)
1683 nn = e2node(j)
1684 tagn(nn) = 0
1685 END DO !J=
1686 END DO
1687 END DO !II=1,NRTM
1688 ELSE
1689C-------- copy KREMNODE,REMNODE in *_CP and re-build KREMNODE,REMNODE to avoid insert
1690 ALLOCATE(kremn_cp(nrtm+1),remn_cp(nremov))
1691 kremn_cp(1:nrtm+1)=kremnode(1:nrtm+1)
1692 remn_cp(1:nremov)=remnode(1:nremov)
1693 DO ii=1,nrtm
1694C--------old first
1695 nii = kremn_cp(ii+1)-kremn_cp(ii)
1696 DO i = 1,nii
1697 remnode(kremnode(ii)+i)=remn_cp(kremn_cp(ii)+i)
1698 END DO
1699C--------fictive nodes
1700 new = kremnode(ii) + nii
1701 DO i = kremn_cp(ii)+1,kremn_cp(ii+1)
1702 ns = remn_cp(i)
1703 IF (pt_e2node(ns,1)==0) cycle
1704 DO j = pt_e2node(ns,1),pt_e2node(ns,2)
1705 nn = e2node(j)
1706 IF (tagn(nn)==0) THEN
1707 nm = nn + numnod
1708 new = new + 1
1709 remnode(new)=nm
1710 tagn(nn)=1
1711 END IF
1712 END DO !J=
1713 END DO !I =
1714C reset TAGN(NN) =0
1715 DO i = kremn_cp(ii)+1,kremn_cp(ii+1)
1716 ns = remn_cp(i)
1717 IF (pt_e2node(ns,1)==0) cycle
1718 DO j = pt_e2node(ns,1),pt_e2node(ns,2)
1719 nn = e2node(j)
1720 tagn(nn) = 0
1721 END DO !J=
1722 END DO
1723 kremnode(ii+1) = new
1724 END DO !II=1,NRTM
1725 DEALLOCATE(kremn_cp,remn_cp)
1726 END IF !(IFLAG==0) THEN
1727C----6---------------------------------------------------------------7---------8
1728 RETURN
1729 END
1730!||====================================================================
1731!|| ri2_int24p_ini ../starter/source/interfaces/inter3d1/i7remnode.F
1732!||--- called by ------------------------------------------------------
1733!|| inintr ../starter/source/interfaces/interf1/inintr.F
1734!|| inintr2 ../starter/source/interfaces/inter3d1/inintr2.F
1735!||--- calls -----------------------------------------------------
1736!|| fretitl2 ../starter/source/starter/freform.F
1737!|| rm_cand24 ../starter/source/interfaces/inter3d1/i7remnode.F
1738!||--- uses -----------------------------------------------------
1739!||====================================================================
1740 SUBROUTINE ri2_int24p_ini(IPARI ,INTBUF_TAB ,ITAB, NOM_OPT,NREMOV)
1741C-----------------------------------------------
1742C M o d u l e s
1743C-----------------------------------------------
1744 USE my_alloc_mod
1745 USE intbufdef_mod
1746 USE names_and_titles_mod , ONLY : nchartitle
1747C-----------------------------------------------
1748C I m p l i c i t T y p e s
1749C-----------------------------------------------
1750#include "implicit_f.inc"
1751C-----------------------------------------------
1752C A n a l y s e M o d u l e
1753C-----------------------------------------------
1754#include "param_c.inc"
1755C-----------------------------------------------
1756C D u m m y A r g u m e n t s
1757C-----------------------------------------------
1758 INTEGER IPARI(NPARI,*), ITAB(*),NREMOV(*),IFLAG
1759 INTEGER NOM_OPT(LNOPT1,*)
1760
1761 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1762C-----------------------------------------------
1763C C o m m o n B l o c k s
1764C-----------------------------------------------
1765#include "com04_c.inc"
1766#include "scr17_c.inc"
1767C-----------------------------------------------
1768C L o c a l V a r i a b l e s
1769C-----------------------------------------------
1770 INTEGER N,I_STOK,NTY,ID
1771 CHARACTER(LEN=NCHARTITLE) :: TITR
1772C-----------------------------------------------
1773C----remove pene_ini of int24 with Irem_i2
1774C------INTBUF_TAB(N)%CAND_E,INTBUF_TAB(N)%CAND_N
1775 DO N=1,ninter
1776 nty=ipari(7,n)
1777 IF (nty==24.AND.nremov(n) >0) THEN
1778 id=nom_opt(1,n)
1779 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,n),ltitr)
1780 i_stok = intbuf_tab(n)%I_STOK(1)
1781 CALL rm_cand24(i_stok,id,titr,intbuf_tab(n)%CAND_N,intbuf_tab(n)%CAND_E,
1782 + intbuf_tab(n)%KREMNODE,intbuf_tab(n)%REMNODE,
1783 + intbuf_tab(n)%NSV,intbuf_tab(n)%IRTLM,
1784 + intbuf_tab(n)%PENE_OLD,itab )
1785 intbuf_tab(n)%I_STOK(1) = i_stok
1786 END IF
1787 END DO
1788C----
1789 RETURN
1790 END
1791!||====================================================================
1792!|| rm_cand24 ../starter/source/interfaces/inter3d1/i7remnode.F
1793!||--- called by ------------------------------------------------------
1794!|| ri2_int24p_ini ../starter/source/interfaces/inter3d1/i7remnode.F
1795!||--- calls -----------------------------------------------------
1796!|| ancmsg ../starter/source/output/message/message.f
1797!||--- uses -----------------------------------------------------
1798!|| format_mod ../starter/share/modules1/format_mod.F90
1799!|| message_mod ../starter/share/message_module/message_mod.F
1800!||====================================================================
1801 SUBROUTINE rm_cand24(I_STOK,ID,TITR,CAND_N,CAND_E,KREMNODE ,REMNOD ,
1802 * NSV ,IRTLM,PENE_OLD,ITAB )
1803C
1804C-----------------------------------------------
1805C M o d u l e s
1806C-----------------------------------------------
1807 USE my_alloc_mod
1808 USE message_mod
1809 USE names_and_titles_mod , ONLY : nchartitle
1810 USE format_mod , ONLY : fmw_10i
1811C-----------------------------------------------
1812C I m p l i c i t T y p e s
1813C-----------------------------------------------
1814#include "implicit_f.inc"
1815C-----------------------------------------------
1816C C o m m o n B l o c k s
1817C-----------------------------------------------
1818#include "com04_c.inc"
1819#include "scr03_c.inc"
1820#include "units_c.inc"
1821C-----------------------------------------------
1822 INTEGER I_STOK,CAND_E(*),CAND_N(*),KREMNODE(*),IRTLM(2,*),REMNOD(*),
1823 * NSV(*),ID,ITAB(*)
1824 my_real
1825 . PENE_OLD(5,*)
1826 CHARACTER(LEN=NCHARTITLE) :: TITR
1827C-----------------------------------------------
1828C L o c a l V a r i a b l e s
1829C-----------------------------------------------
1830 INTEGER NE, I,NS,NI,I_RM(I_STOK),K,L,J,II_STOK,NRM
1831 INTEGER ITAG(NUMNOD)
1832C REAL
1833C-----------------------------------------------
1834C E x t e r n a l F u n c t i o n s
1835C-----------------------------------------------
1836 DO I=1,i_stok
1837 i_rm(i) = 0
1838 ni = cand_n(i)
1839 ne = cand_e(i)
1840 ns = nsv(ni)
1841 k = kremnode(ne)+1
1842 l = kremnode(ne+1)
1843 DO j=k,l
1844 IF (remnod(j)==ns) THEN
1845 i_rm(i) = 1
1846 cycle
1847 END IF
1848 END DO
1849 END DO
1850C--------reput IRTLM(1,NI)=0,PEN_OLD(5,NI)=0 et compact CAND_N,CAND_E ,I_STOK
1851 ii_stok = 0
1852 DO i=1,i_stok
1853 IF (i_rm(i) == 1) THEN
1854 ni = cand_n(i)
1855 irtlm(1,ni) = 0
1856 pene_old(5,ni)=zero
1857 ELSE
1858 ii_stok = ii_stok+1
1859 cand_n(ii_stok) = cand_n(i)
1860 cand_e(ii_stok) = cand_e(i)
1861 END IF
1862 END DO
1863 nrm = i_stok-ii_stok
1864C ----- message out
1865 IF (nrm >0) THEN
1866 CALL ancmsg(msgid=1637,
1867 . msgtype=msgwarning,
1868 . anmode=aninfo_blind_1,
1869 . i1=id,
1870 . c1=titr,
1871 . i2=nrm)
1872 IF(ipri>=5) THEN
1873 WRITE(iout,*) 'REMOVED SECONDARY NODE WITH INITIAL PENETRATION:'
1874 k = 0
1875 itag(1:numnod)=0
1876 DO i=1,i_stok
1877 IF (i_rm(i) == 1) THEN
1878 ni = cand_n(i)
1879 ns = nsv(ni)
1880 IF (ns <= numnod .AND. itag(ns)==0 ) THEN
1881 k = k + 1
1882 i_rm(k) = ns
1883 itag(ns)=1
1884 END IF
1885 END IF
1886 END DO
1887 WRITE(iout,fmt=fmw_10i) (itab(i_rm(j)),j=1,nrm)
1888 END if!(IPRI>=5) THEN
1889 END IF !(NRM >0) THEN
1890 i_stok= ii_stok
1891C
1892 RETURN
1893 END
if
if(complex_arithmetic) id
freform
subroutine freform(irunn, irfl, irfe, h3d_data, flag_cst_ams, dynain_data, sensors, dt, output, glob_therm)
Definition freform.F:88
remn_i2op_edg25
subroutine remn_i2op_edg25(n, flagremnode, ipari, intbuf_tab, i2node, points_i2n, i2node_size, nom_opt, itab, flag_output)
Definition i25remlin.F:434
dim_iedgn2
subroutine dim_iedgn2(ne2, nsne, is2se, irtse, tagn)
Definition i7remnode.F:495
i7remnode_init
subroutine i7remnode_init(iself_impactant, nty, x, nrtm, irect, nsv, nsn, numnod, itab, gap_s, gap_m, gapmin, gapmax, gap_s_l, gap_m_l, igap, kremnode, remnode, gap, drad, nremnode, ilev, nbinflg, mbinflg, ipari, i_mem_rem, gapm_mx, gaps_mx, gapm_l_mx, gaps_l_mx, knod2seg, nod2seg, tagsecnd, gapsecnd, gap_s_l_tmp, minseg)
Definition i7remnode.F:155
i25remnor
subroutine i25remnor(nrtm, irect, nsv, nsn, numnod, kremnode, remnode, kremnor, remnor, ipari, tagsecnd)
Definition i7remnode.F:327
remn_i2_edgop
subroutine remn_i2_edgop(ipari, intbuf_tab, itab, nremov)
Definition i7remnode.F:1420
insert_a
subroutine insert_a(n, ic, ia, id)
Definition i7remnode.F:396
remn_i2op
subroutine remn_i2op(lower_bound, upper_bound, ipari, intbuf_tab, itab, nom_opt, nremov, iddlevel, skip_type25_edge_2_edge)
Definition i7remnode.F:675
remn_i2_edg
subroutine remn_i2_edg(ipari, intbuf_tab, itab, nremov, iflag)
Definition i7remnode.F:428
add_nsfic1
subroutine add_nsfic1(nrtm, nremov, kremnode, remnode, e2node, pt_e2node, tagn, iflag)
Definition i7remnode.F:1645
ri2_int24p_ini
subroutine ri2_int24p_ini(ipari, intbuf_tab, itab, nom_opt, nremov)
Definition i7remnode.F:1741
ind_iedgn2
subroutine ind_iedgn2(ne2, nsne, is2se, irtse, tagn, iedgn2)
Definition i7remnode.F:538
dim_ptedgn
subroutine dim_ptedgn(nsize, nsne, is2se, irtse, tagn)
Definition i7remnode.F:1506
pre_i2
subroutine pre_i2(ipari, intbuf_tab, nsize, i2node, point_i2node)
Definition i7remnode.F:1234
zeronm_tagd
subroutine zeronm_tagd(is, irect, irtl, tagd)
Definition i7remnode.F:1381
add_nsfic
subroutine add_nsfic(ne2, nrtm, nsne, is2se, nremov, kremnode, remnode, iedgn2, iflag)
Definition i7remnode.F:590
i7remnode
subroutine i7remnode(iremnode, noint, titr, intbuf_tab, numnod, x, nrtm, irect, nsv, nsn, itab, gap_s, gap_m, gapmin, gapmax, gap_s_l, gap_m_l, igap, gap, drad, nremnode, nty, ipari, i_mem_rem, gapm_mx, gaps_mx, gapm_l_mx, gaps_l_mx, ilev, nbinflg, mbinflg, dgapload, npari)
Definition i7remnode.F:43
pre_i2edge
subroutine pre_i2edge(nsize, nsne, is2se, irtse, tagn, e2node, pt_e2node)
Definition i7remnode.F:1552
rm_cand24
subroutine rm_cand24(i_stok, id, titr, cand_n, cand_e, kremnode, remnod, nsv, irtlm, pene_old, itab)
Definition i7remnode.F:1803
inint3
subroutine inint3(inscr, x, ixs, ixc, pm, geo, ipari, nin, itab, ms, mwa, rwa, ixtg, iwrn, ikine, ixt, ixp, ixr, nelemint, iddlevel, ifiend, ale_connectivity, nsnet, nmnet, igrbric, iwcont, nsnt, nmnt, nsn2t, nmn2t, iwcin2, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, igrsurf, ikine1, ielem21, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, nod2el1d, knod2el1d, ixs10, i_mem, resort, inter_cand, ixs16, ixs20, id, titr, iremnode, nremnode, iparts, kxx, ixx, igeo, intercep, lelx, intbuf_tab, fillsol, pm_stack, iworksh, kxig3d, ixig3d, tagprt_fric, intbuf_fric_tab, ipartt, ipartp, ipartx, ipartr, nsn_multi_connec, t2_add_connec, t2_nb_connec, t2_connec, nom_opt, icode, iskew, iremnode_edg, s_append_array, x_append, mass_append, n2d, flag_removed_node, nspmd, inter_type2_number, elem_linked_to_segment, sinscr, sicode, sitab, nin25, flag_elem_inter25, multi_fvm)
Definition inint3.F:144
min
#define min(a, b)
Definition macros.h:20
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
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
main
int main(int argc, char *argv[])
Definition CMakeCCompilerId.c:841
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
starter
program starter
Definition starter.F:39
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29
upgrade_remnode2
subroutine upgrade_remnode2(ni, nremnode, intbuf_tab, nty)
Definition upgrade_remnode.F:112