OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
upenric1_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!|| upenric1_n4 ../engine/source/elements/xfem/upenric1_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!||====================================================================
30 SUBROUTINE upenric1_n4(IPARG ,IXC ,NFT ,JFT ,JLT ,
31 . ELCUTC ,IADC_CRK,IEL_CRK ,INOD_CRK,NXLAY ,
32 . NODEDGE,ENRTAG ,CRKEDGE ,XEDGE4N )
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,*),IXC(NIXC,*),ELCUTC(2,*),IADC_CRK(4,*),
54 . iel_crk(*),enrtag(numnod,*),inod_crk(*),nodedge(2,*),xedge4n(4,*)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER I,J,K,K1,K2,IR,II,ELCRK,ILEV,LAYCUT,IECUT,ILAY,IXEL,NELCRK,
59 . IADC1,IADC2,IADC3,IADC4,IE10,IE20,IE1,IE2,NOD1,NOD2,IED,EDGE,
60 . en1,en2,en3,en4
61 INTEGER JCT(MVSIZ),ENR0(4),D(4),NS(4)
62 DATA D/2,3,4,1/
63 TYPE (XFEM_EDGE_) , DIMENSION(*) :: CRKEDGE
64C=======================================================================
65c tag all standard cracked elements (all layers included)
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 ii = nxel*(ilay-1)
78 DO ir=1,nelcrk
79 i = jct(ir)
80 elcrk = iel_crk(i+nft)
81 laycut = crkedge(ilay)%LAYCUT(elcrk)
82 IF (laycut /= 0) THEN
83 iadc1 = iadc_crk(1,elcrk)
84 iadc2 = iadc_crk(2,elcrk)
85 iadc3 = iadc_crk(3,elcrk)
86 iadc4 = iadc_crk(4,elcrk)
87 ns(1) = ixc(2,i+nft)
88 ns(2) = ixc(3,i+nft)
89 ns(3) = ixc(4,i+nft)
90 ns(4) = ixc(5,i+nft)
91C
92 DO ixel=1,nxel
93 ilev = ii+ixel
94 enr0(1) = 0
95 enr0(2) = 0
96 enr0(3) = 0
97 enr0(4) = 0
98 en1 = crklvset(ilev)%ENR0(1,iadc1)
99 en2 = crklvset(ilev)%ENR0(1,iadc2)
100 en3 = crklvset(ilev)%ENR0(1,iadc3)
101 en4 = crklvset(ilev)%ENR0(1,iadc4)
102 IF (en1 /= 0) enr0(1) = en1
103 IF (en2 /= 0) enr0(2) = en2
104 IF (en3 /= 0) enr0(3) = en3
105 IF (en4 /= 0) enr0(4) = en4
106C
107 DO k=1,4
108 edge = xedge4n(k,elcrk)
109 iecut = crkedge(ilay)%ICUTEDGE(edge)
110 ie1 = 0
111 ie2 = 0
112 ied = crkedge(ilay)%IEDGEC(k,elcrk)
113 IF (iecut == 3 .and. ied > 0) THEN ! connection edge (crklayer_adv,_ini)
114 nod1 = nodedge(1,edge)
115 nod2 = nodedge(2,edge)
116 ie10 = crkedge(ilay)%EDGEENR(1,edge)
117 ie20 = crkedge(ilay)%EDGEENR(2,edge)
118 IF (nod1 == ixc(k+1,i+nft) .and.
119 . nod2 == ixc(d(k)+1,i+nft)) THEN
120 k1 = k
121 k2 = d(k)
122 ie1 = enr0(k)
123 ie2 = enr0(d(k))
124 ELSE IF (nod2 == ixc(k+1,i+nft) .and.
125 . nod1 == ixc(d(k)+1,i+nft)) THEN
126 k1 = d(k)
127 k2 = k
128 ie1 = enr0(d(k))
129 ie2 = enr0(k)
130 ENDIF
131c
132c set ENRTAG for nodal enrichment update
133c
134 IF (ie1 /= 0) enrtag(ns(k1),abs(ie1))
135 . = max(enrtag(ns(k1),abs(ie1)),ie10)
136 IF (ie2 /= 0) enrtag(ns(k2),abs(ie2))
137 . = max(enrtag(ns(k2),abs(ie2)),ie20)
138
139c if (IE1 /= 0) then
140c write(*,'(A,3I5)') 'UPX1: NS,IE,ENRTAG=',NS(K1),IE1,ENRTAG(NS(K1),ABS(IE1))
141c endif
142c if (IE2 /= 0) then
143c write(*,'(A,3I5)') 'UPX1: NS,IE,ENRTAG=',NS(K2),IE1,ENRTAG(NS(K2),ABS(IE2))
144c endif
145C
146 ENDIF ! IF (IECUT == 3)
147 ENDDO ! DO K=1,4
148 ENDDO ! IXEL=1,NXEL
149 ENDIF ! IF (LAYCUT /= 0)
150 ENDDO ! DO IR=1,NELCRK
151 ENDDO ! DO ILAY=1,NXLAY
152C-----------------------------------------------
153 RETURN
154 END
max
#define max(a, b)
Definition macros.h:21
crackxfem_mod
Definition crackxfem_mod.F:121
crackxfem_mod::crklvset
type(xfem_lvset_), dimension(:), allocatable crklvset
Definition crackxfem_mod.F:146
upenric1_n4
subroutine upenric1_n4(iparg, ixc, nft, jft, jlt, elcutc, iadc_crk, iel_crk, inod_crk, nxlay, nodedge, enrtag, crkedge, xedge4n)
Definition upenric1_n4.F:33