upenric1_n4.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    upenric1_n4     ../engine/source/elements/xfem/upenric1_n4.F
!||--- called by ------------------------------------------------------
!||    upxfem1         ../engine/source/elements/xfem/upxfem1.F
!||--- uses       -----------------------------------------------------
!||    crackxfem_mod   ../engine/share/modules/crackxfem_mod.F
!||    element_mod     ../common_source/modules/elements/element_mod.F90
!||====================================================================
      SUBROUTINE upenric1_n4(IPARG  ,IXC     ,NFT     ,JFT     ,JLT   ,
     .                       ELCUTC ,IADC_CRK,IEL_CRK ,INOD_CRK,NXLAY ,
     .                       NODEDGE,ENRTAG  ,CRKEDGE ,XEDGE4N )
C-----------------------------------------------
      USE crackxfem_mod
      use element_mod , only : nixc
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "mvsiz_p.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "com_xfem1.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NFT,JFT,JLT,NXLAY
      INTEGER IPARG(NPARG,*),IXC(NIXC,*),ELCUTC(2,*),IADC_CRK(4,*),
     .  iel_crk(*),enrtag(numnod,*),inod_crk(*),nodedge(2,*),xedge4n(4,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,K,K1,K2,IR,II,ELCRK,ILEV,LAYCUT,IECUT,ILAY,IXEL,NELCRK,
     .   IADC1,IADC2,IADC3,IADC4,IE10,IE20,IE1,IE2,NOD1,NOD2,IED,EDGE,
     .   en1,en2,en3,en4
      INTEGER JCT(MVSIZ),ENR0(4),D(4),NS(4)
      DATA D/2,3,4,1/
      TYPE (XFEM_EDGE_) , DIMENSION(*) :: CRKEDGE
C=======================================================================
c     tag all standard cracked elements (all layers included)
      nelcrk = 0
      DO i=jft,jlt
        jct(i) = 0
        IF (elcutc(1,i+nft) /= 0) THEN
          nelcrk = nelcrk + 1
          jct(nelcrk) = i
        ENDIF
      ENDDO
      IF (nelcrk == 0) RETURN
C---
      DO ilay=1,nxlay
        ii = nxel*(ilay-1)    
        DO ir=1,nelcrk
          i = jct(ir)
          elcrk  = iel_crk(i+nft)
          laycut = crkedge(ilay)%LAYCUT(elcrk)
          IF (laycut /= 0) THEN
            iadc1 = iadc_crk(1,elcrk)
            iadc2 = iadc_crk(2,elcrk)
            iadc3 = iadc_crk(3,elcrk)
            iadc4 = iadc_crk(4,elcrk)
            ns(1) = ixc(2,i+nft)
            ns(2) = ixc(3,i+nft)
            ns(3) = ixc(4,i+nft)
            ns(4) = ixc(5,i+nft)
C
            DO ixel=1,nxel
              ilev = ii+ixel  
              enr0(1) = 0
              enr0(2) = 0
              enr0(3) = 0
              enr0(4) = 0
              en1 = crklvset(ilev)%ENR0(1,iadc1)
              en2 = crklvset(ilev)%ENR0(1,iadc2)
              en3 = crklvset(ilev)%ENR0(1,iadc3)
              en4 = crklvset(ilev)%ENR0(1,iadc4)
              IF (en1 /= 0) enr0(1) = en1
              IF (en2 /= 0) enr0(2) = en2
              IF (en3 /= 0) enr0(3) = en3
              IF (en4 /= 0) enr0(4) = en4
C
              DO k=1,4
                edge  = xedge4n(k,elcrk)
                iecut = crkedge(ilay)%ICUTEDGE(edge)
                ie1   = 0
                ie2   = 0
                ied   = crkedge(ilay)%IEDGEC(k,elcrk)
                IF (iecut == 3 .and. ied > 0) THEN ! connection edge  (crklayer_adv,_ini)
                  nod1 = nodedge(1,edge)
                  nod2 = nodedge(2,edge)
                  ie10 = crkedge(ilay)%EDGEENR(1,edge)
                  ie20 = crkedge(ilay)%EDGEENR(2,edge)
                  IF (nod1 == ixc(k+1,i+nft) .and.
     .                nod2 == ixc(d(k)+1,i+nft)) THEN
                    k1 = k
                    k2 = d(k)
                    ie1 = enr0(k)
                    ie2 = enr0(d(k))
                  ELSE IF (nod2 == ixc(k+1,i+nft) .and.
     .                     nod1 == ixc(d(k)+1,i+nft)) THEN
                    k1 = d(k)
                    k2 = k
                    ie1 = enr0(d(k))
                    ie2 = enr0(k)
                  ENDIF
c
c                 set ENRTAG for nodal enrichment update
c
                  IF (ie1 /= 0) enrtag(ns(k1),abs(ie1))
     .                        = max(enrtag(ns(k1),abs(ie1)),ie10)
                  IF (ie2 /= 0) enrtag(ns(k2),abs(ie2))
     .                        = max(enrtag(ns(k2),abs(ie2)),ie20)
     
c                  if (IE1 /= 0) then
c                    write(*,'(A,3I5)') 'UPX1: NS,IE,ENRTAG=',NS(K1),IE1,ENRTAG(NS(K1),ABS(IE1))
c                  endif
c                  if (IE2 /= 0) then
c                    write(*,'(A,3I5)') 'UPX1: NS,IE,ENRTAG=',NS(K2),IE1,ENRTAG(NS(K2),ABS(IE2))
c                  endif
C
                ENDIF ! IF (IECUT == 3)
              ENDDO ! DO K=1,4
            ENDDO   ! IXEL=1,NXEL
          ENDIF   ! If (laycut /= 0)
        ENDDO     ! DO IR=1,NELCRK
      ENDDO       ! DO ILAY=1,NXLAY
C-----------------------------------------------
      RETURN
      END