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