OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i24tools.F File Reference
#include "implicit_f.inc"
#include "scr03_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine add_id (n, ic, id)
subroutine add_n_id (n, ic, id)
logical function intab (nic, ic, n)
subroutine normv3 (v, norm)
subroutine voisin2 (nc1, nc2, x, i1, i2, yi, yj, inv)
subroutine re_ori (i1, i2, in, x)
subroutine msg_err (i1, i2, itab, irr, id, titr)
logical function same_seg (irect1, irect2)
subroutine seg_opp (ei, ej, irect, x, iop)
subroutine removeic (n, ic, iself, irect, x, i1, i2, iasym, irr)
subroutine removeic1 (n, ic, iself, irect, x, i1, i2, iasym, irr)

Function/Subroutine Documentation

◆ add_id()

subroutine add_id ( integer n,
integer, dimension(*) ic,
integer id )

Definition at line 29 of file i24tools.F.

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
id
initmumps id
Definition multiplerhs_example.m:4

◆ add_n_id()

subroutine add_n_id ( integer n,
integer, dimension(*) ic,
integer id )

Definition at line 58 of file i24tools.F.

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

◆ intab()

logical function intab ( integer nic,
integer, dimension(*) ic,
integer n )

Definition at line 94 of file i24tools.F.

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
intab
logical function intab(nic, ic, n)
Definition i24tools.F:95

◆ msg_err()

subroutine msg_err ( integer i1,
integer i2,
integer, dimension(*) itab,
integer irr,
integer id,
character(len=nchartitle) titr )

Definition at line 270 of file i24tools.F.

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
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

◆ normv3()

subroutine normv3 ( v,
norm )

Definition at line 128 of file i24tools.F.

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
my_real
#define my_real
Definition cppsort.cpp:32
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
max
#define max(a, b)
Definition macros.h:21

◆ re_ori()

subroutine re_ori ( integer i1,
integer i2,
integer, dimension(*) in,
x )

Definition at line 223 of file i24tools.F.

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

◆ removeic()

subroutine removeic ( integer n,
integer, dimension(*) ic,
integer iself,
integer, dimension(4,*) irect,
x,
integer i1,
integer i2,
integer iasym,
integer irr )

Definition at line 429 of file i24tools.F.

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
normv3
subroutine normv3(v, norm)
Definition i24tools.F:129
voisin2
subroutine voisin2(nc1, nc2, x, i1, i2, yi, yj, inv)
Definition i24tools.F:164
norma4n
subroutine norma4n(n1, n2, n3, area, irect, x)
Definition norma1.F:132

◆ removeic1()

subroutine removeic1 ( integer n,
integer, dimension(*) ic,
integer iself,
integer, dimension(4,*) irect,
x,
integer i1,
integer i2,
integer iasym,
integer irr )

Definition at line 545 of file i24tools.F.

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
voisin1
subroutine voisin1(nc1, nc2, i1, i2, inv)
Definition voisin1.F:29

◆ same_seg()

logical function same_seg ( integer, dimension(*) irect1,
integer, dimension(*) irect2 )

Definition at line 328 of file i24tools.F.

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
same_seg
logical function same_seg(irect1, irect2)
Definition i24tools.F:329

◆ seg_opp()

subroutine seg_opp ( integer ei,
integer ej,
integer, dimension(4,*) irect,
x,
integer iop )

Definition at line 374 of file i24tools.F.

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
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567

◆ voisin2()

subroutine voisin2 ( integer, dimension(*) nc1,
integer, dimension(*) nc2,
x,
integer i1,
integer i2,
yi,
yj,
integer inv )

Definition at line 163 of file i24tools.F.

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
norma4nx
subroutine norma4nx(n1, n2, n3, area, irect, x, i1, i2, shf)
Definition norma1.F:183