OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i2dst3_27.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!|| i2dst3_27 ../starter/source/interfaces/inter3d1/i2dst3_27.F
25!||--- called by ------------------------------------------------------
26!|| i2trivox ../starter/source/interfaces/inter3d1/i2trivox.F90
27!||--- calls -----------------------------------------------------
28!|| choose_main_segment ../starter/source/interfaces/inter3d1/i2dst3_27.F
29!|| i2bar3 ../starter/source/interfaces/inter3d1/i2dst3.f
30!||====================================================================
31 SUBROUTINE i2dst3_27(first,last,
32 . GAPV,CAND_E ,CAND_N,TZINF,IRTL,ST,DMIN,IGNORE,
33 . IRECT,
34 . IX3,
35 1 IX4,X1 ,X2 ,X3 ,X4 ,
36 1 Y1 ,Y2 ,Y3 ,Y4 ,Z1 ,
37 2 Z2 ,Z3 ,Z4 ,XI ,YI ,
38 3 ZI ,X0 ,Y0 ,Z0 ,NX1,
39 4 NY1,NZ1,NX2,NY2,NZ2,
40 5 NX3,NY3,NZ3,NX4,NY4,
41 6 NZ4,P1 ,P2 ,P3 ,P4 ,
42 7 LB1,LB2,LB3,LB4,LC1,
43 8 LC2,LC3,LC4,S ,T )
44C============================================================================
45C this routine is called by: i2tri(/inter3d1/i2tri.f)
46C I2BUC1(/inter3d1/i2buc1.F)
47C----------------------------------------------------------------------------
48C cette routine appelle : I7BAR3(/inter3d1/i7bar3.F)
49C============================================================================
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C G l o b a l P a r a m e t e r s
56C-----------------------------------------------
57#include "mvsiz_p.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 integer, intent(in) :: first !< first index of the candidates
62 integer, intent(in) :: last !< last index of the candidates
63 INTEGER CAND_E(*),CAND_N(*),IRTL(*),IGNORE,
64 . IRECT(4,*)
65 my_real
66 . GAPV(*),TZINF,ST(2,*),DMIN(*)
67 INTEGER, DIMENSION(MVSIZ), INTENT(IN) :: IX3,IX4
68 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: X1,X2,X3,X4
69 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: Y1,Y2,Y3,Y4
70 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: Z1,Z2,Z3,Z4
71 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: XI,YI,ZI
72 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: X0,Y0,Z0
73 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx1,ny1,nz1
74 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx2,ny2,nz2
75 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx3,ny3,nz3
76 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx4,ny4,nz4
77 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: p1,p2,p3,p4
78 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: lb1,lb2,lb3,lb4
79 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: lc1,lc2,lc3,lc4
80 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: s,t
81C-----------------------------------------------
82C C o m m o n B l o c k s
83C-----------------------------------------------
84#include "param_c.inc"
85#include "vect07_c.inc"
86C-----------------------------------------------
87C L o c a l V a r i a b l e s
88C-----------------------------------------------
89 INTEGER TFLAG(MVSIZ)
90 INTEGER I, II
91 my_real pene(mvsiz)
92C-----------------------------------------------
93C=======================================================================
94C
95C-----------------------------------------------
96C DERIVED FROM I2DST3 - improved projection on triangles
97C-----------------------------------------------
98C
99 DO i=first,last
100 x0(i) = fourth*(x1(i)+x2(i)+x3(i)+x4(i))
101 y0(i) = fourth*(y1(i)+y2(i)+y3(i)+y4(i))
102 z0(i) = fourth*(z1(i)+z2(i)+z3(i)+z4(i))
103 ENDDO
104C
105 DO i=first,last
106 IF (ix3(i) == ix4(i)) THEN
107 x0(i) = x3(i)
108 y0(i) = y3(i)
109 z0(i) = z3(i)
110 tflag(i) = 1
111 ELSE
112 tflag(i) = 0
113 ENDIF
114 ENDDO
115C
116 CALL i2bar3(first,last,
117 . xi ,yi ,zi ,x0 ,y0 ,
118 . z0 ,x1 ,y1 ,z1 ,x2 ,
119 . y2 ,z2 ,nx1,ny1,nz1,
120 . lb1 ,lc1 ,p1 ,gapv, tflag )
121C
122 CALL i2bar3(first,last,
123 . xi ,yi ,zi ,x0 ,y0 ,
124 . z0 ,x2 ,y2 ,z2 ,x3 ,
125 . y3 ,z3 ,nx2,ny2,nz2,
126 . lb2 ,lc2 ,p2 ,gapv, tflag )
127C
128 CALL i2bar3(first,last,
129 . xi ,yi ,zi ,x0 ,y0 ,
130 . z0 ,x3 ,y3 ,z3 ,x4 ,
131 . y4 ,z4 ,nx3,ny3,nz3,
132 . lb3 ,lc3 ,p3 ,gapv, tflag )
133C
134 CALL i2bar3(first,last,
135 . xi ,yi ,zi ,x0 ,y0 ,
136 . z0 ,x4 ,y4 ,z4 ,x1 ,
137 . y1 ,z1 ,nx4,ny4,nz4,
138 . lb4 ,lc4 ,p4 ,gapv, tflag )
139C
140 DO i=first,last
141 IF (tflag(i) == 1) THEN
142 pene(i) = p1(i)
143 s(i) = lb1(i)
144 t(i) = lc1(i)
145 ELSE
146 pene(i) = max(p1(i),p2(i),p3(i),p4(i))
147 IF(p1(i)==pene(i))THEN
148 s(i) = -lb1(i) + lc1(i)
149 t(i) = -lb1(i) - lc1(i)
150 ELSEIF(p2(i)==pene(i))THEN
151 s(i) = lb2(i) + lc2(i)
152 t(i) = -lb2(i) + lc2(i)
153 ELSEIF(p3(i)==pene(i))THEN
154 s(i) = lb3(i) - lc3(i)
155 t(i) = lb3(i) + lc3(i)
156 ELSEIF(p4(i)==pene(i))THEN
157 s(i) = -lb4(i) - lc4(i)
158 t(i) = lb4(i) - lc4(i)
159 ELSE
160 s(i) = zero
161 t(i) = zero
162 ENDIF
163 ENDIF
164 ENDDO
165C
166 IF(ignore==2 .OR. ignore == 3)THEN
167 DO i=first,last
168 IF(pene(i)>zero .AND.
169 . (s(i) < onep5 .AND.
170 . t(i) < onep5 .AND.
171 . s(i) >-onep5 .AND.
172 . t(i) >-onep5))THEN
173 ii=cand_n(i)
174 IF(gapv(i) - pene(i)<dmin(ii))THEN
175 dmin(ii)=gapv(i)-pene(i)
176 irtl(ii)=cand_e(i)
177 st(1,ii) = s(i)
178 st(2,ii) = t(i)
179 ELSEIF(gapv(i) - pene(i)==dmin(ii))THEN
180 CALL choose_main_segment(irect,irtl(ii),cand_e(i),s(i),t(i),st(1,ii),st(2,ii),tflag(i))
181 ENDIF
182 ENDIF
183 ENDDO
184 ELSEIF(ignore==1)THEN
185 DO i=first,last
186C
187 IF(pene(i)>zero .AND.
188 . (s(i) < onep5 .AND.
189 . t(i) < onep5 .AND.
190 . s(i) >-onep5 .AND.
191 . t(i) >-onep5)) THEN
192 ii=cand_n(i)
193
194 IF(tzinf - pene(i)<dmin(ii))THEN
195 dmin(ii)=tzinf - pene(i)
196 irtl(ii)=cand_e(i)
197 st(1,ii) = s(i)
198 st(2,ii) = t(i)
199 ELSEIF(tzinf - pene(i)==dmin(ii))THEN
200 CALL choose_main_segment(irect,irtl(ii),cand_e(i),s(i),t(i),st(1,ii),st(2,ii),tflag(i))
201 ENDIF
202 ENDIF
203 ENDDO
204 ELSE
205 DO i=first,last
206C
207 IF(pene(i)>zero) THEN
208 ii=cand_n(i)
209
210 IF(tzinf - pene(i)<dmin(ii))THEN
211 dmin(ii)=tzinf - pene(i)
212 irtl(ii)=cand_e(i)
213 st(1,ii) = s(i)
214 st(2,ii) = t(i)
215 ELSEIF(tzinf - pene(i)==dmin(ii))THEN
216 CALL choose_main_segment(irect,irtl(ii),cand_e(i),s(i),t(i),st(1,ii),st(2,ii),tflag(i))
217 ENDIF
218 ENDIF
219 ENDDO
220 ENDIF
221C
222 RETURN
223 END
224C
225!||====================================================================
226!|| choose_main_segment ../starter/source/interfaces/inter3d1/i2dst3_27.F
227!||--- called by ------------------------------------------------------
228!|| i2dst3_27 ../starter/source/interfaces/inter3d1/i2dst3_27.F
229!||====================================================================
230 SUBROUTINE choose_main_segment(IRECT,M_OLD,M_NEW,S_NEW,T_NEW,S,T,TFLAG)
231C============================================================================
232C-----------------------------------------------
233C I m p l i c i t T y p e s
234C-----------------------------------------------
235#include "implicit_f.inc"
236C-----------------------------------------------
237C D u m m y A r g u m e n t s
238C-----------------------------------------------
239 INTEGER IRECT(4,*),M_OLD,M_NEW,TFLAG
240 my_real
241 . S_NEW,T_NEW,S,T
242C-----------------------------------------------
243C L o c a l V a r i a b l e s
244C-----------------------------------------------
245 INTEGER TFLAG_OLD,INTERIOR_OLD,INTERIOR,SWITCH
246C-----------------------------------------------
247C
248 IF (IRECT(3,M_OLD)==irect(4,m_old)) THEN
249 tflag_old = 1
250 IF ((s>=zero).AND.(t>=zero).AND.(one-s-t>=zero)) THEN
251 interior_old = 1
252 ELSE
253 interior_old = 0
254 ENDIF
255 ELSE
256 tflag_old = 0
257 IF ((abs(s)<=one).AND.(abs(t)<=one)) THEN
258 interior_old = 1
259 ELSE
260 interior_old = 0
261 ENDIF
262 ENDIF
263C
264 IF (tflag==1) THEN
265 IF ((s_new>=zero).AND.(t_new>=zero).AND.(one-s_new-t_new>=zero)) THEN
266 interior = 1
267 ELSE
268 interior = 0
269 ENDIF
270 ELSE
271 IF ((abs(s_new)<=one).AND.(abs(t_new)<=one)) THEN
272 interior = 1
273 ELSE
274 interior = 0
275 ENDIF
276 ENDIF
277C
278C-- Choose segment to keep as main segment
279 switch = 0
280 IF ((tflag_old==0).AND.(tflag==0)) THEN
281C-- two quadrangles
282 IF (max(abs(s_new),abs(t_new))<max(abs(s),abs(t))) switch = 1
283 ELSE
284C-- At least on segment is a triangle
285 IF (interior_old < interior) THEN
286 switch = 1
287 ELSEIF (interior_old == interior) THEN
288C-- The segment with projection closest to center is retained ((1/3,1/3) for triangles and (0,0) for quadrangles)
289 IF (((s_new-third*tflag)**2+(t_new-third*tflag)**2)<
290 . ((s-third*tflag_old)**2+(t-third*tflag_old)**2)) switch = 1
291 ENDIF
292 ENDIF
293C
294 IF (switch == 1) THEN
295 m_old = m_new
296 s = s_new
297 t = t_new
298 ENDIF
299C
300 RETURN
301 END
i2dst3
subroutine i2dst3(first, last, gapv, cand_e, cand_n, tzinf, irtl, st, dmin, ignore, ix3, ix4, x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, xi, yi, zi, x0, y0, z0, nx1, ny1, nz1, nx2, ny2, nz2, nx3, ny3, nz3, nx4, ny4, nz4, p1, p2, p3, p4, lb1, lb2, lb3, lb4, lc1, lc2, lc3, lc4, s, t)
Definition i2dst3.F:42
i2bar3
subroutine i2bar3(first, last, xi, yi, zi, xa, ya, za, xb, yb, zb, xc, yc, zc, nx, ny, nz, lb, lc, p, gapv, tflag)
Definition i2dst3.F:254
choose_main_segment
subroutine choose_main_segment(irect, m_old, m_new, s_new, t_new, s, t, tflag)
Definition i2dst3_27.F:231
i2dst3_27
subroutine i2dst3_27(first, last, gapv, cand_e, cand_n, tzinf, irtl, st, dmin, ignore, irect, ix3, ix4, x1, x2, x3, x4, y1, y2, y3, y4, z1, z2, z3, z4, xi, yi, zi, x0, y0, z0, nx1, ny1, nz1, nx2, ny2, nz2, nx3, ny3, nz3, nx4, ny4, nz4, p1, p2, p3, p4, lb1, lb2, lb3, lb4, lc1, lc2, lc3, lc4, s, t)
Definition i2dst3_27.F:44
max
#define max(a, b)
Definition macros.h:21
starter
program starter
Definition starter.F:39