OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
itribox.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!|| itribox ../starter/source/airbag/itribox.F
25!||--- called by ------------------------------------------------------
26!|| fvmesh1 ../starter/source/airbag/fvmesh.F
27!||--- calls -----------------------------------------------------
28!|| polclip ../starter/source/airbag/itribox.f
29!||====================================================================
30 SUBROUTINE itribox(TRI, BOX, NORM, NVERTS, POLY, NVMAX)
31C-----------------------------------------------
32C I m p l i c i t T y p e s
33C-----------------------------------------------
34#include "implicit_f.inc"
35C-----------------------------------------------
36C D u m m y A r g u m e n t s
37C-----------------------------------------------
38 INTEGER NVERTS, NVMAX
39 my_real
40 . tri(3,*), box(3,*), norm(3,*), poly(3,*)
41C-----------------------------------------------
42C L o c a l V a r i a b l e s
43C-----------------------------------------------
44 INTEGER I, NPOUT, J
45 INTEGER JJ, NN, IFOUND, REDIR(NVMAX)
46 my_real
47 . a(3), n(3), polyout(3,nvmax)
48 my_real
49 . x1, y1, z1, x2, y2, z2, dd, tole
50 INTEGER P_REF(6)
51 DATA p_ref /1,5,1,2,3,4/
52#ifdef MYREAL8
53 tole=em10
54#else
55 tole=em5
56#endif
57C Intersection triangle-box
58 nverts=3
59 DO i=1,nverts
60 poly(1,i)=tri(1,i)
61 poly(2,i)=tri(2,i)
62 poly(3,i)=tri(3,i)
63 ENDDO
64C
65 DO i=1,6
66 a(1)=box(1,p_ref(i))
67 a(2)=box(2,p_ref(i))
68 a(3)=box(3,p_ref(i))
69 n(1)=norm(1,i)
70 n(2)=norm(2,i)
71 n(3)=norm(3,i)
72 CALL polclip(poly, nverts, a, n, polyout, npout)
73 nverts=npout
74 DO j=1,nverts
75 poly(1,j)=polyout(1,j)
76 poly(2,j)=polyout(2,j)
77 poly(3,j)=polyout(3,j)
78 ENDDO
79 ENDDO
80C Elimination des noeuds doubles
81 nn=0
82 DO i=1,nverts
83 x1=poly(1,i)
84 y1=poly(2,i)
85 z1=poly(3,i)
86 ifound=0
87 DO j=1,nn
88 jj=redir(j)
89 x2=poly(1,jj)
90 y2=poly(2,jj)
91 z2=poly(3,jj)
92 dd=sqrt((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)
93 IF (dd<=tole) ifound=j
94 ENDDO
95 IF (ifound==0) THEN
96 nn=nn+1
97 redir(nn)=i
98 ENDIF
99 ENDDO
100C
101 nverts=nn
102 DO i=1,nverts
103 poly(1,i)=polyout(1,redir(i))
104 poly(2,i)=polyout(2,redir(i))
105 poly(3,i)=polyout(3,redir(i))
106 ENDDO
107C
108 RETURN
109 END
110!||====================================================================
111!|| polclip ../starter/source/airbag/itribox.F
112!||--- called by ------------------------------------------------------
113!|| itribox ../starter/source/airbag/itribox.F
114!||====================================================================
115 SUBROUTINE polclip(POLYIN, NPIN, A, N, POLYOUT, NPOUT )
116C-----------------------------------------------
117C I m p l i c i t T y p e s
118C-----------------------------------------------
119#include "implicit_f.inc"
120C-----------------------------------------------
121C D u m m y A r g u m e n t s
122C-----------------------------------------------
123 INTEGER NPIN, NPOUT
124 my_real polyin(3,*), a(*), n(*), polyout(3,*)
125C-----------------------------------------------
126C L o c a l V a r i a b l e s
127C-----------------------------------------------
128 INTEGER I, II
129 my_real x1, y1, z1, x2, y2, z2, ss1, ss2, x12, y12, z12, xa1, ya1, za1, alpha, xm, ym, zm, ssn
130
131C polygon clipping with a plane
132 npout=0
133 DO i=1,npin
134 IF (i/=npin) THEN
135 ii=i+1
136 ELSE
137 ii=1
138 ENDIF
139C
140 x1=polyin(1,i)
141 y1=polyin(2,i)
142 z1=polyin(3,i)
143 x2=polyin(1,ii)
144 y2=polyin(2,ii)
145 z2=polyin(3,ii)
146C
147 ss1=(x1-a(1))*n(1)+(y1-a(2))*n(2)+(z1-a(3))*n(3)
148 ss2=(x2-a(1))*n(1)+(y2-a(2))*n(2)+(z2-a(3))*n(3)
149 IF (ss1<zero.AND.ss2<zero) cycle
150 IF (ss1>=zero.AND.ss2>=zero) THEN
151 npout=npout+1
152 polyout(1,npout)=x1
153 polyout(2,npout)=y1
154 polyout(3,npout)=z1
155 cycle
156 ENDIF
157C
158 x12=x2-x1
159 y12=y2-y1
160 z12=z2-z1
161 xa1=x1-a(1)
162 ya1=y1-a(2)
163 za1=z1-a(3)
164 ssn=x12*n(1)+y12*n(2)+z12*n(3)
165 alpha=-(xa1*n(1)+ya1*n(2)+za1*n(3))/ssn
166 xm=x1+alpha*x12
167 ym=y1+alpha*y12
168 zm=z1+alpha*z12
169 IF (ss1>=zero) THEN
170 npout=npout+1
171 polyout(1,npout)=x1
172 polyout(2,npout)=y1
173 polyout(3,npout)=z1
174 npout=npout+1
175 polyout(1,npout)=xm
176 polyout(2,npout)=ym
177 polyout(3,npout)=zm
178 ELSEIF (ss2>=zero) THEN
179 npout=npout+1
180 polyout(1,npout)=xm
181 polyout(2,npout)=ym
182 polyout(3,npout)=zm
183 ENDIF
184 ENDDO
185C
186 RETURN
187 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
alpha
#define alpha
Definition eval.h:35
polclip
subroutine polclip(polyin, npin, a, n, polyout, npout)
Definition itribox.F:116
itribox
subroutine itribox(tri, box, norm, nverts, poly, nvmax)
Definition itribox.F:31
starter
program starter
Definition starter.F:39