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

Go to the source code of this file.

Functions/Subroutines

subroutine inintsub_25 (itab, igrnod, igrsurf, nom_opt, intbuf_tab, nrtm, nrtm0, nsn, nisubs, nisubm, noint, ni, nod2nsv, nod2rtm, kad, tagnod, tagrtm, iadd, nsne, nty, nrtse)

Function/Subroutine Documentation

◆ inintsub_25()

subroutine inintsub_25 ( integer, dimension(*) itab,
type (group_), dimension(ngrnod) igrnod,
type (surf_), dimension(nsurf) igrsurf,
integer, dimension(lnopt1,*) nom_opt,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer nrtm,
integer nrtm0,
integer nsn,
integer nisubs,
integer nisubm,
integer noint,
integer ni,
integer, dimension(*) nod2nsv,
integer, dimension(*) nod2rtm,
integer, dimension(*) kad,
integer, dimension(*) tagnod,
integer, dimension(*) tagrtm,
integer, dimension(*) iadd,
integer, intent(in) nsne,
integer, intent(in) nty,
integer, intent(in) nrtse )

Definition at line 37 of file inintsub_25.F.

42
43C-----------------------------------------------
44C M o d u l e s
45C-----------------------------------------------
46 USE message_mod
47 USE intbufdef_mod
48 USE groupdef_mod
49 USE names_and_titles_mod , ONLY : nchartitle
50 USE get_edge_fic_node_mod , ONLY : get_edge_fic_node
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-----------------------------------------------
58#include "scr17_c.inc"
59#include "com04_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER ITAB(*), NOD2NSV(*), NOD2RTM(*), KAD(*), TAGNOD(*), TAGRTM(*),
64 . IADD(*)
65 INTEGER NRTM, NRTM0, NSN, NISUBS, NISUBM, NOINT, NI
66 INTEGER NOM_OPT(LNOPT1,*)
67 INTEGER ,INTENT(IN) :: NSNE, NTY, NRTSE
68
69 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
70C-----------------------------------------------
71C L o c a l V a r i a b l e s
72C-----------------------------------------------
73 INTEGER I,J,K,JGRN,ISU,ISU1,ISU2,
74 . JSUB, KSUB, NNE, IS, ISV, CUR, ID1,
75 . NEXT, IM, KM, JAD, IN, II, N,STAT,K1,K2,NT19,INOD,IFNRT,
76 . IS1,IS2,IS3,IS4,IE,IE1,IE2,NS,ISS1_1,ISS1_2,ISS2_1,ISS2_2,
77 . IGRN_1,IGRN_2,NS1,NS2
78 CHARACTER MESS*40
79 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
80C-----------------------------------------------
81 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
82 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
83 TYPE (SURF_) , DIMENSION(NSLIN) :: IGRSLIN
84C-----------------------------------------------
85C D a t a
86C-----------------------------------------------
87 DATA mess/'SUB-INTERFACES FOR TH INITIALIZATIONS '/
88C-----------------------------------------------
89C E x t e r n a l F u n c t i o n s
90C-----------------------------------------------
91 INTEGER BITSET
92 EXTERNAL bitset
93C
94 INTEGER BITGET
95 EXTERNAL bitget
96C=======================================================================
97
98C
99 intbuf_tab(ni)%ADDSUBS(1:nsn+1) = 0 ! address of different subinter related to secondary node
100 intbuf_tab(ni)%ADDSUBM(1:nrtm+1) = 0 ! address of different subinter related to main segment
101
102 intbuf_tab(ni)%INFLG_SUBS(1:nisubs)=0 ! Flags for determining what is surface Surf1 or Surf2
103 intbuf_tab(ni)%INFLG_SUBM(1:nisubm)=0
104
105C----------------------------------------
106C TAG nodes second calculate addresses
107C---------------------------------------------
108
109 nod2nsv(1:numnod) = 0
110 DO is=1,nsn
111 isv = intbuf_tab(ni)%NSV(is)
112 IF (isv <= numnod) nod2nsv(isv)=is
113 END DO
114C
115 ksub=0
116 DO jsub=1,nintsub
117 id1=nom_opt(1,ninter+jsub)
118 CALL fretitl2(titr1,
119 . nom_opt(lnopt1-ltitr+1,ninter+jsub),ltitr)
120
121C---------Case of subinter defined with inter -------------
122
123 IF(nom_opt(2,ninter+jsub)==noint
124 . .AND.nom_opt(5,ninter+jsub)==1)THEN
125 ksub=ksub+1
126C
127C LISUB(KSUB)=JSUB no interne de la sous-interface
128 intbuf_tab(ni)%LISUB(ksub) = jsub
129 intbuf_tab(ni)%TYPSUB(ksub) = 1
130C
131C prepare ADDSUBS , LISUBS (K31) :
132C LISUBS(ADDSUBS(IS):ADDSUBS(IS+1)-1) SS. INTERF CONTENANT LE ND SECOND. IS
133C
134 tagnod(1:numnod) = 0
135
136 jgrn =nom_opt(4,ninter+jsub) ! GRNOD ID
137 IF(jgrn/=0)THEN
138 nne =igrnod(jgrn)%NENTITY
139 DO i=1,nne
140 in=igrnod(jgrn)%ENTITY(i)
141 is =nod2nsv(in)
142 IF(is==0)THEN
143 CALL ancmsg(msgid=580,
144 . msgtype=msgwarning,
145 . anmode=aninfo_blind_1,
146 . i1=id1,
147 . c1=titr1,
148 . i2=itab(in),
149 . i3=noint)
150 ELSEIF(tagnod(in)==0) THEN ! beware to GRNOD NODENS
151 intbuf_tab(ni)%ADDSUBS(is) =
152 . intbuf_tab(ni)%ADDSUBS(is)+1
153 tagnod(in) = 1
154 END IF
155 END DO
156 END IF
157C
158 isu2 =nom_opt(6,ninter+jsub) ! SURFACE ID 2
159 IF(isu2/=0)THEN
160C
161 isu1 =nom_opt(3,ninter+jsub) ! SURFACE ID 1
162 nne =igrsurf(isu1)%NSEG
163 DO i=1,nne
164 DO j=1,4
165 in = igrsurf(isu1)%NODES(i,j)
166 is = nod2nsv(in)
167 IF (is==0) THEN
168 CALL ancmsg(msgid=580,
169 . msgtype=msgwarning,
170 . anmode=aninfo_blind_1,
171 . i1=id1,
172 . c1=titr1,
173 . i2=itab(in),
174 . i3=noint)
175 ELSEIF (tagnod(in)==0) THEN
176 intbuf_tab(ni)%ADDSUBS(is) = intbuf_tab(ni)%ADDSUBS(is)+1
177 tagnod(in) = 1
178 ENDIF
179 END DO
180 END DO
181
182 nne =igrsurf(isu2)%NSEG
183 DO i=1,nne
184 DO j=1,4
185 in = igrsurf(isu2)%NODES(i,j)
186 is = nod2nsv(in)
187 IF (is==0) THEN
188 CALL ancmsg(msgid=580,
189 . msgtype=msgwarning,
190 . anmode=aninfo_blind_1,
191 . i1=id1,
192 . c1=titr1,
193 . i2=itab(in),
194 . i3=noint)
195 ELSEIF (tagnod(in)==0) THEN
196 intbuf_tab(ni)%ADDSUBS(is) = intbuf_tab(ni)%ADDSUBS(is)+1
197 tagnod(in) = 1
198 ENDIF
199 END DO
200 END DO
201 ENDIF
202
203C
204C---------Case of subinter defined with inter 0 -------------
205C
206 ELSEIF(nom_opt(2,ninter+jsub) == 0
207 . .AND. nom_opt(5,ninter+jsub) == 1) THEN
208
209 ksub=ksub+1
210C
211C LISUB(KSUB)=JSUB no interne de la sous-interface
212 intbuf_tab(ni)%LISUB (ksub) = jsub
213C
214C prepare ADDSUBS , LISUBS (K31) :
215C LISUBS(ADDSUBS(IS):ADDSUBS(IS+1)-1) SS. INTERF CONTENANT LE ND SECOND. IS
216C
217 tagnod(1:numnod) = 0
218
219 isu2 =nom_opt(6,ninter+jsub) ! surface id 2
220 IF(isu2/=0)THEN
221 intbuf_tab(ni)%TYPSUB(ksub) = 2
222 DO i=1,igrsurf(isu2)%NSEG
223 DO k=1,4
224 in=igrsurf(isu2)%NODES(i,k)
225 is =nod2nsv(in)
226 IF(is/=0.AND.tagnod(in)==0) THEN
227 intbuf_tab(ni)%ADDSUBS(is) =
228 . intbuf_tab(ni)%ADDSUBS(is)+1
229 tagnod(in) = 1
230 END IF
231 ENDDO
232 ENDDO
233 ENDIF
234
235 isu1 =nom_opt(3,ninter+jsub) ! SURFACE ID 1
236 IF(isu1/=0)THEN
237 intbuf_tab(ni)%TYPSUB(ksub) = 3
238 DO i=1,igrsurf(isu1)%NSEG
239 DO k=1,4
240 in=igrsurf(isu1)%NODES(i,k)
241 is =nod2nsv(in)
242 IF(is/=0.AND.tagnod(in)==0) THEN
243 intbuf_tab(ni)%ADDSUBS(is) =
244 . intbuf_tab(ni)%ADDSUBS(is)+1
245 tagnod(in) = 1
246 END IF
247 ENDDO
248 ENDDO
249 ENDIF
250C
251C
252 END IF
253
254C
255 IF (nty==24.AND.nsne > 0) THEN ! Case Inter 24 +E2E
256 DO is=1,nsn
257 isv = intbuf_tab(ni)%NSV(is)
258 ns = isv - numnod
259 IF (isv>numnod) THEN
260 CALL get_edge_fic_node(intbuf_tab(ni)%IRTSE , nsne ,intbuf_tab(ni)%IS2SE,intbuf_tab(ni)%IS2PT,
261 . ns , nrtse,is1 , is2 )
262
263 IF(tagnod(is1) == 1.AND.tagnod(is2) == 1) THEN
264 intbuf_tab(ni)%ADDSUBS(is) =
265 . intbuf_tab(ni)%ADDSUBS(is)+1
266 ENDIF
267 ENDIF
268 END DO ! I=1,NSNE
269 ENDIF
270
271
272
273 END DO
274C
275C --------Skyline tabs ADDSUBS-----------
276
277 cur=1
278 DO is=1,nsn
279 next = cur+intbuf_tab(ni)%ADDSUBS(is)
280 intbuf_tab(ni)%ADDSUBS(is)= cur
281 cur = next
282 END DO
283 intbuf_tab(ni)%ADDSUBS(1+nsn)=cur
284C
285C utilise KAD(1:NSN)
286 DO is=1,nsn
287 kad(is)=intbuf_tab(ni)%ADDSUBS(is)
288 END DO
289C
290
291C----------------------------------------
292C Secondary side : After ADRESS STORE SUBINTER in INTBUF_TAB(NI)%LISUBS
293C---------------------------------------------
294 ksub=0
295 DO jsub=1,nintsub
296C
297 IF(nom_opt(2,ninter+jsub)==noint
298 . .AND.nom_opt(5,ninter+jsub)==1)THEN
299 ksub=ksub+1
300C
301C prepare LISUBS :
302C LISUBS(ADDSUBS(IS):ADDSUBS(IS+1)-1) SS. INTERF CONTENANT LE ND SECOND. IS
303C
304 tagnod(1:numnod) = 0
305
306 jgrn =nom_opt(4,ninter+jsub) ! GRNOD ID
307 IF(jgrn/=0)THEN
308 nne =igrnod(jgrn)%NENTITY
309 DO i=1,nne
310 in=igrnod(jgrn)%ENTITY(i)
311 is =nod2nsv(in)
312 IF(is/=0)THEN
313 IF(tagnod(in)==0) THEN ! beware to GRNOD NODENS
314 intbuf_tab(ni)%INFLG_SUBS(kad(is))=
315 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),2)
316 intbuf_tab(ni)%LISUBS(kad(is))=ksub
317 kad(is)=kad(is)+1
318 ELSE
319 intbuf_tab(ni)%INFLG_SUBS(kad(is)-1)=
320 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)-1),2)
321 END IF
322 tagnod(in) = 1
323 END IF
324 END DO
325 ENDIF
326C
327 isu2 =nom_opt(6,ninter+jsub) ! SURFACE ID 2
328 IF(isu2/=0)THEN
329 isu1 =nom_opt(3,ninter+jsub) ! SURFACE ID 1
330 nne =igrsurf(isu1)%NSEG
331 DO i=1,nne
332 DO j=1,4
333 in = igrsurf(isu1)%NODES(i,j)
334 is = nod2nsv(in)
335 IF (is/=0)THEN
336 IF(tagnod(in)==0) THEN
337 intbuf_tab(ni)%INFLG_SUBS(kad(is))=
338 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),0)
339 intbuf_tab(ni)%LISUBS(kad(is))=ksub
340 kad(is)=kad(is)+1
341 tagnod(in) = 1
342 ELSE
343 intbuf_tab(ni)%INFLG_SUBS(kad(is)-1)=
344 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)-1),0)
345 ENDIF
346 ENDIF
347 END DO
348 ENDDO
349
350 nne =igrsurf(isu2)%NSEG
351 DO i=1,nne
352 DO j=1,4
353 in = igrsurf(isu2)%NODES(i,j)
354 is = nod2nsv(in)
355 IF (is/=0)THEN
356 IF(tagnod(in)==0) THEN
357 intbuf_tab(ni)%INFLG_SUBS(kad(is))=
358 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),1)
359 intbuf_tab(ni)%LISUBS(kad(is))=ksub
360 kad(is)=kad(is)+1
361 tagnod(in) = 1
362 ELSE
363 intbuf_tab(ni)%INFLG_SUBS(kad(is)-1)=
364 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)-1),1)
365 ENDIF
366 ENDIF
367 END DO
368 ENDDO
369 ENDIF
370C
371
372C
373C---------Case of subinter defined with inter 0 -------------
374C
375 ELSEIF(nom_opt(2,ninter+jsub) == 0
376 . .AND. nom_opt(5,ninter+jsub) == 1) THEN
377
378 ksub=ksub+1
379C
380C prepare ADDSUBS , LISUBS (K31) :
381C LISUBS(ADDSUBS(IS):ADDSUBS(IS+1)-1) SS. INTERF CONTENANT LE ND SECOND. IS
382C
383 tagnod(1:numnod) = 0
384
385 isu2 =nom_opt(6,ninter+jsub) ! SURFACE ID 2
386 IF(isu2/=0)THEN
387
388 DO i=1,igrsurf(isu2)%NSEG
389 DO k=1,4
390 in=igrsurf(isu2)%NODES(i,k)
391 is =nod2nsv(in)
392 IF (is/=0)THEN
393 IF(tagnod(in)==0) THEN
394 intbuf_tab(ni)%INFLG_SUBS(kad(is))=
395 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),0)
396 intbuf_tab(ni)%LISUBS(kad(is))=ksub
397 kad(is)=kad(is)+1
398 tagnod(in) = 1
399 ELSE
400 intbuf_tab(ni)%INFLG_SUBS(kad(is)-1)=
401 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)-1),0)
402 ENDIF
403 ENDIF
404
405 ENDDO
406 ENDDO
407 ENDIF
408
409 isu1 =nom_opt(3,ninter+jsub) ! SURFACE ID 1
410 IF(isu1/=0)THEN
411
412 DO i=1,igrsurf(isu1)%NSEG
413 DO k=1,4
414 in=igrsurf(isu1)%NODES(i,k)
415 is =nod2nsv(in)
416 IF (is/=0)THEN
417 IF(tagnod(in)==0) THEN
418 intbuf_tab(ni)%INFLG_SUBS(kad(is))=
419 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),1)
420 intbuf_tab(ni)%LISUBS(kad(is))=ksub
421 kad(is)=kad(is)+1
422 tagnod(in) = 1
423 ELSE
424 intbuf_tab(ni)%INFLG_SUBS(kad(is)-1)=
425 . bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)-1),1)
426 ENDIF
427 ENDIF
428 ENDDO
429 ENDDO
430 ENDIF
431
432 END IF
433
434 IF (nty==24.AND.nsne > 0) THEN
435 DO is=1,nsn
436 isv = intbuf_tab(ni)%NSV(is)
437 ns = isv - numnod
438 IF (isv>numnod) THEN
439 CALL get_edge_fic_node(intbuf_tab(ni)%IRTSE , nsne ,intbuf_tab(ni)%IS2SE,intbuf_tab(ni)%IS2PT,
440 . ns , nrtse,is1 , is2 )
441 IF(tagnod(is1) == 1.AND.tagnod(is2)== 1) THEN
442
443 ns1 = nod2nsv(is1)
444 ns2 = nod2nsv(is2)
445
446 iss1_1 = bitget(intbuf_tab(ni)%INFLG_SUBS(kad(ns1)-1),0)
447 iss2_1 = bitget(intbuf_tab(ni)%INFLG_SUBS(kad(ns1)-1),1)
448 igrn_1 = bitget(intbuf_tab(ni)%INFLG_SUBS(kad(ns1)-1),2)
449
450 iss1_2 = bitget(intbuf_tab(ni)%INFLG_SUBS(kad(ns2)-1),0)
451 iss2_2 = bitget(intbuf_tab(ni)%INFLG_SUBS(kad(ns2)-1),1)
452 igrn_2 = bitget(intbuf_tab(ni)%INFLG_SUBS(kad(ns2)-1),2)
453
454
455 IF(iss1_1 == 1.AND.iss1_2== 1) intbuf_tab(ni)%INFLG_SUBS(kad(is)) = bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),0)
456 IF(iss2_1 == 1.AND.iss2_2== 1) intbuf_tab(ni)%INFLG_SUBS(kad(is)) = bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),1)
457 IF(igrn_1 == 1.AND.igrn_2== 1) intbuf_tab(ni)%INFLG_SUBS(kad(is)) = bitset(intbuf_tab(ni)%INFLG_SUBS(kad(is)),2)
458 intbuf_tab(ni)%LISUBS(kad(is))=ksub
459 kad(is)=kad(is)+1
460
461 ENDIF
462 ENDIF
463 END DO
464 ENDIF
465
466
467
468 END DO
469
470
471C----------------------------------------
472C TAG main segments calculate addresses
473C---------------------------------------------
474
475C
476C utilise IADD(1:NUMNOD+1)
477 iadd(1:numnod+1) = 0
478
479 DO im=1,nrtm0
480 in =intbuf_tab(ni)%IRECTM(4*(im-1)+1)
481 iadd(in) =iadd(in)+1
482 in =intbuf_tab(ni)%IRECTM(4*(im-1)+2)
483 iadd(in) =iadd(in)+1
484 in =intbuf_tab(ni)%IRECTM(4*(im-1)+3)
485 iadd(in) =iadd(in)+1
486 in =intbuf_tab(ni)%IRECTM(4*(im-1)+4)
487 iadd(in) =iadd(in)+1
488 END DO
489C
490 cur=1
491 DO i=1,numnod
492 next =cur+iadd(i)
493 iadd(i) =cur
494 cur =next
495 END DO
496 iadd(numnod+1)=cur
497C
498C utilise KAD(NUMNOD)
499 DO i=1,numnod
500 kad(i)=iadd(i)
501 END DO
502C
503C utilise NOD2RTM(4*NRTM0)
504 DO im=1,nrtm0
505 in =intbuf_tab(ni)%IRECTM(4*(im-1)+1)
506 nod2rtm(kad(in)) = im
507 kad(in) = kad(in) + 1
508 in =intbuf_tab(ni)%IRECTM(4*(im-1)+2)
509 nod2rtm(kad(in)) = im
510 kad(in) = kad(in) + 1
511 in =intbuf_tab(ni)%IRECTM(4*(im-1)+3)
512 nod2rtm(kad(in)) = im
513 kad(in) = kad(in) + 1
514 in =intbuf_tab(ni)%IRECTM(4*(im-1)+4)
515 nod2rtm(kad(in)) = im
516 kad(in) = kad(in) + 1
517 ENDDO
518
519C
520C prepare ADDSUBM :
521 ksub=0
522 DO jsub=1,nintsub
523 id1=nom_opt(1,ninter+jsub)
524 CALL fretitl2(titr1,
525 . nom_opt(lnopt1-ltitr+1,ninter+jsub),ltitr)
526
527 IF(nom_opt(2,ninter+jsub)==noint
528 . .AND.nom_opt(5,ninter+jsub)==1)THEN
529 ksub=ksub+1
530C
531 tagrtm(1:nrtm0) = 0
532C
533 isu1 =nom_opt(3,ninter+jsub)
534 nne =igrsurf(isu1)%NSEG
535 DO i=1,nne
536 in=igrsurf(isu1)%NODES(i,1)
537 km=0
538
539 DO 310 jad=iadd(in),iadd(in+1)-1
540 im = nod2rtm(jad)
541 DO 300 j=1,4
542 ii=igrsurf(isu1)%NODES(i,j)
543 IF(j==4.AND.ii==0)THEN
544 GO TO 300
545 ELSE
546 DO k=1,4
547 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) GOTO 300
548 END DO
549 GOTO 310
550 END IF
551 300 CONTINUE
552 km=im
553 GO TO 320
554 310 CONTINUE
555 320 CONTINUE
556
557
558 IF(km==0)THEN
559 CALL ancmsg(msgid=581,
560 . msgtype=msgwarning,
561 . anmode=aninfo_blind_1,
562 . i1=id1,
563 . c1=titr1,
564 . i2=itab(igrsurf(isu1)%NODES(i,1)),
565 . i3=itab(igrsurf(isu1)%NODES(i,2)),
566 . i4=itab(igrsurf(isu1)%NODES(i,3)),
567 . i5=itab(igrsurf(isu1)%NODES(i,4)),
568 . i6=noint)
569 ELSEIF(tagrtm(km)==0)THEN
570 intbuf_tab(ni)%ADDSUBM(km)=intbuf_tab(ni)%ADDSUBM(km)+1
571 tagrtm(km)=1
572 END IF
573 END DO
574C
575 isu2 =nom_opt(6,ninter+jsub)
576 IF(isu2/=0)THEN
577 nne =igrsurf(isu2)%NSEG
578 DO i=1,nne
579 in=igrsurf(isu2)%NODES(i,1)
580 km=0
581 DO 360 jad=iadd(in),iadd(in+1)-1
582 im = nod2rtm(jad)
583 DO 350 j=1,4
584 ii=igrsurf(isu2)%NODES(i,j)
585 IF(j==4.AND.ii==0)THEN
586 GO TO 350
587 ELSE
588 DO k=1,4
589 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) GOTO 350
590 END DO
591 GOTO 360
592 END IF
593 350 CONTINUE
594 km=im
595 GO TO 370
596 360 CONTINUE
597 370 CONTINUE
598
599 IF(km==0)THEN
600 CALL ancmsg(msgid=581,
601 . msgtype=msgwarning,
602 . anmode=aninfo_blind_1,
603 . i1=id1,
604 . c1=titr1,
605 . i2=itab(igrsurf(isu2)%NODES(i,1)),
606 . i3=itab(igrsurf(isu2)%NODES(i,2)),
607 . i4=itab(igrsurf(isu2)%NODES(i,3)),
608 . i5=itab(igrsurf(isu2)%NODES(i,4)),
609 . i6=noint)
610 ELSEIF(tagrtm(km)==0)THEN
611 intbuf_tab(ni)%ADDSUBM(km)=intbuf_tab(ni)%ADDSUBM(km)+1
612 tagrtm(km)=1
613 END IF
614 END DO
615 END IF
616C
617C
618
619
620C
621C---------Case of subinter defined with inter 0 -------------
622C
623 ELSEIF(nom_opt(2,ninter+jsub) == 0
624 . .AND. nom_opt(5,ninter+jsub) == 1) THEN
625
626 ksub=ksub+1
627C
628 tagrtm(1:nrtm0) = 0
629C
630 isu1 =nom_opt(3,ninter+jsub)
631
632 IF(isu1 > 0 ) THEN
633
634 nne =igrsurf(isu1)%NSEG
635 DO i=1,nne
636 in=igrsurf(isu1)%NODES(i,1)
637 km=0
638
639 DO jad=iadd(in),iadd(in+1)-1
640 im = nod2rtm(jad)
641 ifnrt = 0
642 DO j=1,4
643 ii=igrsurf(isu1)%NODES(i,j)
644 IF(j/=4.OR.ii/=0)THEN
645 DO k=1,4
646 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) ifnrt = ifnrt + 1
647 END DO
648 ENDIF
649 ENDDO
650 IF(ifnrt >= 3) THEN
651 km=im
652 EXIT
653 ENDIF
654 ENDDO
655
656 IF(km/=0)THEN
657 IF(tagrtm(km)==0)THEN
658 intbuf_tab(ni)%ADDSUBM(km)=intbuf_tab(ni)%ADDSUBM(km)+1
659 tagrtm(km)=1
660 ENDIF
661 END IF
662 END DO
663 ENDIF
664C
665 isu2 =nom_opt(6,ninter+jsub)
666
667 IF(isu2 > 0 ) THEN
668
669 nne =igrsurf(isu2)%NSEG
670 DO i=1,nne
671 in=igrsurf(isu2)%NODES(i,1)
672 km=0
673
674 DO jad=iadd(in),iadd(in+1)-1
675 im = nod2rtm(jad)
676 ifnrt = 0
677 DO j=1,4
678 ii=igrsurf(isu2)%NODES(i,j)
679 IF(j/=4.OR.ii/=0)THEN
680 DO k=1,4
681 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) ifnrt = ifnrt + 1
682 END DO
683 ENDIF
684 ENDDO
685 IF(ifnrt >= 3) THEN
686 km=im
687 EXIT
688 ENDIF
689 ENDDO
690
691 IF(km/=0)THEN
692 IF(tagrtm(km)==0) THEN
693 intbuf_tab(ni)%ADDSUBM(km)=intbuf_tab(ni)%ADDSUBM(km)+1
694 tagrtm(km)=1
695 ENDIF
696 END IF
697 END DO
698 ENDIF
699C
700 END IF
701
702 END DO
703C
704 cur=1
705 DO im=1,nrtm0
706 next =cur+intbuf_tab(ni)%ADDSUBM(im)
707 intbuf_tab(ni)%ADDSUBM(im)=cur
708 cur =next
709 END DO
710 intbuf_tab(ni)%ADDSUBM(nrtm0+1:nrtm+1)=cur
711C
712C utilise KAD(1:NRTM0)
713 DO im=1,nrtm0
714 kad(im)=intbuf_tab(ni)%ADDSUBM(im)
715 END DO
716C
717C prepare LISUBM :
718C LISUBM(ADDSUBM(IM):ADDSUBM(IM+1)-1) SS. INTERF CONTENANT LE SEG.MAIN IM
719 ksub=0
720 DO jsub=1,nintsub
721 IF(nom_opt(2,ninter+jsub)==noint
722 . .AND.nom_opt(5,ninter+jsub)==1)THEN
723 ksub=ksub+1
724C
725 tagrtm(1:nrtm0) = 0
726C
727 isu1 =nom_opt(3,ninter+jsub)
728 nne =igrsurf(isu1)%NSEG
729 DO i=1,nne
730 in=igrsurf(isu1)%NODES(i,1)
731 km=0
732 DO 410 jad=iadd(in),iadd(in+1)-1
733 im = nod2rtm(jad)
734 DO 400 j=1,4
735 ii=igrsurf(isu1)%NODES(i,j)
736 IF(j==4.AND.ii==0)THEN
737 GO TO 400
738 ELSE
739 DO k=1,4
740 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) GOTO 400
741 END DO
742 GOTO 410
743 END IF
744 400 CONTINUE
745 km=im
746 GOTO 420
747 410 CONTINUE
748 420 CONTINUE
749 IF(km/=0)THEN
750 IF(tagrtm(im)==0)THEN
751 intbuf_tab(ni)%INFLG_SUBM(kad(im))=
752 . bitset(intbuf_tab(ni)%INFLG_SUBM(kad(im)),0)
753 intbuf_tab(ni)%LISUBM(kad(im))=ksub
754 kad(im)=kad(im)+1
755 tagrtm(im)=1
756C ELSE
757C INTBUF_TAB(NI)%INFLG_SUBM(KAD(IM)-1)=
758C . BITSET(INTBUF_TAB(NI)%INFLG_SUBM(KAD(IM)-1),0)
759 END IF
760 END IF
761 END DO
762
763 isu2 =nom_opt(6,ninter+jsub)
764 IF(isu2/=0)THEN
765 nne =igrsurf(isu2)%NSEG
766 DO i=1,nne
767 in=igrsurf(isu2)%NODES(i,1)
768 km=0
769 DO 460 jad=iadd(in),iadd(in+1)-1
770 im = nod2rtm(jad)
771 DO 450 j=1,4
772 ii=igrsurf(isu2)%NODES(i,j)
773 IF(j==4.AND.ii==0)THEN
774 GO TO 450
775 ELSE
776 DO k=1,4
777 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) GOTO 450
778 END DO
779 GOTO 460
780 END IF
781 450 CONTINUE
782 km=im
783 GOTO 470
784 460 CONTINUE
785 470 CONTINUE
786 IF(km/=0)THEN
787 IF(tagrtm(im)==0)THEN
788 intbuf_tab(ni)%INFLG_SUBM(kad(im))=
789 . bitset(intbuf_tab(ni)%INFLG_SUBM(kad(im)),1)
790 intbuf_tab(ni)%LISUBM(kad(im))=ksub
791 kad(im)=kad(im)+1
792 tagrtm(im)=1
793 ELSE
794 intbuf_tab(ni)%INFLG_SUBM(kad(im)-1)=
795 . bitset(intbuf_tab(ni)%INFLG_SUBM(kad(im)-1),1)
796 END IF
797 END IF
798 END DO
799 END IF
800
801
802
803C
804C---------Case of subinter defined with inter 0 -------------
805C
806 ELSEIF(nom_opt(2,ninter+jsub) == 0
807 . .AND. nom_opt(5,ninter+jsub) == 1) THEN
808
809 ksub=ksub+1
810C
811 tagrtm(1:nrtm0) = 0
812C
813
814 isu1 =nom_opt(3,ninter+jsub)
815 IF(isu1 > 0 ) THEN
816
817 nne =igrsurf(isu1)%NSEG
818 DO i=1,nne
819 in=igrsurf(isu1)%NODES(i,1)
820 km=0
821
822 DO jad=iadd(in),iadd(in+1)-1
823 im = nod2rtm(jad)
824 ifnrt = 0
825 DO j=1,4
826 ii=igrsurf(isu1)%NODES(i,j)
827 IF(j/=4.OR.ii/=0)THEN
828 DO k=1,4
829 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) ifnrt = ifnrt + 1
830 END DO
831 ENDIF
832 ENDDO
833 IF(ifnrt >= 3) THEN
834 km=im
835 EXIT
836 ENDIF
837 ENDDO
838
839 IF(km/=0)THEN
840 IF(tagrtm(im)==0)THEN
841 intbuf_tab(ni)%INFLG_SUBM(kad(im))=
842 . bitset(intbuf_tab(ni)%INFLG_SUBM(kad(im)),1)
843 intbuf_tab(ni)%LISUBM(kad(im))=ksub
844 kad(im)=kad(im)+1
845 tagrtm(im)=1
846 ENDIF
847 END IF
848
849 END DO
850C
851 ENDIF
852C
853 isu2 =nom_opt(6,ninter+jsub)
854 IF(isu2 > 0 ) THEN
855
856 nne =igrsurf(isu2)%NSEG
857 DO i=1,nne
858 in=igrsurf(isu2)%NODES(i,1)
859 km=0
860
861 DO jad=iadd(in),iadd(in+1)-1
862 im = nod2rtm(jad)
863 ifnrt = 0
864 DO j=1,4
865 ii=igrsurf(isu2)%NODES(i,j)
866 IF(j/=4.OR.ii/=0)THEN
867 DO k=1,4
868 IF(intbuf_tab(ni)%IRECTM(4*(im-1)+k)==ii) ifnrt = ifnrt + 1
869 END DO
870 ENDIF
871 ENDDO
872 IF(ifnrt >= 3) THEN
873 km=im
874 EXIT
875 ENDIF
876 ENDDO
877
878 IF(km/=0)THEN
879 IF(tagrtm(im)==0)THEN
880 intbuf_tab(ni)%INFLG_SUBM(kad(im))=
881 . bitset(intbuf_tab(ni)%INFLG_SUBM(kad(im)),0)
882 intbuf_tab(ni)%LISUBM(kad(im))=ksub
883 kad(im)=kad(im)+1
884 tagrtm(im)=1
885 ELSE
886 intbuf_tab(ni)%INFLG_SUBM(kad(im)-1)=
887 . bitset(intbuf_tab(ni)%INFLG_SUBM(kad(im)-1),0)
888 END IF
889 END IF
890
891 END DO
892C
893 ENDIF
894C
895 END IF
896 END DO
897C-------------------------------------
898 RETURN
bitget
integer function bitget(i, n)
Definition bitget.F:37
bitset
integer function bitset(i, n)
Definition bitget.F:66
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
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
tagnod
subroutine tagnod(ix, nix, nix1, nix2, numel, iparte, tagbuf, npart)
Definition tagnod.F:29