OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i24tools.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!|| add_id ../starter/source/interfaces/inter3d1/i24tools.F
25!||--- called by ------------------------------------------------------
26!|| comm_seg_e ../starter/source/interfaces/inter3d1/i24inisu_nei.F
27!|| i25neigh_seg_e ../starter/source/interfaces/inter3d1/i25neigh.f
28!||====================================================================
29 SUBROUTINE add_id(N,IC,ID)
30C----6---------------------------------------------------------------7---------8
31C I m p l i c i t T y p e s
32C-----------------------------------------------
33#include "implicit_f.inc"
34C-----------------------------------------------------------------
35C D u m m y A r g u m e n t s
36C-----------------------------------------------
37 INTEGER N ,IC(*),ID
38C-----------------------------------------------
39C L o c a l V a r i a b l e s
40C-----------------------------------------------
41 INTEGER I
42C----add ID--at end--if not inside already----------------
43 IF (id/=0) THEN
44 DO i =1,n
45 IF (ic(i)==id) RETURN
46 ENDDO
47 END IF
48 n =n+1
49 ic(n)=id
50C----6---------------------------------------------------------------7---------8
51 RETURN
52 END
53!||====================================================================
54!|| add_n_id ../starter/source/interfaces/inter3d1/i24tools.F
55!||--- called by ------------------------------------------------------
56!|| comm_seg_n ../starter/source/interfaces/inter3d1/i24inisu_nei.F
57!||====================================================================
58 SUBROUTINE add_n_id(N,IC,ID)
59C----6---------------------------------------------------------------7---------8
60C I m p l i c i t T y p e s
61C-----------------------------------------------
62#include "implicit_f.inc"
63C-----------------------------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER N ,IC(*),ID
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I
71C----add ID--at end----------------
72 n =n+1
73 ic(n)=id
74C----6---------------------------------------------------------------7---------8
75 RETURN
76 END
77!||====================================================================
78!|| intab ../starter/source/interfaces/inter3d1/i24tools.F
79!||--- called by ------------------------------------------------------
80!|| add_nsfic ../starter/source/interfaces/inter3d1/i7remnode.F
81!|| comm_seg_e ../starter/source/interfaces/inter3d1/i24inisu_nei.F
82!|| i24penmax ../starter/source/interfaces/inter3d1/i24pen3.F
83!|| i25neigh_seg_e ../starter/source/interfaces/inter3d1/i25neigh.F
84!|| i25neigh_seg_opp ../starter/source/interfaces/inter3d1/i25neigh.F
85!|| int2cy_chk ../starter/source/constraints/general/bcs/lecbcscyc.f
86!|| int2modif_nd ../starter/source/elements/solid/solide10/dim_s10edg.F
87!|| itagsl2 ../starter/source/interfaces/inter3d1/itagsl2.F
88!|| rbe2modif_nd ../starter/source/elements/solid/solide10/dim_s10edg.F
89!|| rigmodif_nd ../starter/source/elements/solid/solide10/dim_s10edg.F
90!|| s10edg_rlink ../starter/source/elements/solid/solide10/s10edg_rlink.F
91!|| same_seg ../starter/source/interfaces/inter3d1/i24tools.F
92!|| seg_opp ../starter/source/interfaces/inter3d1/i24tools.F
93!||====================================================================
94 LOGICAL FUNCTION intab(NIC,IC,N)
95C----6---------------------------------------------------------------7---------8
96C I m p l i c i t T y p e s
97C-----------------------------------------------
98#include "implicit_f.inc"
99C-----------------------------------------------------------------
100C D u m m y A r g u m e n t s
101C-----------------------------------------------
102 INTEGER n ,nic,ic(*)
103C-----------------------------------------------
104C L o c a l V a r i a b l e s
105C-----------------------------------------------
106 INTEGER i,j
107C----6---------------------------------------------------------------7---------8
108 intab=.false.
109 DO i =1,nic
110 IF (n==ic(i)) THEN
111 intab=.true.
112 RETURN
113 ENDIF
114 ENDDO
115C
116 RETURN
117 END
118!||====================================================================
119!|| normv3 ../starter/source/interfaces/inter3d1/i24tools.F
120!||--- called by ------------------------------------------------------
121!|| i24normns ../starter/source/interfaces/inter3d1/i24sti3.f
122!|| i25neigh_removeallbut1 ../starter/source/interfaces/inter3d1/i25neigh.F
123!|| normvec ../starter/source/interfaces/inter3d1/i24sti3.F
124!|| removeic ../starter/source/interfaces/inter3d1/i24tools.f
125!|| removeic1 ../starter/source/interfaces/inter3d1/i24tools.f
126!|| voisin2 ../starter/source/interfaces/inter3d1/i24tools.F
127!||====================================================================
128 SUBROUTINE normv3(V,NORM)
129C----6---------------------------------------------------------------7---------8
130C I m p l i c i t T y p e s
131C-----------------------------------------------
132#include "implicit_f.inc"
133C-----------------------------------------------------------------
134C D u m m y A r g u m e n t s
135C-----------------------------------------------
136C REAL
137 my_real
138 . v(3),norm
139C-----------------------------------------------
140C L o c a l V a r i a b l e s
141C-----------------------------------------------
142 INTEGER I
143 my_real
144 . s
145C-----
146 norm = sqrt(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
147 s=one/max(em20,norm)
148 v(1)=v(1)*s
149 v(2)=v(2)*s
150 v(3)=v(3)*s
151C----6---------------------------------------------------------------7---------8
152 RETURN
153 END
154!||====================================================================
155!|| voisin2 ../starter/source/interfaces/inter3d1/i24tools.F
156!||--- called by ------------------------------------------------------
157!|| removeic ../starter/source/interfaces/inter3d1/i24tools.F
158!||--- calls -----------------------------------------------------
159!|| norma4n ../starter/source/interfaces/inter3d1/norma1.F
160!|| norma4nx ../starter/source/interfaces/inter3d1/norma1.F
161!|| normv3 ../starter/source/interfaces/inter3d1/i24tools.F
162!||====================================================================
163 SUBROUTINE voisin2(NC1,NC2,X ,I1 ,I2 ,YI,YJ,INV)
164C----6---------------------------------------------------------------7---------8
165C I m p l i c i t T y p e s
166C-----------------------------------------------
167#include "implicit_f.inc"
168C-----------------------------------------------------------------
169C D u m m y A r g u m e n t s
170C-----------------------------------------------
171C REAL
172 INTEGER NC1(*),NC2(*),INV,I1 ,I2
173 my_real
174 . x(3,*),yi(3),yj(3)
175C-----------------------------------------------
176c FUNCTION: find the same orientation of two segments (4n)
177c
178c Note:
179c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
180c
181c TYPE NAME FUNCTION
182c I NC1(1:4),NC2(1:4) - connectivity
183c I I1,I2 - common nodes of two seg
184c I X(3,*) - coordinates
185c O INV - flag : 0 same orientation; 1 inverse one
186C-----------------------------------------------
187C L o c a l V a r i a b l e s
188C-----------------------------------------------
189 INTEGER I,J,J1,J2
190 my_real
191 . s,area,nxi,nyi,nzi,nxj,nyj,nzj,norm,yiyj,y0(3)
192C----build Yi vectors for seg 1,2
193 yiyj=yi(1)*yj(1)+yi(2)*yj(2)+yi(3)*yj(3)
194C--------particular case-----
195 IF (abs(yiyj)<em20) THEN
196 CALL normv3(yj,norm)
197 y0(1)= -em01*yj(1)
198 y0(2)= -em01*yj(2)
199 y0(3)= -em01*yj(3)
200 CALL norma4nx(nxi,nyi,nzi,area,nc1 ,x ,i1,i2,y0)
201 CALL norma4n(nxj,nyj,nzj,area,nc2 ,x )
202 s=nxi*nxj+nyi*nyj+nzi*nzj
203 ELSE
204C----build normal vectors for seg 1,2
205 CALL norma4n(nxi,nyi,nzi,area,nc1 ,x )
206 CALL norma4n(nxj,nyj,nzj,area,nc2 ,x )
207 s=nxi*nxj+nyi*nyj+nzi*nzj
208 END IF
209C
210 IF (yiyj*s <= zero ) THEN
211 inv =0
212 ELSE
213 inv = 1
214 END IF
215C----6---------------------------------------------------------------7---------8
216 RETURN
217 END
218!||====================================================================
219!|| re_ori ../starter/source/interfaces/inter3d1/i24tools.F
220!||--- called by ------------------------------------------------------
221!|| comm_seg_en ../starter/source/interfaces/inter3d1/i24inisu_nei.F
222!||====================================================================
223 SUBROUTINE re_ori(I1,I2,IN,X )
224C----6---------------------------------------------------------------7---------8
225C I m p l i c i t T y p e s
226C-----------------------------------------------
227#include "implicit_f.inc"
228C-----------------------------------------------------------------
229C D u m m y A r g u m e n t s
230C-----------------------------------------------
231 INTEGER I1,I2,IN(*)
232C REAL
233 my_real
234 . x(3,*)
235C-----------------------------------------------
236C L o c a l V a r i a b l e s
237C-----------------------------------------------
238 INTEGER J,J1,J2
239 my_real
240 . s,u1(3),u2(3)
241C----re-orienter IN(1),IN(2) if necessary----------------
242 j1=in(1)
243 j2=in(2)
244 IF (j1 == 0 .OR. j2 == 0) RETURN
245 u1(1)=x(1,i2)-x(1,i1)
246 u1(2)=x(2,i2)-x(2,i1)
247 u1(3)=x(3,i2)-x(3,i1)
248 u2(1)=x(1,j2)-x(1,j1)
249 u2(2)=x(2,j2)-x(2,j1)
250 u2(3)=x(3,j2)-x(3,j1)
251 s= u1(1)*u2(1)+u1(2)*u2(2)+u1(3)*u2(3)
252 IF (s < 0) THEN
253c print *,'---------change order-----------'
254 j=in(2)
255 in(2)=in(1)
256 in(1)=j
257 END IF
258C----6---------------------------------------------------------------7---------8
259 RETURN
260 END
261!||====================================================================
262!|| msg_err ../starter/source/interfaces/inter3d1/i24tools.F
263!||--- called by ------------------------------------------------------
264!|| i24inisur_nei ../starter/source/interfaces/inter3d1/i24inisu_nei.F
265!||--- calls -----------------------------------------------------
266!|| ancmsg ../starter/source/output/message/message.F
267!||--- uses -----------------------------------------------------
268!|| message_mod ../starter/share/message_module/message_mod.F
269!||====================================================================
270 SUBROUTINE msg_err(I1,I2,ITAB,IRR,ID,TITR)
271 USE message_mod
272 USE names_and_titles_mod , ONLY : nchartitle
273C-----------------------------------------------
274C I m p l i c i t T y p e s
275C-----------------------------------------------
276#include "implicit_f.inc"
277C-----------------------------------------------
278C C o m m o n B l o c k s
279C-----------------------------------------------
280#include "scr03_c.inc"
281C-----------------------------------------------
282C D u m m y A r g u m e n t s
283C-----------------------------------------------
284 INTEGER I1,I2,ITAB(*),IRR
285 INTEGER ID
286 CHARACTER(LEN=NCHARTITLE) :: TITR
287C-----------------------------------------------
288C L o c a l V a r i a b l e s
289C-----------------------------------------------
290 INTEGER I
291C----Warning,ERROR out----------------
292 IF(ipri==0) RETURN
293#ifndef HYPERMESH_LIB
294 IF (irr ==11) THEN
295C-----multi-neibour but no valid one
296 CALL ancmsg(msgid=993,
297 . msgtype=msgwarning,
298 . anmode=aninfo_blind_2,
299 . i1=id,
300 . c1=titr,
301 . i2=itab(i1),i3=itab(i2))
302c write(iout,*) '***Warning: No validate commun Seg with line:',
303c + Itab(I1),Itab(I2)
304 ELSEIF (irr ==12) THEN
305C-----multi-neibour but no valid one
306 CALL ancmsg(msgid=994,
307 . msgtype=msgerror,
308 . anmode=aninfo_blind_2,
309 . i1=id,
310 . c1=titr,
311 . i2=itab(i1),i3=itab(i2))
312c write(iout,*) '***ERROR: Too much commun Seg with line:',
313c + Itab(I1),Itab(I2)
314c CALL ARRET(2)
315 END IF
316#endif
317C-----------------------------------------------
318 RETURN
319 END
320!||====================================================================
321!|| same_seg ../starter/source/interfaces/inter3d1/i24tools.F
322!||--- called by ------------------------------------------------------
323!|| comm_seg_e ../starter/source/interfaces/inter3d1/i24inisu_nei.F
324!|| i25neigh_seg_e ../starter/source/interfaces/inter3d1/i25neigh.F
325!||--- calls -----------------------------------------------------
326!|| intab ../starter/source/interfaces/inter3d1/i24tools.F
327!||====================================================================
328 LOGICAL FUNCTION same_seg(IRECT1,IRECT2)
329C-----------------------------------------------
330C I m p l i c i t T y p e s
331C-----------------------------------------------
332#include "implicit_f.inc"
333C-----------------------------------------------
334C D u m m y A r g u m e n t s
335C-----------------------------------------------
336 INTEGER irect1(*),irect2(*)
337C-----------------------------------------------
338c FUNCTION: if two segs have the same node numbers
339c
340c Note:
341c ARGUMENTS: (I: input, O: output, IO: input * output, W: workspace)
342c
343c TYPE NAME FUNCTION
344c I IRECT1,2 - connectivity of segment
345C-----------------------------------------------
346C External function
347C-----------------------------------------------
348 LOGICAL intab
349 EXTERNAL intab
350C-----------------------------------------------
351C L o c a l V a r i a b l e s
352C-----------------------------------------------
353 INTEGER i,j
354C----6---------------------------------------------------------------7---------8
355 same_seg=.true.
356 DO i = 1,4
357 j= irect2(i)
358 IF (.NOT.intab(4,irect1,j)) THEN
359 same_seg=.false.
360 cycle
361 END IF
362 END DO
363C----6---------------------------------------------------------------7---------8
364 RETURN
365 END
366!||====================================================================
367!|| seg_opp ../starter/source/interfaces/inter3d1/i24tools.F
368!||--- called by ------------------------------------------------------
369!|| comm_seg_en ../starter/source/interfaces/inter3d1/i24inisu_nei.f
370!||--- calls -----------------------------------------------------
371!|| intab ../starter/source/interfaces/inter3d1/i24tools.F
372!|| norma4n ../starter/source/interfaces/inter3d1/norma1.F
373!||====================================================================
374 SUBROUTINE seg_opp(EI,EJ,IRECT,X ,IOP)
375C-----------------------------------------------
376C I m p l i c i t T y p e s
377C-----------------------------------------------
378#include "implicit_f.inc"
379C-----------------------------------------------
380C D u m m y A r g u m e n t s
381C-----------------------------------------------
382 INTEGER EI,EJ,IRECT(4,*),IOP
383C REAL
384 my_real
385 . x(3,*)
386C----if the normal of two segments are opposite or near opposite
387C----if two common segs, will also be eliminated
388C-----------------------------------------------
389C External function
390C-----------------------------------------------
391 LOGICAL INTAB
392 EXTERNAL intab
393C-----------------------------------------------
394C L o c a l V a r i a b l e s
395C-----------------------------------------------
396 my_real
397 . area,nxi,nyi,nzi,nxj,nyj,nzj,s
398 INTEGER I,J,NN
399C---
400 iop=0
401 CALL norma4n(nxi,nyi,nzi,area,irect(1,ei),x )
402 CALL norma4n(nxj,nyj,nzj,area,irect(1,ej),x )
403 s=nxi*nxj+nyi*nyj+nzi*nzj
404 IF (s<zero.AND.abs(s)>0.99) iop=1
405 IF (iop == 0 ) THEN
406 nn = 0
407 DO i = 1,3
408 j= irect(i,ei)
409 IF (intab(3,irect(1,ej),j)) nn = nn +1
410 IF (irect(3,ej)/=irect(4,ej).AND.j==irect(4,ej)) nn = nn +1
411 END DO
412 IF (irect(3,ei)/=irect(4,ei)) THEN
413 j=irect(4,ei)
414 IF (intab(3,irect(1,ej),j)) nn = nn +1
415 IF (irect(3,ej)/=irect(4,ej).AND.j==irect(4,ej)) nn = nn +1
416 END IF
417 IF (nn > 2) iop = 1
418 END IF !IF (IOP == 0 )
419C-----------------------------------------------
420 RETURN
421 END
422!||====================================================================
423!|| removeic ../starter/source/interfaces/inter3d1/i24tools.F
424!||--- calls -----------------------------------------------------
425!|| norma4n ../starter/source/interfaces/inter3d1/norma1.F
426!|| normv3 ../starter/source/interfaces/inter3d1/i24tools.F
427!|| voisin2 ../starter/source/interfaces/inter3d1/i24tools.F
428!||====================================================================
429 SUBROUTINE removeic(N,IC,ISELF,IRECT,X ,I1,I2,IASYM,IRR)
430C----6---------------------------------------------------------------7---------8
431C I m p l i c i t T y p e s
432C-----------------------------------------------
433#include "implicit_f.inc"
434C-----------------------------------------------
435C D u m m y A r g u m e n t s
436C-----------------------------------------------
437 INTEGER N,IC(*),ISELF,IRECT(4,*),I1,I2,IE,IASYM,IRR
438 my_real
439 . x(3,*)
440C----ne reste qu'un seg
441C-----------------------------------------------
442C L o c a l V a r i a b l e s
443C-----------------------------------------------
444 INTEGER I,J,J1,J2,INV
445 my_real
446 . s,yj(3,n),yi(3),y0(3),yjni(n),angle(n),smin,norm,
447 . nxi,nyi,nzi
448C----build ksi vectors for EI(-ksi) and EJ()
449 y0(1) = half*(x(1,i1)+x(1,i2))
450 y0(2) = half*(x(2,i1)+x(2,i2))
451 y0(3) = half*(x(3,i1)+x(3,i2))
452 DO j=1,3
453 yi(j)=-y0(j)
454 DO i=1,n
455 yj(j,i)=-y0(j)
456 END DO
457 END DO
458C
459 DO j=1,4
460 j1=irect(j,iself)
461 IF (j1 /= i1 .AND. j1 /= i2) THEN
462 yi(1)=yi(1)+x(1,j1)
463 yi(2)=yi(2)+x(2,j1)
464 yi(3)=yi(3)+x(3,j1)
465 END IF
466 END DO
467 CALL normv3(yi,norm)
468C
469 DO i=1,n
470 ie=ic(i)
471 DO j=1,4
472 j1=irect(j,ie)
473 IF (j1 /= i1 .AND. j1 /= i2) THEN
474 yj(1,i)=yj(1,i)+x(1,j1)
475 yj(2,i)=yj(2,i)+x(2,j1)
476 yj(3,i)=yj(3,i)+x(3,j1)
477 END IF
478 END DO
479 END DO
480C
481 CALL norma4n(nxi,nyi,nzi,norm,irect(1,iself) ,x )
482C
483 DO i=1,n
484 CALL normv3(yj(1,i),norm)
485 yjni(i)=nxi*yj(1,i)+nyi*yj(2,i)+nzi*yj(3,i)
486 angle(i)=abs(yi(1)*yj(1,i)+yi(2)*yj(2,i)+yi(3)*yj(3,i))
487C---------remove asymmetric shell seg-----
488 ie=ic(i)
489 IF (iasym>0) THEN
490 CALL voisin2(irect(1,iself),irect(1,ie),x ,i1 ,i2,
491 + yi,yj(1,i),inv)
492 IF (inv > 0) angle(i) = ep10
493 END IF !(IASYM>0) THEN
494 END DO
495C
496 smin=ep10
497 j1=0
498C--------groupe YJ*Ni>=0 first
499 j=0
500 DO i=1,n
501 IF (yjni(i)>=zero) THEN
502 IF(smin > angle(i)) THEN
503 smin=angle(i)
504 j1=i
505 END IF
506 j=j+1
507 END IF
508 END DO
509C--------same side
510 IF (j==n) THEN
511C--------only groupe YJ*Ni<0 or no valid one
512 ELSEIF(j==0.OR.j1==0) THEN
513 smin=ep10
514 DO i=1,n
515 IF(yjni(i) < zero .AND. smin > angle(i)) THEN
516 smin=angle(i)
517 j1=i
518 END IF
519 END DO
520 END IF
521C ------still no valid one-----------
522 IF (j1==0) then
523c print *,'***warning** No valid Neighbour Segs of',N,' candidats'
524 irr = 11
525 ic(1)=0
526 ELSE
527 ic(1)=ic(j1)
528 END IF
529C
530 DO i=2,n
531 ic(i)=0
532 END DO
533C----6---------------------------------------------------------------7---------8
534 RETURN
535 END
536!||====================================================================
537!|| removeic1 ../starter/source/interfaces/inter3d1/i24tools.F
538!||--- called by ------------------------------------------------------
539!|| comm_seg_en ../starter/source/interfaces/inter3d1/i24inisu_nei.F
540!||--- calls -----------------------------------------------------
541!|| norma4n ../starter/source/interfaces/inter3d1/norma1.f
542!|| normv3 ../starter/source/interfaces/inter3d1/i24tools.F
543!|| voisin1 ../starter/source/interfaces/inter3d1/voisin1.f
544!||====================================================================
545 SUBROUTINE removeic1(N,IC,ISELF,IRECT,X ,I1,I2,IASYM,IRR)
546C-----------------------------------------------
547C I m p l i c i t T y p e s
548C-----------------------------------------------
549#include "implicit_f.inc"
550C-----------------------------------------------
551C D u m m y A r g u m e n t s
552C-----------------------------------------------
553 INTEGER N,IC(*),ISELF,IRECT(4,*),I1,I2,IE,IASYM,IRR
554C REAL
555 my_real
556 . x(3,*)
557C----ne reste qu'un seg
558C-----------------------------------------------
559C L o c a l V a r i a b l e s
560C-----------------------------------------------
561 INTEGER I,J,J1,J2,INV,ipr
562 my_real
563 . s,yj(3,n),yi(3),y0(3),yjni(n),angle(n),smin,norm,
564 . nxi,nyi,nzi,x12,y12,z12,nxj,nyj,nzj,smax
565C----elimine first one of asymmetric shell seg
566 inv = 0
567 DO i=1,n
568 angle(i)=zero
569 END DO
570 IF (iasym>0) THEN
571 DO i=1,n
572C---------remove asymmetric shell seg-----
573 ie=ic(i)
574 CALL voisin1(irect(1,iself),irect(1,ie),i1 ,i2 ,inv)
575 IF (inv > 0) angle(i) = ep10
576 END DO
577 END IF !(IASYM>0) THEN
578C --------YI = N_iself ^ 12
579 CALL norma4n(nxi,nyi,nzi,norm,irect(1,iself) ,x )
580 x12= x(1,i2)-x(1,i1)
581 y12= x(2,i2)-x(2,i1)
582 z12= x(3,i2)-x(3,i1)
583 yi(1)=nyi*z12-nzi*y12
584 yi(2)=nzi*x12-nxi*z12
585 yi(3)=nxi*y12-nyi*x12
586 CALL normv3(yi,norm)
587 j=0
588 DO i=1,n
589 IF (angle(i)==ep10) cycle
590 ie=ic(i)
591 CALL norma4n(nxj,nyj,nzj,norm,irect(1,ie) ,x )
592C----YJ = N_ie ^ 21
593 yj(1,i)=-nyj*z12+nzj*y12
594 yj(2,i)=-nzj*x12+nxj*z12
595 yj(3,i)=-nxj*y12+nyj*x12
596 CALL normv3(yj(1,i),norm)
597 yjni(i)=nxi*yj(1,i)+nyi*yj(2,i)+nzi*yj(3,i)
598 IF (yjni(i)>=zero) j=j+1
599 angle(i)=yi(1)*yj(1,i)+yi(2)*yj(2,i)+yi(3)*yj(3,i)
600 END DO
601C
602 smax=-onep01
603 j1=0
604C--------groupe YJ*Ni>=0 :concave keep angle (max_cos) only
605 DO i=1,n
606 IF (angle(i)==ep10.OR.yjni(i)<zero) cycle
607 IF (angle(i)>=-one) THEN
608 IF(smax < angle(i)) THEN
609 smax=angle(i)
610 j1=i
611 END IF
612 END IF !(ANGLE(I)>=-ONE) THEN
613 END DO
614C------angle >180------
615 IF(j1==0.AND.j >0) THEN
616 smin=ep10
617 DO i=1,n
618 IF (angle(i)==ep10.OR.yjni(i)<zero) cycle
619 IF (smin > angle(i)) THEN
620 smin=angle(i)
621 j1=i
622 END IF
623 END DO
624 END IF
625C--------same side
626 IF (j==n) THEN
627C--------only groupe YJ*Ni<0(convex) and no valid one before
628 ELSEIF(j==0.OR.j1==0) THEN
629C------angle >180- first-----
630 smax=-onep01
631 DO i=1,n
632 IF (angle(i)==ep10.OR.yjni(i)>=zero) cycle
633 IF(angle(i)< -one .AND.smax < angle(i)) THEN
634 smax=angle(i)
635 j1=i
636 END IF
637 END DO
638C ------------------
639 IF (j1==0) then
640 smin=ep10
641 DO i=1,n
642 IF (angle(i)==ep10.OR.yjni(i)>=zero) cycle
643C--------groupe YJ*Ni<0 :convex keep angle (min_cos) only
644 IF(angle(i)>= -one .AND. smin > angle(i)) THEN
645 smin=angle(i)
646 j1=i
647 END IF
648 END DO
649 END IF !(J1==0) then
650 END IF !(J==N) then
651C ------still no valid one-----------
652 IF (j1==0) then
653c print *,'***warning** No valid Neighbour Segs of',N,' candidats'
654 irr = 11
655 ic(1)=0
656 ELSE
657 ic(1)=ic(j1)
658 END IF
659C
660 DO i=2,n
661 ic(i)=0
662 END DO
663C-----------------------------------------------
664 RETURN
665 END
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
comm_seg_en
subroutine comm_seg_en(n1, ied1, n2, ied2, ne, ice, iself, i1, i2, irect, im2sh, nn, icn, x, ie, in, irr)
Definition i24inisu_nei.F:219
i24normns
subroutine i24normns(x, irect, nrt, nsn, nsv, pen_old, stf)
Definition i24sti3.F:1908
i24sti3
subroutine i24sti3(x, irect, stf, ixs, pm, geo, nrt, ixc, nint, stfac, nty, gap, noint, stfn, nsn, ms, nsv, ixtg, igap, wa, gap_s, gap_m, gapmin, ixt, ixp, gapinf, gapmax_s, inacti, knod2els, knod2elc, knod2eltg, nod2els, nod2elc, nod2eltg, igrsurf, intth, ieles, ielec, areas, sh4tree, sh3tree, ipart, ipartc, iparttg, thk, thk_part, ixr, itab, bgapsmx, ixs10, msegtyp, nrt_sh, ixs16, ixs20, gap_n, mvoisn, ilev, igrsurf2, gapmax_m, id, titr, igap0, pen_old, ipartns, iparts, igeo, fillsol, pm_stack, iworksh, intfric, tagprt_fric, ipartfrics, ipartfricm, intbuf_fric_tab, intnitsche, nrts, irects, ielnrts, adrects, facnrts, nmn, msr, ipartt, ipartp, ipartr, elem_linked_to_segment, igsti, flag_elem_inter25)
Definition i24sti3.F:55
seg_opp
subroutine seg_opp(ei, ej, irect, x, iop)
Definition i24tools.F:375
re_ori
subroutine re_ori(i1, i2, in, x)
Definition i24tools.F:224
add_n_id
subroutine add_n_id(n, ic, id)
Definition i24tools.F:59
removeic1
subroutine removeic1(n, ic, iself, irect, x, i1, i2, iasym, irr)
Definition i24tools.F:546
msg_err
subroutine msg_err(i1, i2, itab, irr, id, titr)
Definition i24tools.F:271
normv3
subroutine normv3(v, norm)
Definition i24tools.F:129
same_seg
logical function same_seg(irect1, irect2)
Definition i24tools.F:329
removeic
subroutine removeic(n, ic, iself, irect, x, i1, i2, iasym, irr)
Definition i24tools.F:430
intab
logical function intab(nic, ic, n)
Definition i24tools.F:95
voisin2
subroutine voisin2(nc1, nc2, x, i1, i2, yi, yj, inv)
Definition i24tools.F:164
add_id
subroutine add_id(n, ic, id)
Definition i24tools.F:30
i25neigh
subroutine i25neigh(nrtm, nsn, nsv, irect, irtlm, mvoisin, evoisin, mseglo, msegtyp, itab, x, id, titr, igeo, nadmsr, admsr, adskyn, iadnor, nrtm_sh, iedge, nedge, ledge, lbound, edg_cos, nisub, lisub, addsubm, lisubm, inflg_subm, nisube, addsube, lisube, inflg_sube, noint, nmn, msr, nom_opt, ilev, mbinflg, ebinflg, ielem_m, idel_solid)
Definition i25neigh.F:45
i25neigh_seg_e
subroutine i25neigh_seg_e(n1, ied1, n2, ied2, n, ic, iself, i1, i2, irect, nrtm, msegtyp, mvoisin)
Definition i25neigh.F:1384
int2cy_chk
subroutine int2cy_chk(ipari, intbuf_tab, itagcyc, itab)
Definition lecbcscyc.F:425
max
#define max(a, b)
Definition macros.h:21
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
norma4n
subroutine norma4n(n1, n2, n3, area, irect, x)
Definition norma1.F:132
norma1
subroutine norma1(n1, n2, n3, area, xx1, xx2, xx3)
Definition norma1.F:38
norma4nx
subroutine norma4nx(n1, n2, n3, area, irect, x, i1, i2, shf)
Definition norma1.F:183
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
voisin1
subroutine voisin1(nc1, nc2, i1, i2, inv)
Definition voisin1.F:29