OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
iedge_xfem.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!|| iedge_xfem ../starter/source/elements/xfem/iedge_xfem.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!||--- uses -----------------------------------------------------
30!|| message_mod ../starter/share/message_module/message_mod.F
31!||====================================================================
32 SUBROUTINE iedge_xfem(
33 . IBORDNODE ,IXC ,IXTG ,IEDGESH4,IEDGESH3,
34 . IBORDEDGE ,NODEDGE ,IELCRKC ,IELCRKTG,IEDGE ,
35 . CEP_CRK ,IEDGE_TMP0)
36C=======================================================================
37 USE message_mod
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 "com01_c.inc"
46#include "com04_c.inc"
47#include "com_xfem1.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 INTEGER IBORDNODE(*),IXC(NIXC,*),IXTG(NIXTG,*),IEDGESH4(4,*),
52 . IEDGESH3(3,*),IBORDEDGE(*),NODEDGE(2,*),IELCRKC(*),IELCRKTG(*),
53 . IEDGE(*),CEP_CRK(*),IEDGE_TMP0(*)
54C-----------------------------------------------
55C L o c a l V a r i a b l e s
56C-----------------------------------------------
57 INTEGER I,J,K,L,JJ,LL,I1,I2,I1M,I2M,NL,IED,NLMAX,STAT,
58 . NELALL,NEL,NIX,JCRK0,JCRK,P,PROC
59 INTEGER NEXTK4(4),NEXTK3(3),IWORK(70000)
60 INTEGER, DIMENSION(:,:), ALLOCATABLE ::
61 . LINEIX,LINEIX2,IXWORK,IEDWORK4,IEDWORK3
62 INTEGER, DIMENSION(:), ALLOCATABLE ::
63 . index,taged,itaged,nixel,tagel,tagel_crk,iedge_tmp
64C
65 DATA nextk4/2,3,4,1/
66 DATA nextk3/2,3,1/
67C=======================================================================
68 nlmax = 4*ecrkxfec + 3*ecrkxfetg ! max edges
69 nelall = ecrkxfec+ecrkxfetg ! max elements
70C
71 ALLOCATE (lineix(2,nlmax) ,stat=stat)
72 ALLOCATE (lineix2(2,nlmax) ,stat=stat)
73 ALLOCATE (index(2*nlmax) ,stat=stat)
74 ALLOCATE (ixwork(5,nlmax) ,stat=stat)
75 ALLOCATE (iedwork4(4,ecrkxfec) ,stat=stat)
76 ALLOCATE (iedwork3(3,ecrkxfetg),stat=stat)
77 ALLOCATE (taged(nlmax) ,stat=stat)
78 ALLOCATE (itaged(nlmax) ,stat=stat)
79 ALLOCATE (nixel(nelall) ,stat=stat)
80 ALLOCATE (tagel(nelall) ,stat=stat)
81 ALLOCATE (tagel_crk(nelall) ,stat=stat)
82 lineix = 0
83 lineix2 = 0
84 index = 0
85 ixwork = 0
86 iedwork4= 0
87 iedwork3= 0
88 taged = 0
89 itaged = 0
90 nixel = 0
91 tagel = 0
92 tagel_crk = 0
93C
94 IF (stat /= 0) THEN
95 CALL ancmsg(msgid=268 ,msgtype=msgerror,anmode=anstop,c1='EDGE XFEM')
96 END IF
97c---------------------------------------
98c recherche de toutes les lignes dans la surface (shells)
99c---------------------------------------
100 ll = 0 ! nb edges
101 nel = 0 ! nb elements
102 DO j=1,numelc
103 IF (ielcrkc(j) > 0) THEN
104 nel = nel + 1
105 nixel(nel) = 4
106 tagel(nel) = j
107 tagel_crk(nel) = ielcrkc(j)
108 ENDIF
109 END DO
110C
111 DO j=1,numeltg
112 IF (ielcrktg(j) > 0) THEN
113 nel = nel + 1
114 nixel(nel) = 3
115 tagel(nel) = j
116 tagel_crk(nel) = ielcrktg(j)-ecrkxfec
117 ENDIF
118 END DO
119C
120 DO i=1,nel
121 j = tagel(i)
122 nix = nixel(i)
123 IF (nix == 4) THEN
124c I1=IXC(2,J)
125c I2=IXC(3,J)
126c I3=IXC(4,J)
127c I4=IXC(5,J)
128 DO k=1,nix
129 i1 = ixc(k+1,j)
130 i2 = ixc(nextk4(k)+1,j)
131 ll = ll+1
132 IF(i2 > i1)THEN
133 lineix(1,ll) = i1
134 lineix(2,ll) = i2
135C LINEIX2(1,LL) = J
136 lineix2(1,ll) = i
137 lineix2(2,ll) = k
138 ELSE
139 lineix(1,ll) = i2
140 lineix(2,ll) = i1
141C LINEIX2(1,LL) = J
142 lineix2(1,ll) = i
143 lineix2(2,ll) = -k
144 ENDIF
145 ENDDO
146 ELSE IF (nix == 3) THEN
147c I1=IXTG(2,J)
148c I2=IXTG(3,J)
149c I3=IXTG(4,J)
150 DO k=1,nix
151 i1 = ixtg(k+1,j)
152 i2 = ixtg(nextk3(k)+1,j)
153 ll = ll+1
154 IF(i2 > i1)THEN
155 lineix(1,ll) = i1
156 lineix(2,ll) = i2
157C LINEIX2(1,LL) = J
158 lineix2(1,ll) = i
159 lineix2(2,ll) = k
160 ELSE
161 lineix(1,ll) = i2
162 lineix(2,ll) = i1
163C LINEIX2(1,LL) = J
164 lineix2(1,ll) = i
165 lineix2(2,ll) = -k
166 ENDIF
167 ENDDO
168 END IF
169 END DO
170C---
171 CALL my_orders(0,iwork,lineix,index,ll,2)
172c---------------------------------------
173c remove double edges (internal edges in fact)
174c---------------------------------------
175 nl = 1
176 i1m = lineix(1,index(1))
177 i2m = lineix(2,index(1))
178 ixwork(1,nl)=i1m
179 ixwork(2,nl)=i2m
180 ixwork(3,nl)=lineix2(1,index(1))
181 ixwork(4,nl)=lineix2(2,index(1))
182 ixwork(5,nl)=1
183C
184 j = ixwork(3,nl)
185 k = abs(ixwork(4,nl))
186 nix = nixel(j)
187 i = tagel(j)
188 jj = tagel_crk(j)
189 IF (nix == 4) THEN
190 iedwork4(k,jj) = nl
191 ELSE IF (nix == 3) THEN
192 iedwork3(k,jj) = nl
193 END IF
194C----
195 DO l=2,ll
196 i1 = lineix(1,index(l))
197 i2 = lineix(2,index(l))
198 IF(i2 /= i2m .or. i1 /= i1m)THEN
199 nl = nl + 1
200 ixwork(1,nl)=i1
201 ixwork(2,nl)=i2
202 ixwork(3,nl)=lineix2(1,index(l))
203 ixwork(4,nl)=lineix2(2,index(l))
204 ixwork(5,nl)=1 ! bord
205C
206 j = ixwork(3,nl)
207 k = abs(ixwork(4,nl))
208 nix = nixel(j)
209 i = tagel(j)
210 jj = tagel_crk(j)
211 IF(nix == 4)THEN
212 iedwork4(k,jj) = nl
213 ELSE IF(nix == 3)THEN
214 iedwork3(k,jj) = nl
215 END IF
216 ELSE
217 ixwork(5,nl)=0 ! edge double
218C
219 j = lineix2(1,index(l))
220 k = abs(lineix2(2,index(l)))
221 nix = nixel(j)
222 i = tagel(j)
223 jj = tagel_crk(j)
224 IF(nix == 4)THEN
225 iedwork4(k,jj) = nl
226 ELSE IF(nix == 3)THEN
227 iedwork3(k,jj) = nl
228 END IF
229 ENDIF
230 i1m = i1
231 i2m = i2
232 ENDDO
233C
234 numedges = nl
235c---------------------------------------
236c build global shell element edges table (all edges)
237c---------------------------------------
238 nl = 0
239 DO j=1,nel
240 nix = nixel(j)
241 i = tagel(j)
242 jj = tagel_crk(j)
243 IF (nix == 4) THEN
244 DO k=1,nix
245 ied = iedwork4(k,jj)
246 IF (taged(ied) == 0) THEN
247 nl = nl + 1
248 itaged(ied) = nl
249 taged( ied) = 1
250 iedge(nl) = nl
251 ibordedge(nl) = ixwork(5,ied)
252 IF(ixwork(5,ied) == 1)THEN
253 ibordnode(ixwork(1,ied)) = 1
254 ibordnode(ixwork(2,ied)) = 1
255 END IF
256c edge nodes
257 nodedge(1,nl) = ixwork(1,ied)
258 nodedge(2,nl) = ixwork(2,ied)
259 END IF
260 iedgesh4(k,jj) = itaged(ied)
261 END DO
262 ELSE IF (nix == 3) THEN
263 DO k=1,nix
264 ied = iedwork3(k,jj)
265 IF (taged(ied) == 0) THEN
266 nl = nl + 1
267 itaged(ied) = nl
268 taged(ied) = 1
269 ibordedge(nl) = ixwork(5,ied)
270 iedge(nl) = nl
271 IF(ixwork(5,ied) == 1)THEN
272 ibordnode(ixwork(1,ied)) = 1
273 ibordnode(ixwork(2,ied)) = 1
274 END IF
275c edge nodes
276 nodedge(1,nl) = ixwork(1,ied)
277 nodedge(2,nl) = ixwork(2,ied)
278 END IF
279 iedgesh3(k,jj) = itaged(ied)
280 END DO
281 END IF
282 END DO
283c---------------------------------------
284c keep boundary nodes (remove internal edges)
285c---------------------------------------
286c LL = NL
287c NL = 0
288c DO L=1,LL
289c IF(IXWORK(5,L) == 1)THEN
290c NL = NL + 1
291c I1=IXWORK(1,NL)
292c I2=IXWORK(2,NL)
293c I3=IXWORK(3,NL)
294c I4=IXWORK(4,NL)
295c I5=IXWORK(5,NL)
296c IXWORK(1,NL)=IXWORK(1,L)
297c IXWORK(2,NL)=IXWORK(2,L)
298c IXWORK(3,NL)=IXWORK(3,L)
299c IXWORK(4,NL)=IXWORK(4,L)
300c IXWORK(5,NL)=1 ! bord on
301c IXWORK(1,L)=I1
302c IXWORK(2,L)=I2
303c IXWORK(3,L)=I3
304c IXWORK(4,L)=I4
305c IXWORK(5,L)=I5
306C
307c I1=IXWORK(1,L)
308c I2=IXWORK(2,L)
309c I3=IXWORK(3,L)
310c I4=IXWORK(4,L)
311c I5=IXWORK(5,L)
312c IXWORK(1,NL)=I1
313c IXWORK(2,NL)=I2
314c IXWORK(3,NL)=I3
315c IXWORK(4,NL)=I4
316c IXWORK(5,NL)=I5 ! bord on
317c ENDIF
318c ENDDO
319c---------------------------------------
320c fill border nodal table
321c---------------------------------------
322c DO LL=1,NL
323c IBORDNODE(IXWORK(1,LL)) = 1
324c IBORDNODE(IXWORK(2,LL)) = 1
325c ENDDO
326C
327 ALLOCATE (iedge_tmp(numedges))
328 iedge_tmp = 0
329C
330 DO p = 1,nspmd
331 itaged = 0
332 DO i=1,nel
333c J = TAGEL(I)
334 nix = nixel(i)
335 jcrk0 = tagel_crk(i)
336 jcrk = jcrk0
337 IF(nix == 3) jcrk = jcrk + ecrkxfec
338 proc = cep_crk(jcrk) + 1
339 IF(p == proc)THEN
340 IF(nix==4)THEN
341 DO k=1,nix
342 ied = iedgesh4(k,jcrk0)
343cc IF(IED /= 0)THEN
344cc IF(ITAGED(IED) == 0)THEN
345cc ITAGED(IED) = 1
346cc IEDGE_TMP0(IED) = IEDGE_TMP0(IED) + 1
347cc ENDIF
348cc ENDIF
349 IF(ied /= 0 .AND. ibordedge(ied) == 0)THEN
350 IF(iedge_tmp(ied) >= 0)THEN
351 iedge_tmp(ied) = iedge_tmp(ied) + 1
352 ENDIF
353 ENDIF
354 ENDDO
355 ELSEIF(nix==3)THEN
356 DO k=1,nix
357 ied = iedgesh3(k,jcrk0)
358cc IF(IED /= 0)THEN
359cc IF(ITAGED(IED) == 0)THEN
360cc ITAGED(IED) = 1
361cc IEDGE_TMP0(IED) = IEDGE_TMP0(IED) + 1
362cc ENDIF
363cc ENDIF
364 IF(ied /= 0 .AND. ibordedge(ied) == 0)THEN
365 IF(iedge_tmp(ied) >= 0)THEN
366 iedge_tmp(ied) = iedge_tmp(ied) + 1
367 ENDIF
368 ENDIF
369 ENDDO
370 ENDIF
371 END IF ! IF(P == PROC)THEN
372 END DO
373C---
374 DO ied=1,numedges
375 IF(iedge_tmp(ied) == 1) iedge_tmp(ied) = -1
376 ENDDO
377C---
378 END DO
379C---
380 DO ied=1,numedges
381 IF(iedge_tmp(ied) == -1) iedge_tmp0(ied) = iedge_tmp(ied)
382 ENDDO
383C---
384C-----------
385 DEALLOCATE (index)
386 DEALLOCATE (ixwork)
387 DEALLOCATE (lineix)
388 DEALLOCATE (lineix2)
389 DEALLOCATE (iedwork4)
390 DEALLOCATE (iedwork3)
391 DEALLOCATE (taged)
392 DEALLOCATE (itaged)
393 DEALLOCATE (nixel)
394 DEALLOCATE (tagel)
395 DEALLOCATE (tagel_crk)
396 DEALLOCATE (iedge_tmp)
397C-----------
398 RETURN
399 END
400!||====================================================================
401!|| distfuncc1 ../starter/source/elements/xfem/iedge_xfem.F
402!||====================================================================
403 SUBROUTINE distfuncc1(PLXN,PLYN,PLZN,FI,
404 . X,Y,Z,XINT1X,XINT1Y,XINT1Z)
405C-----------------------------------------------
406C I m p l i c i t T y p e s
407C-----------------------------------------------
408#include "implicit_f.inc"
409C-----------------------------------------------
410C D u m m y A r g u m e n t s
411C-----------------------------------------------
412 my_real
413 . x,y,z,xint1x,xint1y,xint1z,
414 . plxn,plyn,plzn,fi
415C-----------------------------------------------
416C L o c a l V a r i a b l e s
417C-----------------------------------------------
418 my_real
419 . len
420C-----------------------------------------------
421 fi=plxn*(x-xint1x)+
422 . plyn*(y-xint1y)+
423 . plzn*(z-xint1z)
424 len=sqrt(plxn**2+plyn**2+plzn**2)
425 IF(len/=zero)fi=fi/len
426C
427 RETURN
428 END
429C
430!||====================================================================
431!|| distfuncc2 ../starter/source/elements/xfem/iedge_xfem.F
432!||====================================================================
433 SUBROUTINE distfuncc2(XN,YN,ZN,
434 . XT1,YT1,ZT1,XT2,YT2,ZT2,DIS)
435C-----------------------------------------------
436C I m p l i c i t T y p e s
437C-----------------------------------------------
438#include "implicit_f.inc"
439C-----------------------------------------------
440C D u m m y A r g u m e n t s
441C-----------------------------------------------
442 my_real
443 . dis,xn,yn,zn,xt1,yt1,zt1,xt2,yt2,zt2
444C-----------------------------------------------
445C L o c a l V a r i a b l e s
446C-----------------------------------------------
447 my_real
448 . area,xn1,yn1,zn1,x12,y12,z12,xx,yy,zz
449C-----------------------------------------------
450 xn1=xn-xt1
451 yn1=yn-yt1
452 zn1=zn-zt1
453C
454 x12=xt2-xt1
455 y12=yt2-yt1
456 z12=zt2-zt1
457C
458 xx=yn1*z12-zn1*y12
459 yy=zn1*x12-xn1*z12
460 zz=xn1*y12-yn1*x12
461C
462 area=-half*sqrt(xx**2+yy**2+zz**2)
463 dis=sqrt(x12**2+y12**2+z12**2)
464 IF(dis/=zero)dis=area/dis
465C
466 RETURN
467 END
my_real
#define my_real
Definition cppsort.cpp:32
area
subroutine area(d1, x, x2, y, y2, eint, stif0)
Definition hm_read_prop32.F:567
iedge_xfem
subroutine iedge_xfem(ibordnode, ixc, ixtg, iedgesh4, iedgesh3, ibordedge, nodedge, ielcrkc, ielcrktg, iedge, cep_crk, iedge_tmp0)
Definition iedge_xfem.F:36
distfuncc1
subroutine distfuncc1(plxn, plyn, plzn, fi, x, y, z, xint1x, xint1y, xint1z)
Definition iedge_xfem.F:405
distfuncc2
subroutine distfuncc2(xn, yn, zn, xt1, yt1, zt1, xt2, yt2, zt2, dis)
Definition iedge_xfem.F:435
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
message_mod
Definition message_mod.F:1249
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889