OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rafig3d.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!|| rafig3d ../starter/source/elements/ige3d/rafig3d.F
25!||--- called by ------------------------------------------------------
26!|| prerafig3d ../starter/source/elements/ige3d/prerafig3d.f
27!||--- uses -----------------------------------------------------
28!|| meshsurfig3d_mod ../starter/source/elements/ige3d/meshsurfig3d_mod.F
29!||====================================================================
30 SUBROUTINE rafig3d(KNOTLOCPC,DEG,DEGTANG1,DEGTANG2,IAD_KNOT,
31 . NKNOT1,NKNOT2,NKNOT3,GAMA,DIR,
32 . NEWKNOT,X,D,V,MS,
33 . WIGE,TAB_FCTCUT,L_TAB_FCTCUT,TAB_REMOVE,TAB_NEWFCT,
34 . DECALGEO,TABCONPATCH,NUMPATCH,KXIG3D,
35 . IXIG3D,TAB_STAY,FLAG_PRE)
36C----------------------------------------------------------------------
37C ROUTINE QUI VA INSERER LE NOUVEAU KNOT DANS LE PATCH EN CREANT DE
38C NOUVELLES FONCTIONS, EN EN SUPPRIMANT CERTAINES, TOUT EN TENANT
39C COMPTE DES FONCTIONS EXISTANTES, SUR LE PATCHS OU SUR LES AUTRES PATCHS
40C ET QUI MODIFIE LES COORDONNES X, V, D DES POINTS SI BESOIN
41C----------------------------------------------------------------------
42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE meshsurfig3d_mod
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "com04_c.inc"
54#include "param_c.inc"
55#include "ige3d_c.inc"
56C-----------------------------------------------
57C D u m m y A r g u m e n t s
58C-----------------------------------------------
59 INTEGER IXIG3D(*),KXIG3D(NIXIG3D,*),IAD_KNOT,NKNOT1,NKNOT2,NKNOT3,
60 . DEG,DEGTANG1,DEGTANG2,IEL,DIR,
61 . TAB_REMOVE(*),TAB_STAY(*),TAB_FCTCUT(*),
62 . L_TAB_FCTCUT,DECALGEO,TAB_NEWFCT(*),
63 . FLAG_PRE,NUMPATCH
64 TYPE(tabconpatch_ig3d_), DIMENSION(*) :: TABCONPATCH
65 my_real KNOTLOCPC(DEG_MAX,3,*),GAMA(*),NEWKNOT
66 my_real X(3,*),V(3,*),D(3,*),MS(*),WIGE(*)
67C-----------------------------------------------
68C L o c a l V a r i a b l e s
69C-----------------------------------------------
70 INTEGER I,J,ITFCT,OFFSET_KNOT,DIRTANG1,DIRTANG2,
71 . idfctcoupee,idfctcoupee1,idfctcoupee2,flag_remove,itnctrl
72 my_real alpha1,alpha2,newknotloc(deg+1,2),tol
73C=======================================================================
74c
75 newknotloc = 0
76 tol = em06
77c
78 IF(dir==1) THEN
79 dirtang1 = 2
80 dirtang2 = 3
81 offset_knot = iad_knot
82 ELSEIF(dir==2) THEN
83 dirtang1 = 3
84 dirtang2 = 1
85 offset_knot = iad_knot+nknot1
86 ELSEIF(dir==3) THEN
87 dirtang1 = 1
88 dirtang2 = 2
89 offset_knot = iad_knot+nknot1+nknot2
90 ENDIF
91c
92 DO itfct=1,l_tab_fctcut
93
94 idfctcoupee = tab_fctcut(itfct)
95c
96 IF(newknot<knotlocpc(1,dir,decalgeo+idfctcoupee).OR.
97 . newknot>knotlocpc(deg+1,dir,decalgeo+idfctcoupee)) cycle
98c
99C CALCUL DES COEFFICIENTS ALPHA1 ET ALPHA2
100c
101 IF(newknot>=knotlocpc(deg,dir,decalgeo+idfctcoupee)) THEN
102 alpha1=1
103 ELSE
104 alpha1=(newknot-knotlocpc(1,dir,decalgeo+idfctcoupee))/
105 / (knotlocpc(deg,dir,decalgeo+idfctcoupee)-knotlocpc(1,dir,decalgeo+idfctcoupee))
106 ENDIF
107 IF(newknot<=knotlocpc(2,dir,decalgeo+idfctcoupee)) THEN
108 alpha2=1
109 ELSE
110 alpha2=(knotlocpc(deg+1,dir,decalgeo+idfctcoupee)-newknot)/
111 / (knotlocpc(deg+1,dir,decalgeo+idfctcoupee)-knotlocpc(2,dir,decalgeo+idfctcoupee))
112 ENDIF
113c
114c ASSEMBLAGE DES NOUVEAUX KNOT
115c
116 i=deg+1
117 DO WHILE (knotlocpc(i-1,dir,decalgeo+idfctcoupee)>=newknot)
118 newknotloc(i,1)=knotlocpc(i-1,dir,decalgeo+idfctcoupee)
119 newknotloc(i,2)=knotlocpc(i,dir,decalgeo+idfctcoupee)
120 i=i-1
121 ENDDO
122 newknotloc(i,1)=newknot
123 newknotloc(i,2)=knotlocpc(i,dir,decalgeo+idfctcoupee)
124 i=i-1
125 newknotloc(i,1)=knotlocpc(i,dir,decalgeo+idfctcoupee)
126 newknotloc(i,2)=newknot
127 i=i-1
128 DO WHILE (i>2)
129 newknotloc(i,1)=knotlocpc(i-1,dir,decalgeo+idfctcoupee)
130 newknotloc(i,2)=knotlocpc(i,dir,decalgeo+idfctcoupee)
131 i=i-1
132 ENDDO
133 DO WHILE (i>=1)
134 newknotloc(i,1)=knotlocpc(i,dir,decalgeo+idfctcoupee)
135 newknotloc(i,2)=knotlocpc(i+1,dir,decalgeo+idfctcoupee)
136 i=i-1
137 ENDDO
138c
139c Recherche si la fonction rajoutee existe deja dans les anciens points
140c
141 DO j=1,l_tab_fctcut
142 idfctcoupee1 = tab_fctcut(j)
143 DO i=1,degtang1+1
144 IF(abs(knotlocpc(i,dirtang1,decalgeo+idfctcoupee)-knotlocpc(i,dirtang1,decalgeo+idfctcoupee1))>tol) EXIT
145 ENDDO
146 IF(i>degtang1+1) THEN
147 DO i=1,degtang2+1
148 IF(abs(knotlocpc(i,dirtang2,decalgeo+idfctcoupee)-knotlocpc(i,dirtang2,decalgeo+idfctcoupee1))>tol) EXIT
149 ENDDO
150 ENDIF
151 IF(i>degtang2+1) THEN
152 DO i=1,deg+1
153 IF(abs(newknotloc(i,1)-knotlocpc(i,dir,decalgeo+idfctcoupee1))>tol) EXIT
154 ENDDO
155 ENDIF
156 IF(i>deg+1) EXIT
157 ENDDO
158 IF(i>deg+1) THEN ! La fonction existe deja
159c
160c modification d'un ancien point existant
161c
162 IF(flag_pre==1) THEN
163 x(:,idfctcoupee1)=(x(:,idfctcoupee1)*gama(idfctcoupee1)+
164 . x(:,idfctcoupee)*gama(idfctcoupee)*alpha1)/
165 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
166 d(:,idfctcoupee1)=(d(:,idfctcoupee1)*gama(idfctcoupee1)+
167 . d(:,idfctcoupee)*gama(idfctcoupee)*alpha1)/
168 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
169 v(:,idfctcoupee1)=(v(:,idfctcoupee1)*gama(idfctcoupee1)+
170 . v(:,idfctcoupee)*gama(idfctcoupee)*alpha1)/
171 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
172 ms(idfctcoupee1)=(ms(idfctcoupee1)*gama(idfctcoupee1)+
173 . ms(idfctcoupee)*gama(idfctcoupee)*alpha1)/
174 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
175 wige(idfctcoupee1)=(wige(idfctcoupee1)*gama(idfctcoupee1)+
176 . wige(idfctcoupee)*gama(idfctcoupee)*alpha1)/
177 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
178 ENDIF
179 gama(idfctcoupee1) = gama(idfctcoupee1)+alpha1*gama(idfctcoupee)
180 knotlocpc(:,dir,decalgeo+idfctcoupee1) = newknotloc(:,1)
181 ELSEIF(i<=deg+1) THEN ! Il faut chercher dans les nouveaux points
182 DO j=1,newfct ! les nouvelles fonctions de cette meshsurf
183 idfctcoupee1 = numnodige0+offset_newfct+j
184 DO i=1,degtang1+1
185 IF(abs(knotlocpc(i,dirtang1,decalgeo+idfctcoupee)-knotlocpc(i,dirtang1,decalgeo+idfctcoupee1))>tol) EXIT
186 ENDDO
187 IF(i>degtang1+1) THEN
188 DO i=1,degtang2+1
189 IF(abs(knotlocpc(i,dirtang2,decalgeo+idfctcoupee)-knotlocpc(i,dirtang2,decalgeo+idfctcoupee1))>tol) EXIT
190 ENDDO
191 ENDIF
192 IF(i>degtang2+1) THEN
193 DO i=1,deg+1
194 IF(abs(newknotloc(i,1)-knotlocpc(i,dir,decalgeo+idfctcoupee1))>tol) EXIT
195 ENDDO
196 ENDIF
197 IF(i>deg+1) EXIT
198 ENDDO
199 ENDIF
200 IF(i>deg+1) THEN ! La fonction existe deja
201c
202c modification d'un point existant
203c
204 IF(flag_pre==1) THEN
205 x(:,numnodige0+offset_newfct+j)=(x(:,numnodige0+offset_newfct+j)*gama(idfctcoupee1)+
206 . x(:,idfctcoupee)*gama(idfctcoupee)*alpha1)/
207 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
208 d(:,numnodige0+offset_newfct+j)=(d(:,numnodige0+offset_newfct+j)*gama(idfctcoupee1)+
209 . d(:,idfctcoupee)*gama(idfctcoupee)*alpha1)/
210 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
211 v(:,numnodige0+offset_newfct+j)=(v(:,numnodige0+offset_newfct+j)*gama(idfctcoupee1)+
212 . v(:,idfctcoupee)*gama(idfctcoupee)*alpha1)/
213 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
214 ms(numnodige0+offset_newfct+j)=(ms(numnodige0+offset_newfct+j)*gama(idfctcoupee1)+
215 . ms(idfctcoupee)*gama(idfctcoupee)*alpha1)/
216 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
217 wige(numnodige0+offset_newfct+j)=(wige(numnodige0+offset_newfct+j)*gama(idfctcoupee1)+
218 . wige(idfctcoupee)*gama(idfctcoupee)*alpha1)/
219 . (gama(idfctcoupee1)+alpha1*gama(idfctcoupee))
220 ENDIF
221 gama(idfctcoupee1) = gama(idfctcoupee1)+alpha1*gama(idfctcoupee)
222 knotlocpc(:,dir,decalgeo+idfctcoupee1) = newknotloc(:,1)
223 ELSE
224 newfct = newfct+1
225 l_tab_newfct = l_tab_newfct+1
226 IF(flag_pre==1) THEN
227 x(:,numnodige0+offset_newfct+newfct) = x(:,idfctcoupee)
228 d(:,numnodige0+offset_newfct+newfct) = d(:,idfctcoupee)
229 v(:,numnodige0+offset_newfct+newfct) = v(:,idfctcoupee)
230 ms(numnodige0+offset_newfct+newfct) = ms(idfctcoupee)
231 wige(numnodige0+offset_newfct+newfct) = wige(idfctcoupee)
232 ENDIF
233 gama(numnodige0+offset_newfct+newfct) = alpha1*gama(idfctcoupee)
234 knotlocpc(:,dir,decalgeo+numnodige0+offset_newfct+newfct) = newknotloc(:,1)
235 knotlocpc(:,dirtang1,decalgeo+numnodige0+offset_newfct+newfct) = knotlocpc(:,dirtang1,decalgeo+idfctcoupee)
236 knotlocpc(:,dirtang2,decalgeo+numnodige0+offset_newfct+newfct) = knotlocpc(:,dirtang2,decalgeo+idfctcoupee)
237 tab_newfct(l_tab_newfct) = numnodige0+offset_newfct+newfct
238 ENDIF
239c
240 DO j=1,l_tab_fctcut
241 idfctcoupee2 = tab_fctcut(j)
242 DO i=1,degtang1+1
243 IF(abs(knotlocpc(i,dirtang1,decalgeo+idfctcoupee)-knotlocpc(i,dirtang1,decalgeo+idfctcoupee2))>tol) EXIT
244 ENDDO
245 IF(i>degtang1+1) THEN
246 DO i=1,degtang2+1
247 IF(abs(knotlocpc(i,dirtang2,decalgeo+idfctcoupee)-knotlocpc(i,dirtang2,decalgeo+idfctcoupee2))>tol) EXIT
248 ENDDO
249 ENDIF
250 IF(i>degtang2+1) THEN
251 DO i=1,deg+1
252 IF(abs(newknotloc(i,2)-knotlocpc(i,dir,decalgeo+idfctcoupee2))>tol) EXIT
253 ENDDO
254 ENDIF
255 IF(i>deg+1) EXIT
256 ENDDO
257 IF(i>deg+1) THEN ! La fonction existe deja
258c
259c modification d'un point existant
260c
261 IF(flag_pre==1) THEN
262 x(:,idfctcoupee2)=(x(:,idfctcoupee2)*gama(idfctcoupee2)+
263 . x(:,idfctcoupee)*gama(idfctcoupee)*alpha2)/
264 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
265 d(:,idfctcoupee2)=(d(:,idfctcoupee2)*gama(idfctcoupee2)+
266 . d(:,idfctcoupee)*gama(idfctcoupee)*alpha2)/
267 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
268 v(:,idfctcoupee2)=(v(:,idfctcoupee2)*gama(idfctcoupee2)+
269 . v(:,idfctcoupee)*gama(idfctcoupee)*alpha2)/
270 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
271 ms(idfctcoupee2)=(ms(idfctcoupee2)*gama(idfctcoupee2)+
272 . ms(idfctcoupee)*gama(idfctcoupee)*alpha2)/
273 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
274 wige(idfctcoupee2)=(wige(idfctcoupee2)*gama(idfctcoupee2)+
275 . wige(idfctcoupee)*gama(idfctcoupee)*alpha2)/
276 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
277 ENDIF
278 gama(idfctcoupee2) = gama(idfctcoupee2)+alpha2*gama(idfctcoupee)
279 knotlocpc(:,dir,decalgeo+idfctcoupee2) = newknotloc(:,2)
280 ELSEIF(i<=deg+1) THEN ! Il faut chercher dans les nouveaux points
281 DO j=1,newfct ! les nouvelles fonctions de cette meshsurf
282 idfctcoupee2 = numnodige0+offset_newfct+j
283 DO i=1,degtang1+1
284 IF(abs(knotlocpc(i,dirtang1,decalgeo+idfctcoupee)-knotlocpc(i,dirtang1,decalgeo+idfctcoupee2))>tol) EXIT
285 ENDDO
286 IF(i>degtang1+1) THEN
287 DO i=1,degtang2+1
288 IF(abs(knotlocpc(i,dirtang2,decalgeo+idfctcoupee)-knotlocpc(i,dirtang2,decalgeo+idfctcoupee2))>tol) EXIT
289 ENDDO
290 ENDIF
291 IF(i>degtang2+1) THEN
292 DO i=1,deg+1
293 IF(abs(newknotloc(i,2)-knotlocpc(i,dir,decalgeo+idfctcoupee2))>tol) EXIT
294 ENDDO
295 ENDIF
296 IF(i>deg+1) EXIT
297 ENDDO
298 ENDIF
299 IF(i>deg+1) THEN ! La fonction existe deja
300c
301c modification d'un point existant
302c
303 IF(flag_pre==1) THEN
304 x(:,numnodige0+offset_newfct+j)=(x(:,numnodige0+offset_newfct+j)*gama(idfctcoupee2)+
305 . x(:,idfctcoupee)*gama(idfctcoupee)*alpha2)/
306 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
307 d(:,numnodige0+offset_newfct+j)=(d(:,numnodige0+offset_newfct+j)*gama(idfctcoupee2)+
308 . d(:,idfctcoupee)*gama(idfctcoupee)*alpha2)/
309 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
310 v(:,numnodige0+offset_newfct+j)=(v(:,numnodige0+offset_newfct+j)*gama(idfctcoupee2)+
311 . v(:,idfctcoupee)*gama(idfctcoupee)*alpha2)/
312 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
313 ms(numnodige0+offset_newfct+j)=(ms(numnodige0+offset_newfct+j)*gama(idfctcoupee2)+
314 . ms(idfctcoupee)*gama(idfctcoupee)*alpha2)/
315 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
316 wige(numnodige0+offset_newfct+j)=(wige(numnodige0+offset_newfct+j)*gama(idfctcoupee2)+
317 . wige(idfctcoupee)*gama(idfctcoupee)*alpha2)/
318 . (gama(idfctcoupee2)+alpha2*gama(idfctcoupee))
319 ENDIF
320 gama(idfctcoupee2) = gama(idfctcoupee2)+alpha2*gama(idfctcoupee)
321 knotlocpc(:,dir,decalgeo+idfctcoupee2) = newknotloc(:,2)
322 ELSE
323 newfct = newfct+1
324 l_tab_newfct = l_tab_newfct+1
325 IF(flag_pre==1) THEN
326 x(:,numnodige0+offset_newfct+newfct) = x(:,idfctcoupee)
327 d(:,numnodige0+offset_newfct+newfct) = d(:,idfctcoupee)
328 v(:,numnodige0+offset_newfct+newfct) = v(:,idfctcoupee)
329 ms(numnodige0+offset_newfct+newfct) = ms(idfctcoupee)
330 wige(numnodige0+offset_newfct+newfct) = wige(idfctcoupee)
331 ENDIF
332 gama(numnodige0+offset_newfct+newfct) = alpha2*gama(idfctcoupee)
333 knotlocpc(:,dir,decalgeo+numnodige0+offset_newfct+newfct) = newknotloc(:,2)
334 knotlocpc(:,dirtang1,decalgeo+numnodige0+offset_newfct+newfct) = knotlocpc(:,dirtang1,decalgeo+idfctcoupee)
335 knotlocpc(:,dirtang2,decalgeo+numnodige0+offset_newfct+newfct) = knotlocpc(:,dirtang2,decalgeo+idfctcoupee)
336 tab_newfct(l_tab_newfct) = numnodige0+offset_newfct+newfct
337 ENDIF
338c
339ccc si la fonction est sur un autre patch aussi, elle ne doit pas etre supprimee.
340ccc Elle sera supprimee de la connectivite du patch raffine mais restera
341ccc avec son numero de fct pour le patch voisin
342c
343 flag_remove=1
344 DO i=1,nbpart_ig3d
345 IF(i==numpatch) cycle ! pas sur le patch sur lequel on travaille
346 DO j=1,tabconpatch(i)%L_TAB_IG3D
347 DO itnctrl=1,kxig3d(3,tabconpatch(i)%TAB_IG3D(j))
348 IF(ixig3d(kxig3d(4,tabconpatch(i)%TAB_IG3D(j))+itnctrl-1)==idfctcoupee) THEN
349c print*,'finallement on garde', IDFCTCOUPEE
350 flag_remove=0
351 ENDIF
352 ENDDO
353 ENDDO
354 ENDDO
355
356 IF(flag_remove==1) THEN
357 l_tab_remove = l_tab_remove+1
358 tab_remove(l_tab_remove) = idfctcoupee
359 ELSE
360 l_tab_stay = l_tab_stay+1
361 tab_stay(l_tab_stay) = idfctcoupee
362 ENDIF
363c
364 ENDDO
365c
366 RETURN
367 END
368c
369
alpha2
#define alpha2
Definition eval.h:48
meshsurfig3d_mod
Definition meshsurfig3d_mod.F:33
prerafig3d
subroutine prerafig3d(knot, knotlocpc, knotlocel, kxig3d, ixig3d, igeo, ipartig3d, x, v, d, ms, wige, tabconpatch, flag_pre)
Definition prerafig3d.F:43
rafig3d
subroutine rafig3d(knotlocpc, deg, degtang1, degtang2, iad_knot, nknot1, nknot2, nknot3, gama, dir, newknot, x, d, v, ms, wige, tab_fctcut, l_tab_fctcut, tab_remove, tab_newfct, decalgeo, tabconpatch, numpatch, kxig3d, ixig3d, tab_stay, flag_pre)
Definition rafig3d.F:36
starter
program starter
Definition starter.F:39
meshsurfig3d_mod::tabconpatch_ig3d_
Definition meshsurfig3d_mod.F:83