crk_tagxp4.F File Reference

#include "implicit_f.inc"
#include "mvsiz_p.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "com_xfem1.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	crk_tagxp4 (iparg, ixc, nft, jft, jlt, elcutc, iadc_crk, iel_crk, inod_crk, enrtag, nxlay, crkedge, xedge4n, itab)

Function/Subroutine Documentation

crk_tagxp4()

subroutine crk_tagxp4	(	integer, dimension(nparg,*)	iparg,
		integer, dimension(nixc,*)	ixc,
		integer	nft,
		integer	jft,
		integer	jlt,
		integer, dimension(2,*)	elcutc,
		integer, dimension(4,*)	iadc_crk,
		integer, dimension(*)	iel_crk,
		integer, dimension(*)	inod_crk,
		integer, dimension(numnod,*)	enrtag,
		integer	nxlay,
		type (xfem_edge_), dimension(*)	crkedge,
		integer, dimension(4,*)	xedge4n,
		integer, dimension(*)	itab )

Definition at line 31 of file crk_tagxp4.F.

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