OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
preinicrk4N.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!|| preinicrk4n ../starter/source/elements/xfem/preinicrk4N.F
25!||--- called by ------------------------------------------------------
26!|| lslocal ../starter/source/elements/xfem/lslocal.F
27!||--- calls -----------------------------------------------------
28!|| lsintx ../starter/source/elements/xfem/preinicrk4N.F
29!||--- uses -----------------------------------------------------
30!||====================================================================
31 SUBROUTINE preinicrk4n(ELBUF_STR,XFEM_STR,
32 . X1L ,Y1L ,X2L ,Y2L ,X3L ,
33 . Y3L ,X4L ,Y4L ,LFT ,LLT ,
34 . NFT ,NXLAY ,IELCRKC ,EDGEC ,BETA0 ,
35 . IEDGESH4,ELCUT ,XNOD ,IXC ,NODEDGE ,
36 . TAGSKYC ,KNOD2ELC,TAGEDGE ,CRKLVSET ,CRKSHELL,
37 . CRKEDGE ,XFEM_PHANTOM)
38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE xfem2def_mod
42 USE elbufdef_mod
43C-----------------------------------------------
44C I m p l i c i t T y p e s
45C-----------------------------------------------
46#include "implicit_f.inc"
47C-----------------------------------------------
48C G l o b a l P a r a m e t e r s
49C-----------------------------------------------
50#include "mvsiz_p.inc"
51C-----------------------------------------------
52C C o m m o n B l o c K s
53C-----------------------------------------------
54#include "com_xfem1.inc"
55C-----------------------------------------------
56C D u m m y A r g u m e n t s
57C-----------------------------------------------
58 INTEGER LFT,LLT,NFT,NXLAY
59 INTEGER IELCRKC(*),EDGEC(4,*),IEDGESH4(4,*),ELCUT(*),XNOD(2,2),
60 . IXC(NIXC,*),NODEDGE(2,*),TAGSKYC(4,*),KNOD2ELC(*),TAGEDGE(*)
61 my_real
62 . X1L(*),Y1L(*),X2L(*),Y2L(*),X3L(*),Y3L(*),X4L(*),Y4L(*),
63 . BETA0(2)
64C
65 TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_STR
66 TYPE (ELBUF_STRUCT_), DIMENSION(NXEL) , TARGET :: XFEM_STR
67 TYPE (XFEM_LVSET_) , DIMENSION(NLEVMAX) :: CRKLVSET
68 TYPE (XFEM_SHELL_) , DIMENSION(NLEVMAX) :: CRKSHELL
69 TYPE (XFEM_EDGE_) , DIMENSION(NXLAYMAX) :: CRKEDGE
70 TYPE (XFEM_PHANTOM_), DIMENSION(NXLAYMAX) :: XFEM_PHANTOM
71C-----------------------------------------------
72C L o c a l V a r i a b l e s
73C-----------------------------------------------
74 INTEGER I,K,II,R,ELCRK,IED,p1,p2,dd(4),d1(4),d2(4),IFI(2),
75 . icut,iedge,ic1,ic2,icrk,ilev(nxel),il,ilay,n(4),isign0(4),
76 . nod1,nod2,ixel,ienr0(4),ienr(4),ntag(4)
77 my_real
78 . fit(4,mvsiz),xn(4),yn(4),xmi(2),ymi(2),beta(2,mvsiz),
79 . off_phantom
80 EXTERNAL lsintx
81 my_real lsintx
82 TYPE(g_bufel_) , POINTER :: GBUF
83 TYPE(l_bufel_) , POINTER :: LBUF
84C
85 DATA dd/2,3,4,1/
86 DATA d1/2,3,4,5/
87 DATA d2/3,4,5,2/
88C=======================================================================
89 p2 = 0
90 DO i=lft,llt
91 xn(1)=x1l(i)
92 yn(1)=y1l(i)
93 xn(2)=x2l(i)
94 yn(2)=y2l(i)
95 xn(3)=x3l(i)
96 yn(3)=y3l(i)
97 xn(4)=x4l(i)
98 yn(4)=y4l(i)
99 IF (elcut(i+nft) > 0) THEN
100 DO r=1,4 ! edges
101 p1 = r
102 p2 = dd(r)
103 ied = edgec(r,i+nft)
104 IF (ied > 0) THEN
105 xmi(ied) = half*(xn(p1)+xn(p2))
106 ymi(ied) = half*(yn(p1)+yn(p2))
107 ENDIF
108 ENDDO
109C
110 DO r=1,4 ! nodes
111 fit(r,i) = lsintx(xmi(1),ymi(1),xmi(2),ymi(2),xn(r),yn(r))
112 ENDDO
113 ENDIF
114 ENDDO
115C
116 DO i=lft,llt
117 elcrk = ielcrkc(i+nft)
118 beta(1,i) = zero
119 beta(2,i) = zero
120 IF (elcut(i+nft) > 0) THEN
121C
122 DO r=1,4 ! edges
123 iedge = iedgesh4(r,elcrk)
124 ied = edgec(r,i+nft)
125 IF (ied > 0) THEN
126 nod1 = nodedge(1,iedge)
127 nod2 = nodedge(2,iedge)
128 IF (nod1 == xnod(ied,1) .and. nod2 == xnod(ied,2)) THEN
129 beta(ied,i) = beta0(ied)
130 ELSE IF (nod2 == xnod(ied,1) .and. nod1 == xnod(ied,2)) THEN
131 beta(ied,i) = one - beta0(ied)
132 END IF
133 ENDIF
134 ENDDO
135 ENDIF
136 ENDDO ! I=LFT,LLT
137c------------------------------------------------------------
138c
139 DO ilay=1,nxlay
140 ii = nxel*(ilay-1)
141 DO k=1,nxel
142 ilev(k) = ii + k
143 ENDDO
144 DO i=lft,llt
145 elcrk = ielcrkc(i+nft)
146 IF (elcut(i+nft) > 0) THEN
147 icrk = crkshell(ilev(1))%PHANTOMG(elcrk) ! global xfem element N
148 crklvset(ilev(1))%ELCUT(elcrk) = icrk
149 crklvset(ilev(2))%ELCUT(elcrk) = -icrk
150c
151 xfem_phantom(ilay)%ELCUT(elcrk) = icrk
152 crkedge(ilay)%LAYCUT(elcrk) = 2
153C
154 n(1) = ixc(2,i+nft)
155 n(2) = ixc(3,i+nft)
156 n(3) = ixc(4,i+nft)
157 n(4) = ixc(5,i+nft)
158C
159 isign0(1) = int(sign(one,fit(1,i))) * icrk
160 isign0(2) = int(sign(one,fit(2,i))) * icrk
161 isign0(3) = int(sign(one,fit(3,i))) * icrk
162 isign0(4) = int(sign(one,fit(4,i))) * icrk
163C
164 ntag(1:4) = 0
165C
166 DO r=1,4
167 ienr0(r) = 0
168 ienr(r)=0
169 ied = edgec(r,i+nft)
170 IF(ied > 0)THEN
171 ntag(r) = ntag(r) + 1
172 ntag(dd(r)) = ntag(dd(r)) + 1
173 ENDIF
174 ENDDO
175C
176 DO r=1,4
177 ied = edgec(r,i+nft)
178 iedge = iedgesh4(r,elcrk)
179 IF(ied > 0)THEN
180 nod1 = nodedge(1,iedge)
181 nod2 = nodedge(2,iedge)
182 IF(nod1 == n(r) .and. nod2 == n(dd(r)))THEN
183 p1 = r
184 p2 = dd(r)
185 ELSE IF(nod2 == n(r) .and. nod1 == n(dd(r)))THEN
186 p1 = dd(r)
187 p2 = r
188 END IF
189 IF(ntag(p1) > 0.AND.crkedge(ilay)%EDGEENR(1,iedge) > 0)
190 . ienr0(p1) = crkedge(ilay)%EDGEENR(1,iedge)
191 IF(ntag(p2) > 0.AND.crkedge(ilay)%EDGEENR(2,iedge) > 0)
192 . ienr0(p2) = crkedge(ilay)%EDGEENR(2,iedge)
193 ENDIF
194 ENDDO
195C
196 DO r=1,4
197 IF(ienr0(r) /= 0)THEN
198 ienr(r) = ienr0(r)
199 ELSE
200 ienr(r) = tagskyc(r,i+nft)+knod2elc(n(r))*(ilay-1)
201 ENDIF
202 ENDDO
203C
204 DO r=1,4
205 ied = edgec(r,i+nft)
206 iedge = iedgesh4(r,elcrk)
207 IF (ied > 0) THEN
208 DO il=1,nxel
209 crklvset(ilev(il))%EDGE(r,elcrk) = ied ! (=1,2)
210 crklvset(ilev(il))%ICUTEDGE(iedge) = 1
211 crklvset(ilev(il))%RATIOEDGE(iedge) = beta(ied,i)
212 ENDDO
213C
214 crkedge(ilay)%EDGETIP(1,iedge) = max(ied,
215 . crkedge(ilay)%EDGETIP(1,iedge))
216 crkedge(ilay)%EDGETIP(2,iedge) =
217 . crkedge(ilay)%EDGETIP(2,iedge) + 1
218C
219c add check if BETA (0:1)
220C
221 IF(crkedge(ilay)%EDGEICRK(iedge) == 0)
222 . crkedge(ilay)%EDGEICRK(iedge) = icrk
223C
224 nod1 = nodedge(1,iedge)
225 nod2 = nodedge(2,iedge)
226 ifi(1:2) = 0
227 p1 = 0
228 p2 = 0
229 IF(nod1 == n(r) .and. nod2 == n(dd(r)))THEN
230 ifi(1) = isign0(r)
231 ifi(2) = isign0(dd(r))
232 p1 = r
233 p2 = dd(r)
234 ELSE IF(nod2 == n(r) .and. nod1 == n(dd(r)))THEN
235 ifi(1) = isign0(dd(r))
236 ifi(2) = isign0(r)
237 p1 = dd(r)
238 p2 = r
239 END IF
240 IF(crkedge(ilay)%EDGEIFI(1,iedge) == 0)
241 . crkedge(ilay)%EDGEIFI(1,iedge) = ifi(1)
242 IF(crkedge(ilay)%EDGEIFI(2,iedge) == 0)
243 . crkedge(ilay)%EDGEIFI(2,iedge) = ifi(2)
244 IF(crkedge(ilay)%EDGEENR(1,iedge) == 0)
245 . crkedge(ilay)%EDGEENR(1,iedge) = ienr(p1)
246 IF(crkedge(ilay)%EDGEENR(2,iedge) == 0)
247 . crkedge(ilay)%EDGEENR(2,iedge) = ienr(p2)
248 ENDIF
249 ENDDO ! r=1,4
250 ENDIF
251 ENDDO ! I=LFT,LLT
252 ENDDO ! ILAY=1,NXLAY
253C------------------------------------------------------
254c activation of cracked elements (OFFG = 1)
255C------------------------------------------------------
256 IF (nxlay > 1) THEN ! multilayer
257 DO ixel=1,nxel
258 DO ilay=1,nxlay
259 lbuf => xfem_str(ixel)%BUFLY(ilay)%LBUF(1,1,1)
260 DO i=lft,llt
261 IF(elcut(i+nft) > 0)THEN
262 off_phantom = lbuf%OFF(i)
263 lbuf%OFF(i) = - off_phantom
264 ENDIF
265 ENDDO
266 ENDDO
267 ENDDO
268 ELSE ! monolayer
269 DO ixel=1,nxel
270 gbuf => xfem_str(ixel)%GBUF
271 DO i=lft,llt
272 IF(elcut(i+nft) > 0)THEN
273 off_phantom = gbuf%OFF(i)
274 gbuf%OFF(i) = - off_phantom
275 ENDIF
276 ENDDO
277 ENDDO
278 ENDIF ! IF(NXLAY > 1)THEN
279C------------------------------------------------------
280c remove (replace) already cracked elements (OFFG = 0)
281C------------------------------------------------------
282 DO i=lft,llt
283 IF(elcut(i+nft) > 0)THEN
284 elbuf_str%GBUF%OFF(i) = zero
285 ENDIF
286 ENDDO
287C
288 DO i=lft,llt
289 elcrk = ielcrkc(i+nft)
290 IF(elcut(i+nft) > 0)THEN
291 DO r=1,4
292 ied = edgec(r,i+nft)
293 iedge = iedgesh4(r,elcrk)
294 IF(ied > 0)THEN
295 tagedge(iedge) = tagedge(iedge) + 1
296 ENDIF
297 ENDDO
298 ENDIF
299 ENDDO
300C-----------
301 RETURN
302 END
303c
304!||====================================================================
305!|| lsintx ../starter/source/elements/xfem/preinicrk4N.F
306!||--- called by ------------------------------------------------------
307!|| preinicrk3n ../starter/source/elements/xfem/preinicrk3N.F
308!|| preinicrk4n ../starter/source/elements/xfem/preinicrk4N.F
309!||====================================================================
310 my_real FUNCTION lsintx(Y1, Z1, Y2, Z2, Y, Z)
311C-----------------------------------------------
312C I m p l i c i t T y p e s
313C-----------------------------------------------
314#include "implicit_f.inc"
315C-----------------------------------------------
316C D u m m y A r g u m e n t s
317C-----------------------------------------------
318 my_real
319 . y1,z1,y2,z2,y,z
320C-----------------------------------------------
321C L o c a l V a r i a b l e s
322C-----------------------------------------------
323 my_real aria,ab
324C=======================================================================
325 aria = ((y2*z-y*z2)-(y1*z-y*z1)+(y1*z2-z1*y2))
326 ab = (y2-y1)**2 + (z2-z1)**2
327 IF (ab > zero) THEN
328 lsintx = aria/sqrt(ab)
329 ELSE
330 lsintx = zero
331 ENDIF
332C-----------
333 RETURN
334 END
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
xfem2def_mod
Definition xfem2def_mod.F:40
preinicrk4n
subroutine preinicrk4n(elbuf_str, xfem_str, x1l, y1l, x2l, y2l, x3l, y3l, x4l, y4l, lft, llt, nft, nxlay, ielcrkc, edgec, beta0, iedgesh4, elcut, xnod, ixc, nodedge, tagskyc, knod2elc, tagedge, crklvset, crkshell, crkedge, xfem_phantom)
Definition preinicrk4N.F:38