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