upd_failwave_sh4n.F File Reference

#include "implicit_f.inc"
#include "com04_c.inc"
#include "comlock.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	set_failwave_sh4n (failwave, fwave_el, dadv, nel, ixc, itab, ngl, offly)

Function/Subroutine Documentation

set_failwave_sh4n()

subroutine set_failwave_sh4n	(	type (failwave_str_)	failwave,
		integer, dimension(nel), intent(out)	fwave_el,
		intent(in)	dadv,
		integer	nel,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(numnod), intent(in)	itab,
		integer, dimension(nel), intent(in)	ngl,
		integer, dimension(nel), intent(in)	offly )

Definition at line 33 of file upd_failwave_sh4n.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE failwave_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   C o m m o n   B l o c k s
C-----------------------------------------------
#include "com04_c.inc"
#include "comlock.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NEL
      INTEGER IXC(NIXC,*)
      INTEGER, DIMENSION(NEL)   , INTENT(IN)    :: NGL,OFFLY
      INTEGER, DIMENSION(NUMNOD), INTENT(IN)    :: ITAB 
      my_real ,DIMENSION(NEL)   , INTENT(IN)    :: dadv  
      INTEGER, DIMENSION(NEL)   , INTENT(OUT)   :: FWAVE_EL
      TYPE (FAILWAVE_STR_)  :: FAILWAVE 
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,II,K,N1,N2,N3,N4,FOUND,LEVEL,NINDX,NFAIL,FNOD1,FNOD2,
     .   KNEXT,KPREV,NCURR
      INTEGER ,DIMENSION(NEL) :: INDX
      INTEGER ,DIMENSION(4)   :: NDL,NDR,NOD_ID,NOD_NN
c---
      DATA ndr/2,3,4,1/
      DATA ndl/4,1,2,3/
c-----------------------------------------------
c set failure flag to elements using nodal frontwave information from neighbors
C=======================================================================
c
c---------------
      SELECT CASE (failwave%WAVE_MOD)
c---------------
        CASE (1)   ! isotropic propagation
c---------------
          DO i=1,nel
            IF (offly(i) == 1 .and. dadv(i) == one) THEN
              n1 = failwave%IDXI(ixc(2,i))
              n2 = failwave%IDXI(ixc(3,i))
              n3 = failwave%IDXI(ixc(4,i))
              n4 = failwave%IDXI(ixc(5,i))
              nfail = failwave%FWAVE_NOD(1,n1,1) 
     .              + failwave%FWAVE_NOD(1,n2,1)
     .              + failwave%FWAVE_NOD(1,n3,1)
     .              + failwave%FWAVE_NOD(1,n4,1)
              IF (nfail > 0) fwave_el(i) = 1
            ENDIF
          ENDDO
c---------------
        CASE (2)   ! directional propagation through edges only
c---------------
          nindx = 0
          DO i=1,nel
            IF (offly(i) == 1 .and. dadv(i) == one) THEN
              nindx = nindx + 1    ! count of non damaged elements
              indx(nindx) = i
            ENDIF
          ENDDO
c
          DO ii=1,nindx         
            i = indx(ii)        
            n1 = ixc(2,i)
            n2 = ixc(3,i)
            n3 = ixc(4,i)
            n4 = ixc(5,i)
            nod_nn(1) = failwave%IDXI(n1)  
            nod_nn(2) = failwave%IDXI(n2)  
            nod_nn(3) = failwave%IDXI(n3)  
            nod_nn(4) = failwave%IDXI(n4)  
            nod_id(1) = itab(n1)   
            nod_id(2) = itab(n2)   
            nod_id(3) = itab(n3)   
            nod_id(4) = itab(n4)
            found = 0   
c
            DO k=1,4
              ncurr = nod_nn(k)
              IF (failwave%MAXLEV(ncurr) > 0) THEN
                knext = ndr(k)  
                kprev = ndl(k)
c
                DO level = 1,failwave%MAXLEV(ncurr)
                  fnod1 = failwave%FWAVE_NOD(1,ncurr,level)
                  fnod2 = failwave%FWAVE_NOD(2,ncurr,level)
c
                  IF (fnod1 == nod_id(knext) .and. fnod2 == 0) THEN
                    found = 1
                    fwave_el(i) = 1
                    EXIT
                  ENDIF
                ENDDO  !  LEVEL
                IF (found == 1) EXIT
              ENDIF
            ENDDO    !  K=1,4 
c
c            IF (FOUND == 1) THEN
c#include "lockon.inc"
c              write(iout,'(A,I10)')'set failwave flag to element=',ngl(I)
c#include "lockoff.inc"
c            ENDIF
c
          ENDDO     !  II=1,NINDX   
c
c---------------
        CASE (3)   ! directional propagation through edges and diagonals
c---------------
c
          nindx = 0
          DO i=1,nel
            IF (offly(i) == 1 .and. dadv(i) == one) THEN
              nindx = nindx + 1
              indx(nindx) = i
            ENDIF
          ENDDO
c
          DO ii=1,nindx
            i = indx(ii)
            n1 = ixc(2,i)
            n2 = ixc(3,i)
            n3 = ixc(4,i)
            n4 = ixc(5,i)
            nod_nn(1) = failwave%IDXI(n1)  
            nod_nn(2) = failwave%IDXI(n2)  
            nod_nn(3) = failwave%IDXI(n3)  
            nod_nn(4) = failwave%IDXI(n4)  
            nod_id(1) = itab(n1)   
            nod_id(2) = itab(n2)   
            nod_id(3) = itab(n3)   
            nod_id(4) = itab(n4)
            found = 0   
c
            DO k=1,4
              ncurr = nod_nn(k)       
              IF (failwave%MAXLEV(ncurr) > 0) THEN
                knext = ndr(k)  
                kprev = ndl(k)
c
                DO level = 1,failwave%MAXLEV(ncurr)
                  fnod1 = failwave%FWAVE_NOD(1,ncurr,level)
                  fnod2 = failwave%FWAVE_NOD(2,ncurr,level)
c
                  IF (fnod2 == 0 .and. 
     .               (fnod1 == nod_id(knext) .or. fnod1 == nod_id(kprev))) THEN
                    found = 1   ! failwave coming by edge
                    EXIT
                  ELSE IF (fnod1 > 0 .and. fnod2 > 0 .and.
     .              fnod1 /= nod_id(kprev) .and. fnod1 /= nod_id(knext) .and.
     .              fnod2 /= nod_id(kprev) .and. fnod2 /= nod_id(knext)) THEN
                    found = 2   ! failwave coming by diagonal
                    EXIT
                  ENDIF
                ENDDO  !  LEVEL
                IF (found > 0) THEN
                  fwave_el(i) = 1
                  EXIT
                ENDIF
c
              ENDIF
            ENDDO    !  K=1,4 
c
c            IF (FOUND == 1) THEN
c#include "lockon.inc"
c              write(iout,'(A,I10)') 'set edge failwave to element=',ngl(I)
c#include "lockoff.inc"
c            ELSE IF (FOUND == 2) THEN
c#include "lockon.inc"
c              write(iout,'(A,I10)') 'set diag failwave to element=',ngl(I)
c#include "lockoff.inc"
c            ENDIF
c
          ENDDO       !  II=1,NINDX  
c---------------
      END SELECT
c---------------
      RETURN