OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i2dst3.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 ../starter/source/interfaces/inter3d1/i2dst3.F
25!||--- called by ------------------------------------------------------
26!|| i2trivox ../starter/source/interfaces/inter3d1/i2trivox.F90
27!||--- calls -----------------------------------------------------
28!|| i2bar3 ../starter/source/interfaces/inter3d1/i2dst3.F
29!||====================================================================
30 SUBROUTINE i2dst3(first,last,
31 . GAPV,CAND_E ,CAND_N,TZINF,IRTL,ST,DMIN,IGNORE,
32 . IX3,
33 1 IX4,X1 ,X2 ,X3 ,X4 ,
34 1 Y1 ,Y2 ,Y3 ,Y4 ,Z1 ,
35 2 Z2 ,Z3 ,Z4 ,XI ,YI ,
36 3 ZI ,X0 ,Y0 ,Z0 ,NX1,
37 4 NY1,NZ1,NX2,NY2,NZ2,
38 5 NX3,NY3,NZ3,NX4,NY4,
39 6 NZ4,P1 ,P2 ,P3 ,P4 ,
40 7 LB1,LB2,LB3,LB4,LC1,
41 8 LC2,LC3,LC4,S ,T )
42C============================================================================
43C this routine is called by: I2TRI(/inter3d1/i2tri.F)
44C I2BUC1(/inter3d1/i2buc1.F)
45C----------------------------------------------------------------------------
46C cette routine appelle : I7BAR3(/inter3d1/i7bar3.F)
47C============================================================================
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C G l o b a l P a r a m e t e r s
54C-----------------------------------------------
55#include "mvsiz_p.inc"
56C-----------------------------------------------
57C D u m m y A r g u m e n t s
58C-----------------------------------------------
59 integer, intent(in) :: first !< first index of the candidates
60 integer, intent(in) :: last !< last index of the candidates
61 INTEGER CAND_E(*),CAND_N(*),IRTL(*),IGNORE
62 my_real
63 . GAPV(*),TZINF,ST(2,*),DMIN(*)
64 INTEGER, DIMENSION(MVSIZ), INTENT(IN) :: IX3,IX4
65 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: X1,X2,X3,X4
66 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: Y1,Y2,Y3,Y4
67 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: Z1,Z2,Z3,Z4
68 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: XI,YI,ZI
69 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: X0,Y0,Z0
70 my_real, DIMENSION(MVSIZ), INTENT(IN) :: nx1,ny1,nz1
71 my_real, DIMENSION(MVSIZ), INTENT(IN) :: nx2,ny2,nz2
72 my_real, DIMENSION(MVSIZ), INTENT(IN) :: nx3,ny3,nz3
73 my_real, DIMENSION(MVSIZ), INTENT(IN) :: nx4,ny4,nz4
74 my_real, DIMENSION(MVSIZ), INTENT(IN) :: p1,p2,p3,p4
75 my_real, DIMENSION(MVSIZ), INTENT(IN) :: lb1,lb2,lb3,lb4
76 my_real, DIMENSION(MVSIZ), INTENT(IN) :: lc1,lc2,lc3,lc4
77 my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: s,t
78C-----------------------------------------------
79C C o m m o n B l o c k s
80C-----------------------------------------------
81#include "param_c.inc"
82#include "vect07_c.inc"
83C-----------------------------------------------
84C L o c a l V a r i a b l e s
85C-----------------------------------------------
86 INTEGER TFLAG(MVSIZ)
87 INTEGER I, II
88 my_real pene(mvsiz)
89C-----------------------------------------------
90C=======================================================================
91 DO i=first,last
92 x0(i) = fourth*(x1(i)+x2(i)+x3(i)+x4(i))
93 y0(i) = fourth*(y1(i)+y2(i)+y3(i)+y4(i))
94 z0(i) = fourth*(z1(i)+z2(i)+z3(i)+z4(i))
95 ENDDO
96C
97 DO i=first,last
98 IF (ix3(i) == ix4(i)) THEN
99 x0(i) = x3(i)
100 y0(i) = y3(i)
101 z0(i) = z3(i)
102 tflag(i) = 1
103 ELSE
104 tflag(i) = 0
105 ENDIF
106 ENDDO
107C
108 CALL i2bar3(first,last,
109 . xi ,yi ,zi ,x0 ,y0 ,
110 . z0 ,x1 ,y1 ,z1 ,x2 ,
111 . y2 ,z2 ,nx1,ny1,nz1,
112 . lb1 ,lc1 ,p1 ,gapv, tflag )
113C
114 CALL i2bar3(first,last,
115 . xi ,yi ,zi ,x0 ,y0 ,
116 . z0 ,x2 ,y2 ,z2 ,x3 ,
117 . y3 ,z3 ,nx2,ny2,nz2,
118 . lb2 ,lc2 ,p2 ,gapv, tflag )
119C
120 CALL i2bar3(first,last,
121 . xi ,yi ,zi ,x0 ,y0 ,
122 . z0 ,x3 ,y3 ,z3 ,x4 ,
123 . y4 ,z4 ,nx3,ny3,nz3,
124 . lb3 ,lc3 ,p3 ,gapv, tflag )
125C
126 CALL i2bar3(first,last,
127 . xi ,yi ,zi ,x0 ,y0 ,
128 . z0 ,x4 ,y4 ,z4 ,x1 ,
129 . y1 ,z1 ,nx4,ny4,nz4,
130 . lb4 ,lc4 ,p4 ,gapv, tflag )
131C
132 DO i=first,last
133 pene(i) = max(p1(i),p2(i),p3(i),p4(i))
134C
135 IF(p1(i)==pene(i))THEN
136 s(i) = -lb1(i) + lc1(i)
137 t(i) = -lb1(i) - lc1(i)
138 ELSEIF(p2(i)==pene(i))THEN
139 s(i) = lb2(i) + lc2(i)
140 t(i) = -lb2(i) + lc2(i)
141 ELSEIF(p3(i)==pene(i))THEN
142 s(i) = lb3(i) - lc3(i)
143 t(i) = lb3(i) + lc3(i)
144 ELSEIF(p4(i)==pene(i))THEN
145 s(i) = -lb4(i) - lc4(i)
146 t(i) = lb4(i) - lc4(i)
147 ELSE
148 s(i) = zero
149 t(i) = zero
150 ENDIF
151 ENDDO
152C
153 DO i=first,last
154 IF (tflag(i) == 1) THEN
155 pene(i) = p1(i)
156 t(i)= one - two*lb1(i) - two*lc1(i)
157 IF (t(i) < one-em10) THEN
158 s(i)= (lc1(i)-lb1(i))/(lc1(i)+lb1(i))
159 ELSEIF (lb1(i) < -em10) THEN
160 s(i)= two
161 ELSEIF (lc1(i) < -em10) THEN
162 s(i)= -two
163 ELSE
164 s(i)= zero
165 ENDIF
166 ENDIF
167 ENDDO
168C
169 IF(ignore==2 .OR. ignore == 3)THEN
170 DO i=first,last
171 IF(pene(i)>zero .AND.
172 . (s(i) < onep5 .AND.
173 . t(i) < onep5 .AND.
174 . s(i) >-onep5 .AND.
175 . t(i) >-onep5))THEN
176 ii=cand_n(i)
177 IF(gapv(i) - pene(i)<dmin(ii))THEN
178 dmin(ii)=gapv(i)-pene(i)
179 irtl(ii)=cand_e(i)
180 st(1,ii) = s(i)
181 st(2,ii) = t(i)
182 ELSEIF(gapv(i) - pene(i)==dmin(ii))THEN
183 IF(max(abs(s(i)) ,abs(t(i) ))<
184 . max(abs(st(1,ii)),abs(st(2,ii))) )THEN
185 irtl(ii)=cand_e(i)
186 st(1,ii) = s(i)
187 st(2,ii) = t(i)
188 ENDIF
189 ENDIF
190 ENDIF
191 ENDDO
192 ELSEIF(ignore==1)THEN
193 DO i=first,last
194C
195 IF(pene(i)>zero .AND.
196 . (s(i) < onep5 .AND.
197 . t(i) < onep5 .AND.
198 . s(i) >-onep5 .AND.
199 . t(i) >-onep5)) THEN
200 ii=cand_n(i)
201
202 IF(tzinf - pene(i)<dmin(ii))THEN
203 dmin(ii)=tzinf - pene(i)
204 irtl(ii)=cand_e(i)
205 st(1,ii) = s(i)
206 st(2,ii) = t(i)
207 ELSEIF(tzinf - pene(i)==dmin(ii))THEN
208 IF(max(abs(s(i)) ,abs(t(i) ))<
209 . max(abs(st(1,ii)),abs(st(2,ii))) )THEN
210 irtl(ii)=cand_e(i)
211 st(1,ii) = s(i)
212 st(2,ii) = t(i)
213 ENDIF
214 ENDIF
215 ENDIF
216 ENDDO
217 ELSE
218 DO i=first,last
219C
220 IF(pene(i)>zero) THEN
221 ii=cand_n(i)
222 IF(tzinf - pene(i)<dmin(ii))THEN
223 dmin(ii)=tzinf - pene(i)
224 irtl(ii)=cand_e(i)
225 st(1,ii) = s(i)
226 st(2,ii) = t(i)
227 ELSEIF(tzinf - pene(i)==dmin(ii))THEN
228 IF(max(abs(s(i)) ,abs(t(i) ))<
229 . max(abs(st(1,ii)),abs(st(2,ii))) )THEN
230 irtl(ii)=cand_e(i)
231 st(1,ii) = s(i)
232 st(2,ii) = t(i)
233 ENDIF
234 ENDIF
235 ENDIF
236 ENDDO
237 ENDIF
238C
239 RETURN
240 END
241!||====================================================================
242!|| i2bar3 ../starter/source/interfaces/inter3d1/i2dst3.F
243!||--- called by ------------------------------------------------------
244!|| i2dst3 ../starter/source/interfaces/inter3d1/i2dst3.F
245!|| i2dst3_27 ../starter/source/interfaces/inter3d1/i2dst3_27.F
246!||--- calls -----------------------------------------------------
247!|| i7lin3 ../starter/source/interfaces/inter3d1/i7lin3.F
248!||====================================================================
249 SUBROUTINE i2bar3(first,last,
250 . XI,YI,ZI,XA,YA,
251 . ZA,XB,YB,ZB,XC,
252 . YC,ZC,NX,NY,NZ,
253 . LB,LC,P,GAPV,TFLAG)
254C============================================================================
255C-----------------------------------------------
256C I m p l i c i t T y p e s
257C-----------------------------------------------
258#include "implicit_f.inc"
259C-----------------------------------------------
260C D u m m y A r g u m e n t s
261C-----------------------------------------------
262 INTEGER TFLAG(*)
263 integer, intent(in) :: first !< first index of the candidates
264 integer, intent(in) :: last !< last index of the candidates
265C REAL
266 my_real
267 . XI(*),YI(*),ZI(*),XA(*),YA(*),ZA(*),
268 . XB(*),YB(*),ZB(*),XC(*),YC(*),ZC(*),
269 . NX(*),NY(*),NZ(*),LB(*),LC(*),P(*),GAPV(*)
270C-----------------------------------------------
271C C o m m o n B l o c k s
272C-----------------------------------------------
273#include "vect07_c.inc"
274C-----------------------------------------------
275C L o c a l V a r i a b l e s
276C-----------------------------------------------
277 INTEGER I
278C REAL
279 my_real
280 . xpa,ypa,zpa,xpb,ypb,zpb,xpc,ypc,zpc,
281 . xab,yab,zab,xac,yac,zac,alp,
282 . s2,sx,sy,sz,xp,yp,zp
283C--------1---------2---------3---------4---------5---------6---------7--
284 DO i = first,last
285 xab = xb(i) - xa(i)
286 yab = yb(i) - ya(i)
287 zab = zb(i) - za(i)
288C
289 xac = xc(i) - xa(i)
290 yac = yc(i) - ya(i)
291 zac = zc(i) - za(i)
292C
293 nx(i) = yab*zac - zab*yac
294 ny(i) = zab*xac - xab*zac
295 nz(i) = xab*yac - yab*xac
296C
297 s2 = max(em20,sqrt(nx(i)**2 + ny(i)**2 + nz(i)**2))
298 nx(i) = nx(i) / s2
299 ny(i) = ny(i) / s2
300 nz(i) = nz(i) / s2
301C
302 p(i) = nx(i) * (xi(i) - xa(i))
303 . + ny(i) * (yi(i) - ya(i))
304 . + nz(i) * (zi(i) - za(i))
305C
306 xp = xi(i) - nx(i) * p(i)
307 yp = yi(i) - ny(i) * p(i)
308 zp = zi(i) - nz(i) * p(i)
309C
310 xpa = xa(i)-xp
311 ypa = ya(i)-yp
312 zpa = za(i)-zp
313C
314 xpb = xb(i)-xp
315 ypb = yb(i)-yp
316 zpb = zb(i)-zp
317C
318 xpc = xc(i)-xp
319 ypc = yc(i)-yp
320 zpc = zc(i)-zp
321C
322 sx = ypc*zpa - zpc*ypa
323 sy = zpc*xpa - xpc*zpa
324 sz = xpc*ypa - ypc*xpa
325C
326 lb(i) = (nx(i)*sx + ny(i)*sy + nz(i)*sz) / s2
327C
328 sx = ypa*zpb - zpa*ypb
329 sy = zpa*xpb - xpa*zpb
330 sz = xpa*ypb - ypa*xpb
331C
332 lc(i) = (nx(i)*sx + ny(i)*sy + nz(i)*sz) / s2
333 ENDDO
334C
335 DO i=first,last
336 IF(one-lb(i)-lc(i)<zero)THEN
337 CALL i7lin3(xi(i),yi(i),zi(i),xb(i),yb(i),
338 . zb(i),xc(i),yc(i),zc(i),nx(i),
339 . ny(i),nz(i),p(i),alp)
340 ELSEIF(lb(i)<zero)THEN
341 CALL i7lin3(xi(i),yi(i),zi(i),xc(i),yc(i),
342 . zc(i),xa(i),ya(i),za(i),nx(i),
343 . ny(i),nz(i),p(i),alp)
344 IF (tflag(i) == 0) THEN ! only necessary for warped 4 node segments
345 lc(i) = one - alp
346 lb(i) = zero
347 ENDIF
348 ELSEIF(lc(i)<zero)THEN
349 CALL i7lin3(xi(i),yi(i),zi(i),xa(i),ya(i),
350 . za(i),xb(i),yb(i),zb(i),nx(i),
351 . ny(i),nz(i),p(i),alp)
352 IF (tflag(i) == 0) THEN ! only necessary for warped 4 node segments
353 lb(i) = alp
354 lc(i) = zero
355 ENDIF
356 ELSEIF(p(i)<zero)THEN
357
358 nx(i) = -nx(i)
359 ny(i) = -ny(i)
360 nz(i) = -nz(i)
361 p(i) = -p(i)
362 ENDIF
363 ENDDO
364C
365 DO i=first,last
366 p(i) = max(zero, gapv(i) - p(i))
367 ENDDO
368C
369 RETURN
370 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
i7lin3
subroutine i7lin3(xi, yi, zi, xa, ya, za, xb, yb, zb, nx, ny, nz, p, alp)
Definition i7lin3.F:29
max
#define max(a, b)
Definition macros.h:21