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 Copy of 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 NODES C=======================================================================
154c-----------------------------------------------------------------
155c tag nodes surfaces S1 S2
156c-----------------------------------------------------------------
157 DO i=1,numnod
158 tag(i)=0 ! initialisation
159 tags(i)=0 ! initialisation
160 tagb(i)=0 ! initialisation
161 lntag(i)=0 ! initialisation
162 ENDDO
163 IF(isu2 /= 0)THEN
164 DO j=1,igrsurf(isu2)%NSEG
165 DO k=1,4
166 tag(igrsurf(isu2)%NODES(j,k)) = 2
167 lntag(igrsurf(isu2)%NODES(j,k)) = 1
168 ENDDO
169 ENDDO
170 ENDIF
171 IF(isu1 /= 0)THEN
172 DO j=1,igrsurf(isu1)%NSEG
173 DO k=1,4
174 i=igrsurf(isu1)%NODES(j,k)
175 IF(tag(i) == 0)THEN
176 tag(i) = 1
177 ELSEIF(tag(i) == 2)THEN
178 tag(i) = 3
179 ENDIF
180 lntag(i) = 1
181 ENDDO
182 ENDDO
183 ENDIF
184c-----------------------------------------------------------------
185c nodes of surface S2
186c-----------------------------------------------------------------
187 IF(isu2 /= 0)THEN
188 DO j=1,igrsurf(isu2)%NSEG
189 DO k=1,4
190 i=igrsurf(isu2)%NODES(j,k)
191 IF(tag(i) == 2 .and. isym == 1)THEN
192 nmn = nmn + 1
193 IF(iallo == 2)msr(nmn) = i
194 tagb(i) = bitset(tagb(i),4)
195 ENDIF
196 IF(tag(i) == 2 .or. tag(i) == 3)THEN
197 tag(i) = - tag(i)
198 tags(i) = 1
199 nsn = nsn + 1
200 IF(iallo == 2)nsv(nsn) = i
201 tagb(i) = bitset(tagb(i),1)
202 ENDIF
203 ENDDO
204 ENDDO
205 ENDIF
206c-----------------------------------------------------------------
207c nodes of surface S1 if isym /= 2
208c-----------------------------------------------------------------
209 IF(isu1 /= 0)THEN
210 DO j=1,igrsurf(isu1)%NSEG
211 DO k=1,4
212 i=igrsurf(isu1)%NODES(j,k)
213 IF(tag(i) == 1 .and.
214 . (isym == 1 .or. (isym == 0 .and. isu2 == 0))) THEN
215 tags(i) = 1
216 nsn = nsn + 1
217 IF(iallo == 2)nsv(nsn) = i
218 tagb(i) = bitset(tagb(i),0)
219 ENDIF
220 IF(tag(i) == 1 .or. tag(i) == -3)THEN
221 tag(i) = - tag(i)
222 nmn = nmn + 1
223 IF(iallo == 2)msr(nmn) = i
224 tagb(i) = bitset(tagb(i),3)
225 ENDIF
226 ENDDO
227 ENDDO
228 ENDIF
229c-----------------------------------------------------------------
230c nodes of the node group nod1
231c-----------------------------------------------------------------
232 IF(nod1 /= 0)THEN
233 DO j=1,igrnod(nod1)%NENTITY
234 i = igrnod(nod1)%ENTITY(j)
235 lntag(i) = 1
236 IF(tags(i) == 0)THEN
237 tags(i) = 1
238 nsn = nsn+1
239 IF(iallo == 2) nsv(nsn) = i
240 tagb(i) = bitset(tagb(i),2)
241 ENDIF
242 ENDDO
243 ENDIF
244
245 IF(iallo == 2 .and. ipri >= 1) THEN
246 WRITE(iout,'(/,A,/)')' NODES USED FOR SURFACE DEFINITION'
247 WRITE(iout,fmt=fmw_10i)(itab(nsv(i)),i=1,nsn)
248 ENDIF
249C=======================================================================
250c EDGES
251C=======================================================================
252 IF(iedge /= 0)THEN
253 CALL i20edge1(iallo ,igrsurf(isu1)%NSEG ,igrslin(max(1,line1))%NSEG ,nlinm ,nlinma ,
254 2 ixlinm ,msre ,nmne ,iedge ,
255 3 igrsurf(isu1)%NODES,igrslin(max(1,line1))%NODES ,itab ,
256 4 islinm ,x ,edg_cos ,lntag ,
257 5 tagb ,5 ,isu1 ,line1 )
258 CALL i20edge1(iallo ,igrsurf(isu2)%NSEG ,igrslin(max(1,line2))%NSEG ,nlins ,nlinsa ,
259 2 ixlins ,nsve ,nsne ,iedge ,
260 3 igrsurf(isu2)%NODES,igrslin(max(1,line2))%NODES ,itab ,
261 4 islins ,x ,edg_cos ,lntag ,
262 5 tagb ,6 ,isu2 ,line2 )
263 ENDIF
264C=======================================================================
265c EDGES FOR GAP=0 CORRECTION on shell edge
266C=======================================================================
267 IF(iallo == 2)THEN
268 IF(isu1 /= 0)THEN
269 CALL i20bord(igrsurf(isu1)%NSEG ,igrsurf(isu1)%NODES, tagb,isu1)
270 ENDIF
271 IF(isu2 /= 0 .and. isu2 /= isu1)THEN
272 CALL i20bord(igrsurf(isu2)%NSEG ,igrsurf(isu2)%NODES, tagb,isu2)
273 ENDIF
274 ENDIF
275c-----------------------------------------------------------------
276c number of nodes in the interface (second+main+edge)
277c-----------------------------------------------------------------
278 IF(iallo == 1)THEN
279 DO i=1,numnod
280 IF(lntag(i)==1)THEN
281 nln=nln+1
282 ENDIF
283 ENDDO
284 ELSEIF(iallo == 2)THEN
285 nln = ipari(35)
286 j=0
287 DO i=1,numnod
288 IF(lntag(i)==1)THEN
289 j=j+1
290 nlg(j) = i
291 nbinflg(j) = tagb(i)
292 ENDIF
293 ENDDO
294 ENDIF
295
296 ipari(3) = 0
297 ipari(4) = nrtm
298 ipari(5) = nsn
299 ipari(6) = nmn
300 ipari(35) = nln
301 ipari(51) = nlins
302 ipari(52) = nlinm
303 ipari(53) = nlinsa
304 ipari(54) = nlinma
305 ipari(55) = nsne
306 ipari(56) = nmne
307
308
309 RETURN
310 END
311
312
313
314
315
316!||====================================================================
317!|| i20edge1 ../starter/source/interfaces/inter3d1/i20surfi.f
318!||--- called by ------------------------------------------------------
319!|| i20surfi ../starter/source/interfaces/inter3d1/i20surfi.F
320!||--- calls -----------------------------------------------------
321!|| ancmsg ../starter/source/output/message/message.F
322!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
323!||--- uses -----------------------------------------------------
324!|| format_mod ../starter/share/modules1/format_mod.F90
325!|| message_mod ../starter/share/message_module/message_mod.F
326!||====================================================================
327 SUBROUTINE i20edge1(IALLO ,NSEG0 ,NLIN0 ,NLIN ,NACTIF ,
328 2 IXLINE ,MSVE ,NSME ,IEDGE ,
329 3 SURF_NODES,SLIN_NODES,ITAB ,
330 4 ISLINE ,X ,EDG_COS ,LNTAG ,
331 5 TAGB ,NB ,ISU ,LIN )
332C-----------------------------------------------
333C M o d u l e s
334C-----------------------------------------------
335 USE message_mod
336 USE format_mod , ONLY : fmw_4i
337C-----------------------------------------------
338C I m p l i c i t T y p e s
339C-----------------------------------------------
340#include "implicit_f.inc"
341C-----------------------------------------------
342C C o m m o n B l o c k s
343C-----------------------------------------------
344#include "com04_c.inc"
345#include "units_c.inc"
346#include "scr03_c.inc"
347C-----------------------------------------------
348C D u m m y A r g u m e n t s
349C-----------------------------------------------
350 INTEGER IALLO,NSEG0,NLIN0,NLIN,NACTIF,IEDGE,NSME,NB,ISU,LIN
351 INTEGER IXLINE(2,*),ITAB(*),MSVE(*),
352 . LNTAG(*) ,TAGB(*),ISLINE(2,*),SURF_NODES(NSEG0,4),
353 . SLIN_NODES(NLIN0,2)
354 my_real X(3,*),EDG_COS
355C-----------------------------------------------
356C L o c a l V a r i a b l e s
357C-----------------------------------------------
358 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,NL,IS
359 INTEGER NEXTK(4),IWORK(70000),NLL
360 my_real nx,ny,nz,mx,my,mz,aaa,d1x,d1y,d1z,d2x,d2y,d2z
361 INTEGER, DIMENSION(:,:), ALLOCATABLE :: LINEIX,LINEIX2,IXWORK
362 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX,TAG
363 my_real, DIMENSION(:,:), ALLOCATABLE :: xlineix
364
365 INTEGER BITSET
366 EXTERNAL BITSET
367
368 DATA nextk/2,3,4,1/
369C=======================================================================
370 nlmax = 0
371 IF(isu /= 0) nlmax = 4*nseg0
372
373 ALLOCATE (lineix(2,nlmax) ,stat=stat)
374 ALLOCATE (lineix2(2,nlmax) ,stat=stat)
375 ALLOCATE (xlineix(3,nlmax) ,stat=stat)
376 ALLOCATE (index(2*nlmax) ,stat=stat)
377 ALLOCATE (tag(numnod) ,stat=stat)
378 ALLOCATE (ixwork(5,nlmax) ,stat=stat)
379
380 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
381 . msgtype=msgerror,
382 . c1='LINEIX')
383
384c---------------------------------------
385c search for all lines in the surface
386c---------------------------------------
387 IF(isu /= 0)THEN
388 is = 0
389 ll = 0
390 DO j=1,nseg0
391 is = is+1
392 i1=surf_nodes(j,1)
393 i2=surf_nodes(j,2)
394 i3=surf_nodes(j,3)
395 i4=surf_nodes(j,4)
396 d1x = x(1,i3) - x(1,i1)
397 d1y = x(2,i3) - x(2,i1)
398 d1z = x(3,i3) - x(3,i1)
399 d2x = x(1,i4) - x(1,i2)
400 d2y = x(2,i4) - x(2,i2)
401 d2z = x(3,i4) - x(3,i2)
402 nx = d1y * d2z - d1z * d2y
403 ny = d1z * d2x - d1x * d2z
404 nz = d1x * d2y - d1y * d2x
405 aaa = one/max(sqrt(nx*nx+ny*ny+nz*nz),em20)
406 nx = nx * aaa
407 ny = ny * aaa
408 nz = nz * aaa
409 DO k=1,4
410 i1=surf_nodes(j,k)
411 i2=surf_nodes(j,nextk(k))
412 ll = ll+1
413 IF(i2 > i1)THEN
414 lineix(1,ll) = i1
415 lineix(2,ll) = i2
416 lineix2(1,ll) = j
417 lineix2(2,ll) = k
418 ELSE
419c LINEIX(1,LL) = I1
420c LINEIX(2,LL) = I2
421 lineix(1,ll) = i2
422 lineix(2,ll) = i1
423 lineix2(1,ll) = j
424 lineix2(2,ll) = -k
425 ENDIF
426 xlineix(1,ll) = nx
427 xlineix(2,ll) = ny
428 xlineix(3,ll) = nz
429 ENDDO
430 ENDDO
431C
432 CALL my_orders(0,iwork,lineix,index,ll,2)
433
434c---------------------------------------
435c removal of double lines
436c + Calculation of angles (sin) inter-facet
437c---------------------------------------
438 i1m = lineix(1,index(1))
439 i2m = lineix(2,index(1))
440 nl = 1
441 ixwork(1,nl)=i1m
442 ixwork(2,nl)=i2m
443 ixwork(3,nl)=lineix2(1,index(1))
444 ixwork(4,nl)=lineix2(2,index(1))
445 ixwork(5,nl)=1
446 mx = xlineix(1,index(1))
447 my = xlineix(2,index(1))
448 mz = xlineix(3,index(1))
449 DO l=2,ll
450 i1 = lineix(1,index(l))
451 i2 = lineix(2,index(l))
452 nx = xlineix(1,index(l))
453 ny = xlineix(2,index(l))
454 nz = xlineix(3,index(l))
455 IF(i2 /= i2m .or. i1 /= i1m)THEN
456 nl = nl + 1
457 ixwork(1,nl)=i1
458 ixwork(2,nl)=i2
459 ixwork(3,nl)=lineix2(1,index(l))
460 ixwork(4,nl)=lineix2(2,index(l))
461 ixwork(5,nl)=1 ! bord
462 ELSE
463 ixwork(5,nl)=0 ! interne
464 aaa = nx*mx + ny * my + nz * mz
465 IF (aaa < edg_cos) ixwork(5,nl) = -1 ! arte vive
466 ENDIF
467 i1m = i1
468 i2m = i2
469 mx = nx
470 my = ny
471 mz = nz
472 ENDDO
473
474c---------------------------------------
475c Deletion of internal lines (iedge == 1)
476c---------------------------------------
477 ll = nl
478 nl = 0
479 IF(iedge == 1)THEN
480c only the edges are kept
481 DO l=1,ll
482 IF(ixwork(5,l) == 1)THEN
483 nl = nl + 1
484 i1=ixwork(1,nl)
485 i2=ixwork(2,nl)
486 i3=ixwork(3,nl)
487 i4=ixwork(4,nl)
488 i5=ixwork(5,nl)
489 ixwork(1,nl)=ixwork(1,l)
490 ixwork(2,nl)=ixwork(2,l)
491 ixwork(3,nl)=ixwork(3,l)
492 ixwork(4,nl)=ixwork(4,l)
493 ixwork(5,nl)=1 ! bord on
494 ixwork(1,l)=i1
495 ixwork(2,l)=i2
496 ixwork(3,l)=i3
497 ixwork(4,l)=i4
498 ixwork(5,l)=i5
499 ENDIF
500 ENDDO
501 ELSEIF(iedge == 2)THEN
502c all lines are kept AND active
503 DO l=1,ll
504 nl = nl + 1
505 ixwork(5,l)=1 ! all on
506 ENDDO
507 ELSEIF(iedge == 3)THEN
508c the edges are kept
509c the live edges are kept (edg_cos)
510 DO l=1,ll
511 IF(iabs(ixwork(5,l)) == 1)THEN
512 nl = nl + 1
513 i1=ixwork(1,nl)
514 i2=ixwork(2,nl)
515 i3=ixwork(3,nl)
516 i4=ixwork(4,nl)
517 i5=iabs(ixwork(5,nl))
518 ixwork(1,nl)=ixwork(1,l)
519 ixwork(2,nl)=ixwork(2,l)
520 ixwork(3,nl)=ixwork(3,l)
521 ixwork(4,nl)=ixwork(4,l)
522 ixwork(5,nl)=1 ! bord on
523 ixwork(1,l)=i1
524 ixwork(2,l)=i2
525 ixwork(3,l)=i3
526 ixwork(4,l)=i4
527 ixwork(5,l)=i5
528 ENDIF
529 ENDDO
530 ENDIF
531C
532 ELSE
533C no surfaces
534 ll = 0
535 nl = 0
536 ENDIF
537c---------------------------------------
538c number of lines
539c---------------------------------------
540 nll = ll
541 nlin = ll
542 nactif = nl
543 IF(lin /= 0) THEN
544 nlin = nlin + nlin0
545 nactif = nactif + nlin0
546 ENDIF
547c---------------------------------------
548c number of nodes
549c---------------------------------------
550 nsme = 0
551 DO i=1,numnod
552 tag(i) = 0
553 ENDDO
554 DO ll=1,nll
555 tag(ixwork(1,ll)) = 1
556 tag(ixwork(2,ll)) = 1
557 ENDDO
558 IF(lin /= 0)THEN
559 DO j=1,nlin0
560 tag(slin_nodes(j,1)) = 1
561 tag(slin_nodes(j,2)) = 1
562 lntag(slin_nodes(j,1)) = 1
563 lntag(slin_nodes(j,2)) = 1
564 ENDDO
565 ENDIF
566 DO i=1,numnod
567 IF(tag(i) == 1) THEN
568 nsme = nsme + 1
569 tagb(i) = bitset(tagb(i),nb)
570 ENDIF
571 ENDDO
572c---------------------------------------
573c Copy of lines (Iallo == 2)
574c---------------------------------------
575 IF(iallo == 2)THEN
576 l = 0
577 IF(lin /= 0)THEN
578 DO j=1,nlin0
579 l = l+1
580 ixline(1,l) = slin_nodes(j,1) ! noeud 1
581 ixline(2,l) = slin_nodes(j,2) ! noeud 2
582 isline(1,l) = 0 ! surface
583 isline(2,l) = 0 ! side of the surface
584 ENDDO
585 ENDIF
586
587 DO ll=1,nll
588 IF(ixwork(5,ll) == 1)THEN
589 l = l+1
590 ixline(1,l) = ixwork(1,ll) ! noeud 1
591 ixline(2,l) = ixwork(2,ll) ! noeud 2
592 isline(1,l) = ixwork(3,ll) ! surface
593 isline(2,l) = ixwork(4,ll) ! side of the surface
594 ENDIF
595 ENDDO
596
597c inactive lines
598 DO ll=1,nll
599 IF(ixwork(5,ll) /= 1)THEN
600 l = l+1
601 ixline(1,l) = ixwork(1,ll) ! noeud 1
602 ixline(2,l) = ixwork(2,ll) ! noeud 2
603 isline(1,l) = ixwork(3,ll) ! surface
604 isline(2,l) = ixwork(4,ll) ! side of the surface
605 ENDIF
606 ENDDO
607
608 IF(ipri >= 1) THEN
609 WRITE(iout,'(/,A,/)')' ACTIV SEGMENTS USED FOR EDGE'
610 k=1
611 DO i=1,nactif
612 WRITE(iout,fmt=fmw_4i)(itab(ixline(k,i)),k=1,2)
613 ENDDO
614 ENDIF
615
616c nodes
617 l = 0
618 DO i=1,numnod
619 IF(tag(i) == 1)THEN
620 tag(i) = 0
621 l = l+1
622 msve(l) = i
623 ENDIF
624 ENDDO
625 ENDIF
626C-----------
627 DEALLOCATE (index)
628 DEALLOCATE (tag)
629 DEALLOCATE (ixwork)
630 DEALLOCATE (lineix)
631 DEALLOCATE (lineix2)
632 DEALLOCATE (xlineix)
633C-----------
634 RETURN
635 END
636
637
638!||====================================================================
639!|| i20bord ../starter/source/interfaces/inter3d1/i20surfi.F
640!||--- called by ------------------------------------------------------
641!|| i20surfi ../starter/source/interfaces/inter3d1/i20surfi.F
642!||--- calls -----------------------------------------------------
643!|| ancmsg ../starter/source/output/message/message.F
644!|| bitset ../starter/source/interfaces/inter3d1/bitget.F
645!||--- uses -----------------------------------------------------
646!|| message_mod ../starter/share/message_module/message_mod.f
647!||====================================================================
648 SUBROUTINE i20bord(NSEG ,SURF_NODES ,TAGB,ISU)
649C-----------------------------------------------
650C M o d u l e s
651C-----------------------------------------------
652 USE message_mod
653C-----------------------------------------------
654C I m p l i c i t T y p e s
655C-----------------------------------------------
656#include "implicit_f.inc"
657C-----------------------------------------------
658C D u m m y A r g u m e n t s
659C-----------------------------------------------
660 INTEGER IALLO,NSEG,SURF_NODES(NSEG,4),ISU
661 INTEGER TAGB(*)
662C-----------------------------------------------
663C L o c a l V a r i a b l e s
664C-----------------------------------------------
665 INTEGER I,J,K,L,NLMAX,STAT,LL,I1,I2,I3,I4,I5,I1M,I2M,IS,BORD,BOLD
666 INTEGER NEXTK(4),IWORK(70000),NL
667 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
668 . LINEIX
669 INTEGER, DIMENSION(:), ALLOCATABLE ::
670 . index
671
672 INTEGER BITSET
673 EXTERNAL BITSET
674
675 DATA nextk/2,3,4,1/
676C=======================================================================
677 nlmax = 0
678 i1 = 0
679 i2 = 0
680 IF(isu /= 0)nlmax = 4*nseg
681
682 ALLOCATE (lineix(2,nlmax) ,stat=stat)
683 ALLOCATE (index(2*nlmax) ,stat=stat)
684
685 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
686 . msgtype=msgerror,
687 . c1='LINEIX')
688
689c---------------------------------------
690c search for all lines in the surface
691c---------------------------------------
692 ll = 0
693 IF(isu /= 0)THEN
694 is = 0
695 DO j=1,nseg
696 is = is+1
697 i1=surf_nodes(j,1)
698 i2=surf_nodes(j,2)
699 i3=surf_nodes(j,3)
700 i4=surf_nodes(j,4)
701 DO k=1,4
702 i1=surf_nodes(j,k)
703 i2=surf_nodes(j,nextk(k))
704 ll = ll+1
705 IF(i2 > i1)THEN
706 lineix(1,ll) = i1
707 lineix(2,ll) = i2
708 ELSE
709c LINEIX(1,LL) = I1
710c LINEIX(2,LL) = I2
711 lineix(1,ll) = i2
712 lineix(2,ll) = i1
713 ENDIF
714 ENDDO
715 ENDDO
716C
717 CALL my_orders(0,iwork,lineix,index,ll,2)
718
719c---------------------------------------
720c removal of double lines
721c---------------------------------------
722 i1m = lineix(1,index(1))
723 i2m = lineix(2,index(1))
724 bord=1
725 bold=1
726 DO l=2,ll
727 i1 = lineix(1,index(l))
728 i2 = lineix(2,index(l))
729 IF(i1m == i2m)THEN
730c triangle we do nothing
731 bold=1
732 ELSEIF(bold == 0)THEN
733c ditto previous we do nothing
734 bold=1
735 ELSEIF(i2 == i2m .and. i1 == i1m)THEN
736c idem according to pas de bord
737 bord=0
738 bold=0
739 ELSE
740 bord=1 ! bord
741 bold=1
742 tagb(i1m) = bitset(tagb(i1m),7)
743 tagb(i2m) = bitset(tagb(i2m),7)
744 ENDIF
745 i1m = i1
746 i2m = i2
747 ENDDO
748
749 IF(bord==1)THEN
750c last edge is an edge
751 tagb(i1) = bitset(tagb(i1),7)
752 tagb(i2) = bitset(tagb(i2),7)
753 ENDIF
754
755 ENDIF
756
757 DEALLOCATE (index)
758 DEALLOCATE (lineix)
759C-----------
760 RETURN
761 END
762
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:332
i20bord
subroutine i20bord(nseg, surf_nodes, tagb, isu)
Definition i20surfi.F:649
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:668
message_mod
Definition message_mod.F:1257
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
starter
program starter
Definition starter.F:39