OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
test_support_newfct.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!|| test_support_newfct ../starter/source/elements/ige3d/test_support_newfct.F
25!||--- called by ------------------------------------------------------
26!|| prerafig3d ../starter/source/elements/ige3d/prerafig3d.F
27!||====================================================================
28 SUBROUTINE test_support_newfct(KNOTLOCPC, DIRDEG, DEGTANG1, DEGTANG2,
29 . DIR,NEWKNOT,
30 . TAB_COINKNOT,L_TAB_COINKNOT,TAB_NEWFCT,
31 . TAB_NEWFCTCUT,L_TAB_NEWFCTCUT,DECALGEO,TAB_REMOVE,FLAG)
32C----------------------------------------------------------------------
33C ROUTINE QUI MET DE COTE TOUTES LES FONCTIONS QUI ONT
34C ETE MODIFIEES OU CREES PAR RAFIG3D.F MAIS QUI PEUVENT ENCORE ETRE
35C MODIFIEE OU SUPPRIMEES PAR LES ANCIENNES MESHSURFS QUE LA MESHSURF
36C ACTUELLE CROISE
37C----------------------------------------------------------------------
38C-----------------------------------------------
39C I m p l i c i t T y p e s
40C-----------------------------------------------
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "ige3d_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER DIRDEG,DEGTANG1,DEGTANG2,DIR,DECALGEO,
50 . L_TAB_COINKNOT,TAB_NEWFCT(*),
51 . TAB_NEWFCTCUT(L_TAB_NEWFCTCUT),L_TAB_NEWFCTCUT,FLAG,TAB_REMOVE(*)
52 my_real knotlocpc(deg_max,3,*),tab_coinknot(2,*),newknot
53C-----------------------------------------------
54C L o c a l V a r i a b l e s
55C-----------------------------------------------
56 INTEGER :: I,J,K,DIRTANG1,DIRTANG2,INTERSEC,IDFCT,IOUT
57 my_real :: DET, T1, T2, XA(5),YA(5),COIN(2,2),XB, YB, XC, YC, XD, YD, TOL
58C-----------------------------------------------
59C Initialize local variables
60C-----------------------------------------------
61 i = 0
62 j = 0
63 k = 0
64 dirtang1 = 0
65 dirtang2 = 0
66 intersec = 0
67 idfct = 0
68 iout = 0
69 det = 0.0
70 t1 = 0.0
71 t2 = 0.0
72 xa = 0.0
73 ya = 0.0
74 coin = 0.0
75 xb = 0.0
76 yb = 0.0
77 xc = 0.0
78 yc = 0.0
79 xd = 0.0
80 yd = 0.0
81 tol = 0.0
82C-----------------------------------------------
83
84
85C
86 l_tab_newfctcut = 0
87 tol = em06
88C
89 IF(dir==1) THEN
90 dirtang1 = 2
91 dirtang2 = 3
92 ELSEIF(dir==2) THEN
93 dirtang1 = 3
94 dirtang2 = 1
95 ELSEIF(dir==3) THEN
96 dirtang1 = 1
97 dirtang2 = 2
98 ENDIF
99C
100 coin(1,1) = minval(tab_coinknot(1,1:(l_tab_coinknot)))
101 coin(2,1) = minval(tab_coinknot(2,1:(l_tab_coinknot)))
102 coin(1,2) = maxval(tab_coinknot(1,1:(l_tab_coinknot)))
103 coin(2,2) = maxval(tab_coinknot(2,1:(l_tab_coinknot)))
104C
105 DO i=1,newfct ! les nouvelles fonctions ajoutees par le dernier rafig3d.F
106
107 idfct = tab_newfct(offset_newfct+i)
108C Fonctions stockees dans le tableau tab_newfct offsete
109c pour ne pas prendre les newfct des anciennes coupes terminees
110
111 DO j=1,l_tab_remove
112 IF(tab_remove(j)==idfct) EXIT
113 ENDDO
114 IF(j<=l_tab_remove) cycle
115
116 IF(knotlocpc(1,dir,decalgeo+idfct)>=newknot) cycle
117 IF(knotlocpc(dirdeg+1,dir,decalgeo+idfct)<=newknot) cycle
118C
119C----------------------------------------------------------------------
120C LE KNOT A INSERER NE DOIT PAS DEJA ETRE PRESENT
121C----------------------------------------------------------------------
122C
123 DO j=2,dirdeg
124 IF(knotlocpc(j,dir,decalgeo+idfct)==newknot) EXIT
125 ENDDO
126 IF(j<=dirdeg) cycle
127c
128 iout=0
129C
130C----------------------------------------------------------------------
131CC DOCUMENTATION TEST D'INCLUSION : VOIR TEST_SUPPORT_FCT.F
132C----------------------------------------------------------------------
133C
134 xa(1) = knotlocpc(1,dirtang1,decalgeo+idfct) + tol
135 xa(2) = knotlocpc(degtang1+1,dirtang1,decalgeo+idfct) - tol
136 xa(3) = knotlocpc(degtang1+1,dirtang1,decalgeo+idfct) - tol
137 xa(4) = knotlocpc(1,dirtang1,decalgeo+idfct) + tol
138 xa(5) = xa(1)
139 ya(1) = knotlocpc(1,dirtang2,decalgeo+idfct) + tol
140 ya(2) = knotlocpc(1,dirtang2,decalgeo+idfct) + tol
141 ya(3) = knotlocpc(degtang2+1,dirtang2,decalgeo+idfct) - tol
142 ya(4) = knotlocpc(degtang2+1,dirtang2,decalgeo+idfct) - tol
143 ya(5) = ya(1)
144C
145 IF(xa(1)<coin(1,1).OR.ya(1)<coin(2,1)) cycle
146 IF(xa(3)>coin(1,2).OR.ya(3)>coin(2,2)) cycle
147C
148 xb=coin(1,1)-1000
149 yb=coin(2,1)-2000
150C
151 DO j=1,4
152 intersec=0
153 DO k=1,l_tab_coinknot-1
154 xc=tab_coinknot(1,k)
155 yc=tab_coinknot(2,k)
156 xd=tab_coinknot(1,k+1)
157 yd=tab_coinknot(2,k+1)
158 det = (xb-xa(j))*(yc-yd) - (xc-xd)*(yb-ya(j))
159 IF(det==0) THEN
160 ELSE
161 t1 = ((xc-xa(j))*(yc-yd)-(xc-xd)*(yc-ya(j)))/det
162 t2 = ((xb-xa(j))*(yc-ya(j))-(xc-xa(j))*(yb-ya(j)))/det
163 IF(t1>1.OR.t1<0.OR.t2>1.OR.t2<=0) THEN
164 ELSE
165 intersec = intersec + 1
166 ENDIF
167 ENDIF
168 ENDDO
169 IF(mod(intersec,2)==0) iout=1
170 ENDDO
171C
172 DO j=1,4
173 DO k=1,l_tab_coinknot-1
174 xc=tab_coinknot(1,k)
175 yc=tab_coinknot(2,k)
176 xd=tab_coinknot(1,k+1)
177 yd=tab_coinknot(2,k+1)
178 det = (xa(j+1)-xa(j))*(yc-yd) - (xc-xd)*(ya(j+1)-ya(j))
179 IF(det==0) THEN
180 ELSE
181 t1 = ((xc-xa(j))*(yc-yd)-(xc-xd)*(yc-ya(j)))/det
182 t2 = ((xa(j+1)-xa(j))*(yc-ya(j))-(xc-xa(j))*(ya(j+1)-ya(j)))/det
183 IF(t1>1.OR.t1<0.OR.t2>1.OR.t2<=0) THEN
184 ELSE
185 iout=1
186 cycle
187 ENDIF
188 ENDIF
189 ENDDO
190 ENDDO
191C
192C----------------------------------------------------------------------
193C DIMENSIONNEMENT ET STOCKAGE DU TABLEAU DES FONCTIONS A RETRAITER
194C PAR LES ANCIENNES COUPES (TAB_MESHSURFCUT)
195C----------------------------------------------------------------------
196C
197 IF(iout==0) THEN
198 IF(flag==0) THEN
199 l_tab_newfctcut = l_tab_newfctcut + 1
200 ELSE
201 l_tab_newfctcut = l_tab_newfctcut + 1
202 tab_newfctcut(l_tab_newfctcut)=idfct
203 ENDIF
204 ENDIF
205 ENDDO
206C
207 RETURN
208 END
209
210
my_real
#define my_real
Definition cppsort.cpp:32
test_support_newfct
subroutine test_support_newfct(knotlocpc, dirdeg, degtang1, degtang2, dir, newknot, tab_coinknot, l_tab_coinknot, tab_newfct, tab_newfctcut, l_tab_newfctcut, decalgeo, tab_remove, flag)
Definition test_support_newfct.F:32