OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
upenric2_n3.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!|| upenric2_n3 ../engine/source/elements/xfem/upenric2_n3.F
25!||--- called by ------------------------------------------------------
26!|| upxfem1 ../engine/source/elements/xfem/upxfem1.F
27!||--- uses -----------------------------------------------------
28!|| crackxfem_mod ../engine/share/modules/crackxfem_mod.F
29!||====================================================================
30 SUBROUTINE upenric2_n3(IPARG ,IXTG ,NFT ,JFT ,JLT ,
31 . ELCUTC ,IAD_CRKTG,IEL_CRKTG,INOD_CRK,ENRTAG,
32 . NXLAY ,CRKEDGE ,XEDGE3N )
33C-----------------------------------------------
34 USE crackxfem_mod
35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39C-----------------------------------------------
40C G l o b a l P a r a m e t e r s
41C-----------------------------------------------
42#include "mvsiz_p.inc"
43C-----------------------------------------------
44C C o m m o n B l o c k s
45C-----------------------------------------------
46#include "com04_c.inc"
47#include "com_xfem1.inc"
48#include "param_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER NFT,JFT,JLT,NXLAY
53 INTEGER IPARG(NPARG,*),IXTG(NIXTG,*),ELCUTC(2,*),INOD_CRK(*),
54 . iad_crktg(3,*),xedge3n(3,*),iel_crktg(*),enrtag(numnod,*)
55 TYPE (XFEM_EDGE_) , DIMENSION(*) :: CRKEDGE
56C-----------------------------------------------
57C L o c a l V a r i a b l e s
58C-----------------------------------------------
59 INTEGER I,K,IR,ELCRK,ELCRKTG,ILEV,ILAY,IXEL,ELCUT,IECUT,NELCRK,NSX,
60 . IED,EDGE,FAC,IBOUNDEDGE,LAYCUT,ENR,ITRI,ITIP,IAD,COUNT
61 INTEGER JCT(MVSIZ),IADC(3),ENR0(3),IENR(3),NTAG(3),d(3),NS(3)
62 DATA D/2,3,1/
63C=======================================================================
64 nelcrk = 0
65 DO i=jft,jlt
66 jct(i) = 0
67 IF (elcutc(1,i+nft) /= 0) THEN
68 nelcrk = nelcrk + 1
69 jct(nelcrk) = i
70 ENDIF
71 ENDDO
72 IF (nelcrk == 0) RETURN
73C
74 DO ilay=1,nxlay
75 DO ixel=1,nxel
76 ilev = nxel*(ilay-1) + ixel
77 DO ir=1,nelcrk
78 i = jct(ir)
79 elcrktg = iel_crktg(i+nft)
80 elcrk = elcrktg + ecrkxfec
81 elcut = xfem_phantom(ilay)%ELCUT(elcrk)
82 IF (elcut /= 0) THEN
83 ns(1) = ixtg(2,i+nft)
84 ns(2) = ixtg(3,i+nft)
85 ns(3) = ixtg(4,i+nft)
86 iadc(1) = iad_crktg(1,elcrktg)
87 iadc(2) = iad_crktg(2,elcrktg)
88 iadc(3) = iad_crktg(3,elcrktg)
89C
90 fac = 0
91 ntag(1:3)= 0
92 itri = xfem_phantom(ilay)%ITRI(1,elcrk)
93 laycut = crkedge(ilay)%LAYCUT(elcrk)
94c---------------------------------------
95 IF (abs(laycut) == 1) THEN
96c new advancing crack
97c---------------------------------------
98 DO k=1,3
99 ied = crkedge(ilay)%IEDGETG(k,elcrktg) ! = 1,2 => sequence des arretes coupes
100 edge = xedge3n(k,elcrktg)
101 iecut = crkedge(ilay)%ICUTEDGE(edge)
102c Tip edges => NTAG = 2
103 IF (ied > 0 .and. iecut == 2) THEN ! (cas IECUT=3 traite avant)
104 ntag(k) = 2
105 ntag(d(k)) = 2
106 fac = fac + 1
107 ENDIF
108 ENDDO
109c crack touches boundary or goes through a hole due to erased element
110c touching boundary => (IBOUNDEDGE == 1)
111c going through a hole => (IBOUNDEDGE == 2)
112 DO k=1,3
113 edge = xedge3n(k,elcrktg)
114 iboundedge = crkedge(ilay)%IBORDEDGE(edge)
115c Tag boundary edges : NTAG=1
116 ied = crkedge(ilay)%IEDGETG(k,elcrktg)
117 IF (iboundedge > 0 .AND. ied > 0) THEN
118 ntag(k) = 1
119 ntag(d(k)) = 1
120 fac = fac + 1
121 ENDIF
122 ENDDO
123 DO k=1,3
124 ied = crkedge(ilay)%IEDGETG(k,elcrktg)
125 edge = xedge3n(k,elcrktg)
126 itip = crkedge(ilay)%EDGETIP(2,edge)
127 IF (ied > 0 .and. itip == 1) THEN
128 IF (itri /= 0 .and. ixel == 3) THEN
129 ntag(k) = 1
130 ntag(d(k)) = 1
131 fac = fac + 1
132 ENDIF
133 ENDIF
134 ENDDO
135c
136c NTAG = 1 for all except internal tip nodes
137 IF (fac > 0) THEN
138 DO k=1,3
139 IF (ntag(k) /= 2) ntag(k) = 1
140 END DO
141 ENDIF
142c---------------------------------------
143 ELSE IF (laycut == 2) THEN
144c old crack, element already cut previously
145c---------------------------------------
146 DO k=1,3
147 ied = crkedge(ilay)%IEDGETG(k,elcrktg)
148 edge = xedge3n(k,elcrktg)
149 iboundedge = crkedge(ilay)%IBORDEDGE(edge)
150 IF (ied > 0 .and. iboundedge == 2) THEN
151 ntag(k) = 1
152 ntag(d(k)) = 1
153 fac = fac + 1
154 ENDIF
155 ENDDO
156c
157c check if no tip edge in phantom element (count=0 => no tip)
158c
159 count = 0
160 DO k=1,3
161 ied = crkedge(ilay)%IEDGETG(k,elcrktg)
162 edge = xedge3n(k,elcrktg)
163 itip = crkedge(ilay)%EDGETIP(2,edge)
164 IF (ied > 0 .and. itip == 1) count = count + 1
165 END DO
166c
167 IF (count == 0) THEN ! already cracked phantom, no tip edge => no negative enrichments
168 DO k=1,3
169 ied = crkedge(ilay)%IEDGETG(k,elcrktg)
170 edge = xedge3n(k,elcrktg)
171 iad = iadc(k)
172 IF (itri < 0 .and. ixel == 2 .and. crklvset(ilev)%ENR0(1,iad) < 0) THEN
173c enrichment of IXEL = 2 < 0 => copy from IXEL = 3 and tag edge
174 crklvset(ilev)%ENR0(1,iad) = crklvset(ilev+1)%ENR0(1,iad)
175 fac = fac + 1
176 ntag(k) = 1
177 ntag(d(k)) = 1
178 ELSEIF (itri > 0.and. ixel == 1 .and. crklvset(ilev)%ENR0(1,iad) < 0) THEN
179c enrichment of IXEL = 1 < 0 => copy from IXEL = 3 and tag edge
180 crklvset(ilev)%ENR0(1,iad) = crklvset(ilev+2)%ENR0(1,iad)
181 fac = fac + 1
182 ntag(k) = 1
183 ntag(d(k)) = 1
184 ENDIF
185 END DO
186 ENDIF ! COUNT == 0
187c
188 ENDIF ! LAYCUT
189C--------------------------------------------------------------------------
190c set ENRTAG for nodal enrichment update (ENR > 0 only for boundary nodes)
191C--------------------------------------------------------------------------
192 IF (fac > 0) THEN
193 DO k=1,3
194 enr = abs(crklvset(ilev)%ENR0(1,iadc(k)))
195 IF (enr > 0 .AND. ntag(k) == 1) THEN
196 IF (enrtag(ns(k),enr) == 0) enrtag(ns(k),enr) = enr
197 ENDIF
198 ENDDO
199 ENDIF
200C--------------------------------------------------------------------------
201 ENDIF ! IF(ELCUT /= 0)THEN
202 ENDDO ! DO IR=1,NELCRK
203 ENDDO ! DO IXEL=1,NXEL
204 ENDDO ! DO ILAY=1,NXLAY
205C-----------------------------------------------
206 RETURN
207 END
crackxfem_mod
Definition crackxfem_mod.F:121
crackxfem_mod::xfem_phantom
type(xfem_phantom_), dimension(:), allocatable xfem_phantom
Definition crackxfem_mod.F:139
crackxfem_mod::crklvset
type(xfem_lvset_), dimension(:), allocatable crklvset
Definition crackxfem_mod.F:146
upenric2_n3
subroutine upenric2_n3(iparg, ixtg, nft, jft, jlt, elcutc, iad_crktg, iel_crktg, inod_crk, enrtag, nxlay, crkedge, xedge3n)
Definition upenric2_n3.F:33