OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i20surfi.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!|| i20surfi ../starter/source/interfaces/inter3d1/i20surfi.F
25!||--- called by ------------------------------------------------------
26!|| lecins ../starter/source/interfaces/interf1/lecins.F
27!|| lecint ../starter/source/interfaces/interf1/lecint.F
28!||--- calls -----------------------------------------------------
29!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
30!|| i20bord ../starter/source/interfaces/inter3d1/i20surfi.F
31!|| i20edge1 ../starter/source/interfaces/inter3d1/i20surfi.F
32!||--- uses -----------------------------------------------------
33!|| format_mod ../starter/share/modules1/format_mod.F90
34!||====================================================================
35 SUBROUTINE i20surfi(IALLO ,IPARI ,IGRNOD ,IGRSURF ,
36 2 IGRSLIN ,IRECT ,FRIGAP ,
37 3 NSV ,MSR ,IXLINS ,IXLINM ,
38 4 NSVE ,MSRE ,ITAB ,ISLINS ,
39 5 ISLINM ,NLG ,X ,NBINFLG ,
40 6 MBINFLG )
41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE groupdef_mod
45 USE format_mod , ONLY : fmw_10i, fmw_4i, fmw_5i, fmw_i_3f
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "com04_c.inc"
54#include "units_c.inc"
55#include "param_c.inc"
56#include "scr03_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER IALLO
61 INTEGER IPARI(NPARI),
62 . IRECT(4,*), NSV(*),IXLINS(2,*),
63 . IXLINM(2,*),MSR(*),ITAB(*),NSVE(*),MSRE(*),
64 . ISLINS(2,*),ISLINM(2,*),NLG(*),NBINFLG(*),MBINFLG(*)
65 my_real x(3,*),frigap(*)
66C-----------------------------------------------
67 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
68 TYPE (SURF_) , DIMENSION(NSURF) :: IGRSURF
69 TYPE (SURF_) , DIMENSION(NSLIN) :: IGRSLIN
70C-----------------------------------------------
71C L o c a l V a r i a b l e s
72C-----------------------------------------------
73 INTEGER I,J,K,L,LL,NL,ISU1,ISU2,NOD1,NRTM,NRTS,NSN,NMN,
74 . nlinsa,nlinma,isym,iedge,nsne,nmne,nln,
75 . nlins,nlinm,line1,line2,stat,il,ig
76 INTEGER TAG(NUMNOD),TAGS(NUMNOD),NEXTK(4),IWORK(70000),
77 . LNTAG(NUMNOD),TAGB(NUMNOD)
78 my_real edg_cos
79 DATA nextk/1,1,1,-3/
80C-----------------------------------------------
81C E x t e r n a l F u n c t i o n s
82C-----------------------------------------------
83 INTEGER BITSET
84 EXTERNAL bitset
85C
86 CHARACTER MESS*40
87 DATA MESS/'INTERFACE INPUT '/
88 l = 0
89 nsn = 0
90 nmn = 0
91 nrtm = 0
92 nrts = 0
93 nlins = 0
94 nlinm = 0
95 nlinsa= 0
96 nlinma= 0
97 nsne = 0
98 nmne = 0
99 nod1 = ipari(26)
100 nln = 0
101 isym = ipari(43)
102 isu1 = ipari(45)
103 isu2 = ipari(46)
104 iedge = ipari(58)
105 line1 = ipari(59)
106 line2 = ipari(60)
107 edg_cos = frigap(26)
108C=======================================================================
109c SURFACES
110C=======================================================================
111c-----------------------------------------------------------------
112c surface S1
113c-----------------------------------------------------------------
114 IF(isu1 /= 0) nrtm = igrsurf(isu1)%NSEG
115c-----------------------------------------------------------------
116c surface S2
117c-----------------------------------------------------------------
118 IF(isu2 /= 0) nrts = igrsurf(isu2)%NSEG
119
120 IF(isym == 1) nrtm = nrtm + nrts
121
122c---------------------------------------
123c copie des surfaces (IALLO == 2)
124c---------------------------------------
125 IF(iallo == 2)THEN
126 IF(isu1 /= 0)THEN
127 l = 0
128 DO j=1,igrsurf(isu1)%NSEG
129 l = l+1
130 DO k=1,4
131 irect(k,l) = igrsurf(isu1)%NODES(j,k)
132 ENDDO
133 mbinflg(l) = bitset(mbinflg(l),0)
134 ENDDO
135 ENDIF
136 IF(isu2 /= 0 .and. isym == 1)THEN
137 DO j=1,igrsurf(isu2)%NSEG
138 l = l+1
139 DO k=1,4
140 irect(k,l) = igrsurf(isu2)%NODES(j,k)
141 ENDDO
142 mbinflg(l) = bitset(mbinflg(l),1)
143 ENDDO
144 ENDIF
145 IF(ipri>=1) THEN
146 WRITE(iout,'(/,A,/)')' SEGMENTS USED FOR SURFACE DEFINITION'
147 DO i=1,nrtm
148 WRITE(iout,fmt=fmw_4i)(itab(irect(k,i)),k=1,4)
149 ENDDO
150 ENDIF
151 ENDIF
152C=======================================================================
153c NOEUDS
154C=======================================================================
155c-----------------------------------------------------------------
156c tag noeuds surfaces S1 S2
157c-----------------------------------------------------------------
158 DO i=1,numnod
159 tag(i)=0 ! initialisation
160 tags(i)=0 ! initialisation
161 tagb(i)=0 ! initialisation
162 lntag(i)=0 ! initialisation
163 ENDDO
164 IF(isu2 /= 0)THEN
165 DO j=1,igrsurf(isu2)%NSEG
166 DO k=1,4
167 tag(igrsurf(isu2)%NODES(j,k)) = 2
168 lntag(igrsurf(isu2)%NODES(j,k)) = 1
169 ENDDO
170 ENDDO
171 ENDIF
172 IF(isu1 /= 0)THEN
173 DO j=1,igrsurf(isu1)%NSEG
174 DO k=1,4
175 i=igrsurf(isu1)%NODES(j,k)
176 IF(tag(i) == 0)THEN
177 tag(i) = 1
178 ELSEIF(tag(i) == 2)THEN
179 tag(i) = 3
180 ENDIF
181 lntag(i) = 1
182 ENDDO
183 ENDDO
184 ENDIF
185c-----------------------------------------------------------------
186c noeuds de la surface S2
187c-----------------------------------------------------------------
188 IF(isu2 /= 0)THEN
189 DO j=1,igrsurf(isu2)%NSEG
190 DO k=1,4
191 i=igrsurf(isu2)%NODES(j,k)
192 IF(tag(i) == 2 .and. isym == 1)THEN
193 nmn = nmn + 1
194 IF(iallo == 2)msr(nmn) = i
195 tagb(i) = bitset(tagb(i),4)
196 ENDIF
197 IF(tag(i) == 2 .or. tag(i) == 3)THEN
198 tag(i) = - tag(i)
199 tags(i) = 1
200 nsn = nsn + 1
201 IF(iallo == 2)nsv(nsn) = i
202 tagb(i) = bitset(tagb(i),1)
203 ENDIF
204 ENDDO
205 ENDDO
206 ENDIF
207c-----------------------------------------------------------------
208c noeuds de la surface S1 si ISYM /= 2
209c-----------------------------------------------------------------
210 IF(isu1 /= 0)THEN
211 DO j=1,igrsurf(isu1)%NSEG
212 DO k=1,4
213 i=igrsurf(isu1)%NODES(j,k)
214 IF(tag(i) == 1 .and.
215 . (isym == 1 .or. (isym == 0 .and. isu2 == 0))) THEN
216 tags(i) = 1
217 nsn = nsn + 1
218 IF(iallo == 2)nsv(nsn) = i
219 tagb(i) = bitset(tagb(i),0)
220 ENDIF
221 IF(tag(i) == 1 .or. tag(i) == -3)THEN
222 tag(i) = - tag(i)
223 nmn = nmn + 1
224 IF(iallo == 2)msr(nmn) = i
225 tagb(i) = bitset(tagb(i),3)
226 ENDIF
227 ENDDO
228 ENDDO
229 ENDIF
230c-----------------------------------------------------------------
231c noeuds du groupe de noeud NOD1
232c-----------------------------------------------------------------
233 IF(nod1 /= 0)THEN
234 DO j=1,igrnod(nod1)%NENTITY
235 i = igrnod(nod1)%ENTITY(j)
236 lntag(i) = 1
237 IF(tags(i) == 0)THEN
238 tags(i) = 1
239 nsn = nsn+1
240 IF(iallo == 2) nsv(nsn) = i
241 tagb(i) = bitset(tagb(i),2)
242 ENDIF
243 ENDDO
244 ENDIF
245
246 IF(iallo == 2 .and. ipri >= 1) THEN
247 WRITE(iout,'(/,A,/)')' NODES USED FOR SURFACE DEFINITION'
248 WRITE(iout,fmt=fmw_10i)(itab(nsv(i)),i=1,nsn)
249 ENDIF
250C=======================================================================
251c EDGES
252C=======================================================================
253 IF(iedge /= 0)THEN
254 CALL i20edge1(iallo ,igrsurf(isu1)%NSEG ,igrslin(max(1,line1))%NSEG ,nlinm ,nlinma ,
255 2 ixlinm ,msre ,nmne ,iedge ,
256 3 igrsurf(isu1)%NODES,igrslin(max(1,line1))%NODES ,itab ,
257 4 islinm ,x ,edg_cos ,lntag ,
258 5 tagb ,5 ,isu1 ,line1 )
259 CALL i20edge1(iallo ,igrsurf(isu2)%NSEG ,igrslin(max(1,line2))%NSEG ,nlins ,nlinsa ,
260 2 ixlins ,nsve ,nsne ,iedge ,
261 3 igrsurf(isu2)%NODES,igrslin(max(1,line2))%NODES ,itab ,
262 4 islins ,x ,edg_cos ,lntag ,
263 5 tagb ,6 ,isu2 ,line2 )
264 ENDIF
265C=======================================================================
266c BORDS POUR CORRECTION GAP=0 sur bord de coque
267C=======================================================================
268 IF(iallo == 2)THEN
269 IF(isu1 /= 0)THEN
270 CALL i20bord(igrsurf(isu1)%NSEG ,igrsurf(isu1)%NODES, tagb,isu1)
271 ENDIF
272 IF(isu2 /= 0 .and. isu2 /= isu1)THEN
273 CALL i20bord(igrsurf(isu2)%NSEG ,igrsurf(isu2)%NODES, tagb,isu2)
274 ENDIF
275 ENDIF
276c-----------------------------------------------------------------
277c nombre de noeuds dans l'interface(secnd+main+edge)
278c-----------------------------------------------------------------
279 IF(iallo == 1)THEN
280 DO i=1,numnod
281 IF(lntag(i)==1)THEN
282 nln=nln+1
283 ENDIF
284 ENDDO
285 ELSEIF(iallo == 2)THEN
286 nln = ipari(35)
287 j=0
288 DO i=1,numnod
289 IF(lntag(i)==1)THEN
290 j=j+1
291 nlg(j) = i
292 nbinflg(j) = tagb(i)
293 ENDIF
294 ENDDO
295 ENDIF
296
297 ipari(3) = 0
298 ipari(4) = nrtm
299 ipari(5) = nsn
300 ipari(6) = nmn
301 ipari(35) = nln
302 ipari(51) = nlins
303 ipari(52) = nlinm
304 ipari(53) = nlinsa
305 ipari(54) = nlinma
306 ipari(55) = nsne
307 ipari(56) = nmne
308
309
310 RETURN
311 END
312
313
314
315
316
317!||====================================================================
318!|| i20edge1 ../starter/source/interfaces/inter3d1/i20surfi.F
319!||--- called by ------------------------------------------------------
320!|| i20surfi ../starter/source/interfaces/inter3d1/i20surfi.F
321!||--- calls -----------------------------------------------------
322!|| ancmsg ../starter/source/output/message/message.F
323!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
324!||--- uses -----------------------------------------------------
325!|| format_mod ../starter/share/modules1/format_mod.F90
326!|| message_mod ../starter/share/message_module/message_mod.F
327!||====================================================================
328 SUBROUTINE i20edge1(IALLO ,NSEG0 ,NLIN0 ,NLIN ,NACTIF ,
329 2 IXLINE ,MSVE ,NSME ,IEDGE ,
330 3 SURF_NODES,SLIN_NODES,ITAB ,
331 4 ISLINE ,X ,EDG_COS ,LNTAG ,
332 5 TAGB ,NB ,ISU ,LIN )
333C-----------------------------------------------
334C M o d u l e s
335C-----------------------------------------------
336 USE message_mod
337 USE format_mod , ONLY : fmw_4i
338C-----------------------------------------------
339C I m p l i c i t T y p e s
340C-----------------------------------------------
341#include "implicit_f.inc"
342C-----------------------------------------------
343C C o m m o n B l o c k s
344C-----------------------------------------------
345#include "com04_c.inc"
346#include "units_c.inc"
347#include "scr03_c.inc"
348C-----------------------------------------------
349C D u m m y A r g u m e n t s
350C-----------------------------------------------
351 INTEGER IALLO,NSEG0,NLIN0,NLIN,NACTIF,IEDGE,NSME,NB,ISU,LIN
352 INTEGER IXLINE(2,*),ITAB(*),MSVE(*),
353 . LNTAG(*) ,TAGB(*),ISLINE(2,*),SURF_NODES(NSEG0,4),
354 . SLIN_NODES(NLIN0,2)
355 my_real X(3,*),EDG_COS
356C-----------------------------------------------
357C L o c a l V a r i a b l e s
358C-----------------------------------------------
359 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,NL,IS
360 INTEGER NEXTK(4),IWORK(70000),NLL
361 my_real nx,ny,nz,mx,my,mz,aaa,d1x,d1y,d1z,d2x,d2y,d2z
362 INTEGER, DIMENSION(:,:), ALLOCATABLE :: LINEIX,LINEIX2,IXWORK
363 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX,TAG
364 my_real, DIMENSION(:,:), ALLOCATABLE :: xlineix
365
366 INTEGER BITSET
367 EXTERNAL BITSET
368
369 DATA nextk/2,3,4,1/
370C=======================================================================
371 nlmax = 0
372 IF(isu /= 0) nlmax = 4*nseg0
373
374 ALLOCATE (lineix(2,nlmax) ,stat=stat)
375 ALLOCATE (lineix2(2,nlmax) ,stat=stat)
376 ALLOCATE (xlineix(3,nlmax) ,stat=stat)
377 ALLOCATE (index(2*nlmax) ,stat=stat)
378 ALLOCATE (tag(numnod) ,stat=stat)
379 ALLOCATE (ixwork(5,nlmax) ,stat=stat)
380
381 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
382 . msgtype=msgerror,
383 . c1='LINEIX')
384
385c---------------------------------------
386c recherche de toutes les lignes dans la surface
387c---------------------------------------
388 IF(isu /= 0)THEN
389 is = 0
390 ll = 0
391 DO j=1,nseg0
392 is = is+1
393 i1=surf_nodes(j,1)
394 i2=surf_nodes(j,2)
395 i3=surf_nodes(j,3)
396 i4=surf_nodes(j,4)
397 d1x = x(1,i3) - x(1,i1)
398 d1y = x(2,i3) - x(2,i1)
399 d1z = x(3,i3) - x(3,i1)
400 d2x = x(1,i4) - x(1,i2)
401 d2y = x(2,i4) - x(2,i2)
402 d2z = x(3,i4) - x(3,i2)
403 nx = d1y * d2z - d1z * d2y
404 ny = d1z * d2x - d1x * d2z
405 nz = d1x * d2y - d1y * d2x
406 aaa = one/max(sqrt(nx*nx+ny*ny+nz*nz),em20)
407 nx = nx * aaa
408 ny = ny * aaa
409 nz = nz * aaa
410 DO k=1,4
411 i1=surf_nodes(j,k)
412 i2=surf_nodes(j,nextk(k))
413 ll = ll+1
414 IF(i2 > i1)THEN
415 lineix(1,ll) = i1
416 lineix(2,ll) = i2
417 lineix2(1,ll) = j
418 lineix2(2,ll) = k
419 ELSE
420c LINEIX(1,LL) = I1
421c LINEIX(2,LL) = I2
422 lineix(1,ll) = i2
423 lineix(2,ll) = i1
424 lineix2(1,ll) = j
425 lineix2(2,ll) = -k
426 ENDIF
427 xlineix(1,ll) = nx
428 xlineix(2,ll) = ny
429 xlineix(3,ll) = nz
430 ENDDO
431 ENDDO
432C
433 CALL my_orders(0,iwork,lineix,index,ll,2)
434
435c---------------------------------------
436c suppression des lignes doubles
437c + calcul des angles(sin) inter-facettes
438c---------------------------------------
439 i1m = lineix(1,index(1))
440 i2m = lineix(2,index(1))
441 nl = 1
442 ixwork(1,nl)=i1m
443 ixwork(2,nl)=i2m
444 ixwork(3,nl)=lineix2(1,index(1))
445 ixwork(4,nl)=lineix2(2,index(1))
446 ixwork(5,nl)=1
447 mx = xlineix(1,index(1))
448 my = xlineix(2,index(1))
449 mz = xlineix(3,index(1))
450 DO l=2,ll
451 i1 = lineix(1,index(l))
452 i2 = lineix(2,index(l))
453 nx = xlineix(1,index(l))
454 ny = xlineix(2,index(l))
455 nz = xlineix(3,index(l))
456 IF(i2 /= i2m .or. i1 /= i1m)THEN
457 nl = nl + 1
458 ixwork(1,nl)=i1
459 ixwork(2,nl)=i2
460 ixwork(3,nl)=lineix2(1,index(l))
461 ixwork(4,nl)=lineix2(2,index(l))
462 ixwork(5,nl)=1 ! bord
463 ELSE
464 ixwork(5,nl)=0 ! interne
465 aaa = nx*mx + ny * my + nz * mz
466 IF (aaa < edg_cos) ixwork(5,nl) = -1 ! arte vive
467 ENDIF
468 i1m = i1
469 i2m = i2
470 mx = nx
471 my = ny
472 mz = nz
473 ENDDO
474
475c---------------------------------------
476c suppression des lignes internes (IEDGE == 1)
477c---------------------------------------
478 ll = nl
479 nl = 0
480 IF(iedge == 1)THEN
481c seuls les bords sont conservs
482 DO l=1,ll
483 IF(ixwork(5,l) == 1)THEN
484 nl = nl + 1
485 i1=ixwork(1,nl)
486 i2=ixwork(2,nl)
487 i3=ixwork(3,nl)
488 i4=ixwork(4,nl)
489 i5=ixwork(5,nl)
490 ixwork(1,nl)=ixwork(1,l)
491 ixwork(2,nl)=ixwork(2,l)
492 ixwork(3,nl)=ixwork(3,l)
493 ixwork(4,nl)=ixwork(4,l)
494 ixwork(5,nl)=1 ! bord on
495 ixwork(1,l)=i1
496 ixwork(2,l)=i2
497 ixwork(3,l)=i3
498 ixwork(4,l)=i4
499 ixwork(5,l)=i5
500 ENDIF
501 ENDDO
502 ELSEIF(iedge == 2)THEN
503c toutes les lignes sont conserves ET actives
504 DO l=1,ll
505 nl = nl + 1
506 ixwork(5,l)=1 ! all on
507 ENDDO
508 ELSEIF(iedge == 3)THEN
509c les bords sont conservs
510c les artes vives sont conservs (EDG_COS)
511 DO l=1,ll
512 IF(iabs(ixwork(5,l)) == 1)THEN
513 nl = nl + 1
514 i1=ixwork(1,nl)
515 i2=ixwork(2,nl)
516 i3=ixwork(3,nl)
517 i4=ixwork(4,nl)
518 i5=iabs(ixwork(5,nl))
519 ixwork(1,nl)=ixwork(1,l)
520 ixwork(2,nl)=ixwork(2,l)
521 ixwork(3,nl)=ixwork(3,l)
522 ixwork(4,nl)=ixwork(4,l)
523 ixwork(5,nl)=1 ! bord on
524 ixwork(1,l)=i1
525 ixwork(2,l)=i2
526 ixwork(3,l)=i3
527 ixwork(4,l)=i4
528 ixwork(5,l)=i5
529 ENDIF
530 ENDDO
531 ENDIF
532C
533 ELSE
534C pas de surfaces
535 ll = 0
536 nl = 0
537 ENDIF
538c---------------------------------------
539c nombre de lignes
540c---------------------------------------
541 nll = ll
542 nlin = ll
543 nactif = nl
544 IF(lin /= 0) THEN
545 nlin = nlin + nlin0
546 nactif = nactif + nlin0
547 ENDIF
548c---------------------------------------
549c nombre de noeuds
550c---------------------------------------
551 nsme = 0
552 DO i=1,numnod
553 tag(i) = 0
554 ENDDO
555 DO ll=1,nll
556 tag(ixwork(1,ll)) = 1
557 tag(ixwork(2,ll)) = 1
558 ENDDO
559 IF(lin /= 0)THEN
560 DO j=1,nlin0
561 tag(slin_nodes(j,1)) = 1
562 tag(slin_nodes(j,2)) = 1
563 lntag(slin_nodes(j,1)) = 1
564 lntag(slin_nodes(j,2)) = 1
565 ENDDO
566 ENDIF
567 DO i=1,numnod
568 IF(tag(i) == 1) THEN
569 nsme = nsme + 1
570 tagb(i) = bitset(tagb(i),nb)
571 ENDIF
572 ENDDO
573c---------------------------------------
574c copie des lignes (IALLO == 2)
575c---------------------------------------
576 IF(iallo == 2)THEN
577 l = 0
578 IF(lin /= 0)THEN
579 DO j=1,nlin0
580 l = l+1
581 ixline(1,l) = slin_nodes(j,1) ! noeud 1
582 ixline(2,l) = slin_nodes(j,2) ! noeud 2
583 isline(1,l) = 0 ! surface
584 isline(2,l) = 0 ! cot de la surface
585 ENDDO
586 ENDIF
587
588 DO ll=1,nll
589 IF(ixwork(5,ll) == 1)THEN
590 l = l+1
591 ixline(1,l) = ixwork(1,ll) ! noeud 1
592 ixline(2,l) = ixwork(2,ll) ! noeud 2
593 isline(1,l) = ixwork(3,ll) ! surface
594 isline(2,l) = ixwork(4,ll) ! cot de la surface
595 ENDIF
596 ENDDO
597
598c lignes inactives
599 DO ll=1,nll
600 IF(ixwork(5,ll) /= 1)THEN
601 l = l+1
602 ixline(1,l) = ixwork(1,ll) ! noeud 1
603 ixline(2,l) = ixwork(2,ll) ! noeud 2
604 isline(1,l) = ixwork(3,ll) ! surface
605 isline(2,l) = ixwork(4,ll) ! cot de la surface
606 ENDIF
607 ENDDO
608
609 IF(ipri >= 1) THEN
610 WRITE(iout,'(/,A,/)')' ACTIV SEGMENTS USED FOR EDGE'
611 k=1
612 DO i=1,nactif
613 WRITE(iout,fmt=fmw_4i)(itab(ixline(k,i)),k=1,2)
614 ENDDO
615 ENDIF
616
617c noeuds
618 l = 0
619 DO i=1,numnod
620 IF(tag(i) == 1)THEN
621 tag(i) = 0
622 l = l+1
623 msve(l) = i
624 ENDIF
625 ENDDO
626 ENDIF
627C-----------
628 DEALLOCATE (index)
629 DEALLOCATE (tag)
630 DEALLOCATE (ixwork)
631 DEALLOCATE (lineix)
632 DEALLOCATE (lineix2)
633 DEALLOCATE (xlineix)
634C-----------
635 RETURN
636 END
637
638
639!||====================================================================
640!|| i20bord ../starter/source/interfaces/inter3d1/i20surfi.F
641!||--- called by ------------------------------------------------------
642!|| i20surfi ../starter/source/interfaces/inter3d1/i20surfi.F
643!||--- calls -----------------------------------------------------
644!|| ancmsg ../starter/source/output/message/message.F
645!|| bitset ../starter/source/interfaces/inter3d1/bitget.f
646!||--- uses -----------------------------------------------------
647!|| message_mod ../starter/share/message_module/message_mod.F
648!||====================================================================
649 SUBROUTINE i20bord(NSEG ,SURF_NODES ,TAGB,ISU)
650C-----------------------------------------------
651C M o d u l e s
652C-----------------------------------------------
653 USE message_mod
654C-----------------------------------------------
655C I m p l i c i t T y p e s
656C-----------------------------------------------
657#include "implicit_f.inc"
658C-----------------------------------------------
659C D u m m y A r g u m e n t s
660C-----------------------------------------------
661 INTEGER IALLO,NSEG,SURF_NODES(NSEG,4),ISU
662 INTEGER TAGB(*)
663C-----------------------------------------------
664C L o c a l V a r i a b l e s
665C-----------------------------------------------
666 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,IS,BORD,BOLD
667 INTEGER NEXTK(4),IWORK(70000),NL
668 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
669 . LINEIX
670 INTEGER, DIMENSION(:), ALLOCATABLE ::
671 . index
672
673 INTEGER BITSET
674 EXTERNAL BITSET
675
676 DATA nextk/2,3,4,1/
677C=======================================================================
678 nlmax = 0
679 i1 = 0
680 i2 = 0
681 IF(isu /= 0)nlmax = 4*nseg
682
683 ALLOCATE (lineix(2,nlmax) ,stat=stat)
684 ALLOCATE (index(2*nlmax) ,stat=stat)
685
686 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
687 . msgtype=msgerror,
688 . c1='LINEIX')
689
690c---------------------------------------
691c recherche de toutes les lignes dans la surface
692c---------------------------------------
693 ll = 0
694 IF(isu /= 0)THEN
695 is = 0
696 DO j=1,nseg
697 is = is+1
698 i1=surf_nodes(j,1)
699 i2=surf_nodes(j,2)
700 i3=surf_nodes(j,3)
701 i4=surf_nodes(j,4)
702 DO k=1,4
703 i1=surf_nodes(j,k)
704 i2=surf_nodes(j,nextk(k))
705 ll = ll+1
706 IF(i2 > i1)THEN
707 lineix(1,ll) = i1
708 lineix(2,ll) = i2
709 ELSE
710c LINEIX(1,LL) = I1
711c LINEIX(2,LL) = I2
712 lineix(1,ll) = i2
713 lineix(2,ll) = i1
714 ENDIF
715 ENDDO
716 ENDDO
717C
718 CALL my_orders(0,iwork,lineix,index,ll,2)
719
720c---------------------------------------
721c suppression des lignes doubles
722c---------------------------------------
723 i1m = lineix(1,index(1))
724 i2m = lineix(2,index(1))
725 bord=1
726 bold=1
727 DO l=2,ll
728 i1 = lineix(1,index(l))
729 i2 = lineix(2,index(l))
730 IF(i1m == i2m)THEN
731c triangle on ne fait rien
732 bold=1
733 ELSEIF(bold == 0)THEN
734c idem precedent on ne fait rien
735 bold=1
736 ELSEIF(i2 == i2m .and. i1 == i1m)THEN
737c idem suivant pas de bord
738 bord=0
739 bold=0
740 ELSE
741 bord=1 ! bord
742 bold=1
743 tagb(i1m) = bitset(tagb(i1m),7)
744 tagb(i2m) = bitset(tagb(i2m),7)
745 ENDIF
746 i1m = i1
747 i2m = i2
748 ENDDO
749
750 IF(bord==1)THEN
751c derniere arrete est un bord
752 tagb(i1) = bitset(tagb(i1),7)
753 tagb(i2) = bitset(tagb(i2),7)
754 ENDIF
755
756 ENDIF
757
758 DEALLOCATE (index)
759 DEALLOCATE (lineix)
760C-----------
761 RETURN
762 END
763
bitget
integer function bitget(i, n)
Definition bitget.F:37
bitset
integer function bitset(i, n)
Definition bitget.F:66
my_real
#define my_real
Definition cppsort.cpp:32
i20edge1
subroutine i20edge1(iallo, nseg0, nlin0, nlin, nactif, ixline, msve, nsme, iedge, surf_nodes, slin_nodes, itab, isline, x, edg_cos, lntag, tagb, nb, isu, lin)
Definition i20surfi.F:333
i20bord
subroutine i20bord(nseg, surf_nodes, tagb, isu)
Definition i20surfi.F:650
i20surfi
subroutine i20surfi(iallo, ipari, igrnod, igrsurf, igrslin, irect, frigap, nsv, msr, ixlins, ixlinm, nsve, msre, itab, islins, islinm, nlg, x, nbinflg, mbinflg)
Definition i20surfi.F:41
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
groupdef_mod
Definition groupdef_mod.F:662
message_mod
Definition message_mod.F:1249
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
starter
program starter
Definition starter.F:39