parsor_crk.F File Reference

#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "com_xfem1.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	parsor_crk (iparg, ixc, ixtg, el2fa, idcrk, iad_crk, iad_crkg, nbf_l, nbf, iel_crk, nodglobxfe, indx_crk, itab)

Function/Subroutine Documentation

parsor_crk()

subroutine parsor_crk	(	integer, dimension(nparg,ngroup)	iparg,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	el2fa,
		integer	idcrk,
		integer, dimension(*)	iad_crk,
		integer, dimension(nspmd,*)	iad_crkg,
		integer	nbf_l,
		integer	nbf,
		integer, dimension(*)	iel_crk,
		integer, dimension(*)	nodglobxfe,
		integer, dimension(*)	indx_crk,
		integer, dimension(*)	itab )

Definition at line 35 of file parsor_crk.F.

C-----------------------------------------------
      USE crackxfem_mod
      USE my_alloc_mod
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      "com01_c.inc"
#include      "com04_c.inc"
#include      "com_xfem1.inc"
#include      "param_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IXC(NIXC,*),IXTG(NIXTG,*),IPARG(NPARG,NGROUP),IEL_CRK(*),
     .        EL2FA(*),IDCRK,IAD_CRK(*),IAD_CRKG(NSPMD,*),INDX_CRK(*),
     .        NBF_L,NBF,NODGLOBXFE(*),ITAB(*)
C-----------------------------------------------
C     REAL
      my_real off
      INTEGER IE,NG,ITY,LFT,LLT,N,I,J,NEL,NFT,JJ,K,BUF,IXFEM,
     .        IPT,ELC,CRKS,ICRK,IE_EL2FA,NEL_CRK,EMPL,NLEVXF
      INTEGER II(4)
      INTEGER,DIMENSION(:),ALLOCATABLE::NP
C=======================================================================
C     CRK ELEMS INIT
C-----------------------------------------------
      CALL my_alloc(np, nbf_l*4)
      nel_crk = 0
      jj = 0
      ie = 0
C-----------------------------------------------
      DO crks = 1,ncrkpart
        icrk = indx_crk(crks)
        ie_el2fa = 0
C
C en spmd il faut envoyer l'info meme qd on a 0 elem local
C
        DO ng=1,ngroup
          nel   =iparg(2,ng)
          nft   =iparg(3,ng)
          ity   =iparg(5,ng)
          ixfem =iparg(54,ng)
          lft=1
          llt=nel
          nlevxf = iparg(65,ng)
C-----------------------------------------------
C       COQUES
C-----------------------------------------------
          IF (ixfem > 0) THEN
           IF(ixfem == 2 .AND. icrk > nlevxf) cycle
            IF (ity == 3) THEN
              DO i=lft,llt
                n = i + nft
                IF (iel_crk(n) == 0) cycle
                ie = ie + 1
                ie_el2fa = ie_el2fa + 1
                ii(1) = crkshell(icrk)%XNODEL(1,ie_el2fa)
                ii(2) = crkshell(icrk)%XNODEL(2,ie_el2fa)
                ii(3) = crkshell(icrk)%XNODEL(3,ie_el2fa)
                ii(4) = crkshell(icrk)%XNODEL(4,ie_el2fa)
c                print*,'ICRK,ID=',ICRK,CRKSHELL(ICRK)%CRKSHELLID(IE_EL2FA)
c                print*,'  NODES=',ITAB(II(1)),ITAB(II(2)),ITAB(II(3)),ITAB(II(4))
                IF (nspmd == 1) THEN
                  ii(1) = ii(1)-1+idcrk
                  ii(2) = ii(2)-1+idcrk
                  ii(3) = ii(3)-1+idcrk
                  ii(4) = ii(4)-1+idcrk
                  CALL write_i_c(ii,4)
                ELSE
                  np(jj+1) = nodglobxfe(ii(1))-1+idcrk
                  np(jj+2) = nodglobxfe(ii(2))-1+idcrk
                  np(jj+3) = nodglobxfe(ii(3))-1+idcrk
                  np(jj+4) = nodglobxfe(ii(4))-1+idcrk
                ENDIF
                el2fa(nel_crk+ie_el2fa) = ie 
                jj = jj + 4
              ENDDO
C-----------------------------------------------
C             COQUES 3 NOEUDS
C-----------------------------------------------
            ELSEIF (ity == 7) THEN
              DO i=lft,llt
                n = i + nft
                IF (iel_crk(n+numelc) == 0) cycle
                ie = ie + 1
                ie_el2fa = ie_el2fa + 1
                ii(1) = crkshell(icrk)%XNODEL(1,ie_el2fa)
                ii(2) = crkshell(icrk)%XNODEL(2,ie_el2fa)
                ii(3) = crkshell(icrk)%XNODEL(3,ie_el2fa)
                ii(4) = crkshell(icrk)%XNODEL(3,ie_el2fa)
c                II(4) = CRKSHELL(ICRK)%XNODEL(4,IE_EL2FA)
                IF(nspmd == 1)THEN
                  ii(1) = ii(1)-1+idcrk
                  ii(2) = ii(2)-1+idcrk
                  ii(3) = ii(3)-1+idcrk
                  ii(4) = ii(4)-1+idcrk
                  CALL write_i_c(ii,4)
                ELSE
                  np(jj+1) = nodglobxfe(ii(1))-1+idcrk
                  np(jj+2) = nodglobxfe(ii(2))-1+idcrk
                  np(jj+3) = nodglobxfe(ii(3))-1+idcrk
                  np(jj+4) = nodglobxfe(ii(3))-1+idcrk
c                  NP(JJ+4) = NODGLOBXFE(II(4))-1+IDCRK
                ENDIF
                el2fa(nel_crk+ie_el2fa) = ie
                jj = jj + 4
              ENDDO
            ENDIF  !  IF (ITY == 3)
          ENDIF  !  IF (IXFEM == 1 .OR. IXFEM == 2)
        ENDDO  !  DO NG=1,NGROUP
C
        iad_crk(icrk) = ie
        nel_crk = nel_crk + crkshell(icrk)%CRKNUMSHELL
      ENDDO  !  DO CRKS = 1,NCRKPART
c----------------------------------------
      IF (nspmd > 1) THEN
C   construction tableau global des parts sur p0
        IF(ispmd == 0)THEN
          CALL spmd_iglob_partn(iad_crk,ncrkpart,iad_crkg,ncrkpart)
          buf = 4 * nbf
          CALL spmd_iget_partn(4,jj,np,ncrkpart,iad_crkg,buf,1)
        ELSE
          CALL spmd_iglob_partn(iad_crk,ncrkpart,iad_crkg,1)
          buf=1
          CALL spmd_iget_partn(4,jj,np,ncrkpart,iad_crkg,buf,1)
        ENDIF
C
      ELSE ! remplissage IADG pour compatibilite mono/multi
        DO i = 1, ncrkpart
          iad_crkg(1,i) = iad_crk(i)
        END DO
      ENDIF
C-----------
      DEALLOCATE(np)
      RETURN