crk_tagxp4.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/.
c
!||====================================================================
!||    crk_tagxp4      ../engine/source/elements/xfem/crk_tagxp4.F
!||--- called by ------------------------------------------------------
!||    upxfem_tagxp    ../engine/source/elements/xfem/upxfem_tagxp.F
!||--- uses       -----------------------------------------------------
!||    crackxfem_mod   ../engine/share/modules/crackxfem_mod.F
!||====================================================================
      SUBROUTINE crk_tagxp4(IPARG  ,IXC     ,NFT    ,JFT     ,JLT   ,
     .                       ELCUTC ,IADC_CRK,IEL_CRK,INOD_CRK,ENRTAG,
     .                       NXLAY  ,CRKEDGE ,XEDGE4N,ITAB    )
C-----------------------------------------------
      USE crackxfem_mod
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"
#include      "param_c.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "com_xfem1.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,*),INOD_CRK(*),
     .  iadc_crk(4,*),iel_crk(*),enrtag(numnod,*),xedge4n(4,*),itab(*)
      TYPE (XFEM_EDGE_)   , DIMENSION(*) :: CRKEDGE
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,K,IR,IAD,NELCRK,ELCRK,ILEV,ILAY,IXEL,ELCUT,LAYCUT,
     .   IECUT,ENR0,ENR,IBOUNDEDGE,IED,EDGE,COUNT,ITIP,ITRI,NUMXEL,NSX,
     .   isend_nsx,isend_iad
      INTEGER JCT(MVSIZ),NS(4),IADC(4)
C=======================================================================
      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
        DO ir=1,nelcrk
          i = jct(ir)
          elcrk  = iel_crk(i+nft)                       
          elcut  = xfem_phantom(ilay)%ELCUT(elcrk)
          laycut = abs(crkedge(ilay)%LAYCUT(elcrk))        
          IF (elcut /= 0 .and. laycut == 1) THEN  !  new advancing crack
            itri    = xfem_phantom(ilay)%ITRI(1,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)       
            iadc(1) = iadc_crk(1,elcrk)  
            iadc(2) = iadc_crk(2,elcrk)  
            iadc(3) = iadc_crk(3,elcrk)  
            iadc(4) = iadc_crk(4,elcrk)
            isend_nsx = 0
            isend_iad = 0
c           Tag phantom nodes with new positive enrichment to copy the velocities
            IF (itri /= 0) THEN
              ixel = 3 
              ilev = nxel*(ilay-1) + ixel 
              ! sender = third phantom
              DO k=1,4                                                            
                iad  = iadc(k)                                                     
                enr0 = crklvset(ilev)%ENR0(2,iad)                         
                enr  = crklvset(ilev)%ENR0(1,iad)                         
                edge = xedge4n(k,elcrk) ! global egdge N                  
                iboundedge = crkedge(ilay)%IBORDEDGE(edge)                
                nsx = inod_crk(ns(k))                                     
                IF (enr > 0 .and. iboundedge /= 2) THEN                   
                  xfem_phantom(ilay)%TAGXP(1,nsx,enr) = iad                                           
                  xfem_phantom(ilay)%TAGXP(2,nsx,enr) = ilev              
                  xfem_phantom(ilay)%TAGXP(3,nsx,enr) = 2   ! counter
                  isend_nsx = nsx   
                  isend_iad = iad   
                ENDIF                                                                
              ENDDO         
            ENDIF
c
            numxel = 2    ! receiver : first or second phantom
            DO ixel=1,numxel
              ilev = nxel*(ilay-1) + ixel
              DO k=1,4                                                          
                iad  = iadc(k)                                                   
                enr0 = crklvset(ilev)%ENR0(2,iad)                         
                enr  = abs(crklvset(ilev)%ENR0(1,iad))                    
                edge = xedge4n(k,elcrk) ! global egdge N                  
                iboundedge = crkedge(ilay)%IBORDEDGE(edge)                
                nsx = inod_crk(ns(k)) 
                IF (isend_nsx /= nsx  .and. isend_iad /= iad) THEN                                  
                  IF (enr > 0 .and. iboundedge /= 2) THEN                   
                    xfem_phantom(ilay)%TAGXP(4,nsx,enr) = iad                                  
                    xfem_phantom(ilay)%TAGXP(5,nsx,enr) = ilev                    
                    xfem_phantom(ilay)%TAGXP(3,nsx,enr) = 2      ! counter        
                  ENDIF                                                             
                ENDIF                                                               
              ENDDO                                                               
            ENDDO  !  DO IXEL=1,NUMXEL
C--------------------------------------------------------------------------
          ENDIF    !  IF (ELCUT /= 0 .and. LAYCUT == 1)
        ENDDO      !  DO IR=1,NELCRK
      ENDDO        !  DO ILAY=1,NXLAY
c-----------------------------------------------
      RETURN
      END