parsorc.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	parsorc (x, d, xnorm, iadd, cdg, bufel, iparg, ixq, ixc, ixtg, invert, el2fa, mater, ipartq, ipartc, iparttg, elbuf_tab)

Function/Subroutine Documentation

parsorc()

subroutine parsorc	(		x,
			d,
			xnorm,
		integer, dimension(*)	iadd,
			cdg,
			bufel,
		integer, dimension(nparg,*)	iparg,
		integer, dimension(nixq,*)	ixq,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(*)	invert,
		integer, dimension(*)	el2fa,
		integer, dimension(*)	mater,
		integer, dimension(*)	ipartq,
		integer, dimension(*)	ipartc,
		integer, dimension(*)	iparttg,
		type (elbuf_struct_), dimension(ngroup)	elbuf_tab )

Definition at line 31 of file parsorc.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE elbufdef_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      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      my_real
     .   x(*),d(*),xnorm(3,*),cdg(*),bufel(*)
      INTEGER IXC(NIXC,*),IXTG(NIXTG,*),IADD(*),IPARG(NPARG,*),
     .        IXQ(NIXQ,*),
     .        INVERT(*), EL2FA(*),MATER(*),
     .        IPARTQ(*),IPARTC(*),IPARTTG(*)
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP) :: ELBUF_TAB
C-----------------------------------------------
C     REAL
      my_real
     .   off
      INTEGER II(4),IE,NG, ITY, LFT, LLT, KPT, N, I, J, 
     .        IPRT, NEL, IAD, NPAR, NFT, IMID,IALEL,MTN,
     .        NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10,
     .        JJ, K, SH_IH, IHBE,BUF
      INTEGER NP((NUMELQ + NUMELC + NUMELTG )*4)
C-----------------------------------------------
C     NORMALE
C-----------------------------------------------
      DO k=1,numnod
        DO  j=1,3
         xnorm(j,k) = zero
        ENDDO
      ENDDO
      ie = 0
C
      nn1 = 1
      nn2 = 1
      nn3 = 1
      nn4 = nn3 + numelq
      nn5 = nn4 + numelc
      nn6 = nn5 + numeltg
      nn7 = nn6
      nn8 = nn7
      nn9 = nn8
C-----------------------------------------------
      npar = 0
C
C-----------------------------------------------
C     PART
C-----------------------------------------------
      IF(numelq + numelc + numeltg/=0)THEN
      jj = 0
 
      DO 500 iprt=1,npart
       IF(mater(iprt)==0)GOTO 500
       npar = npar + 1
       DO 490 ng=1,ngroup
        mtn   =iparg(1,ng)
        nel   =iparg(2,ng)
        nft   =iparg(3,ng)
        iad   =iparg(4,ng)
        ity   =iparg(5,ng)
        lft=1
        llt=nel
C-----------------------------------------------
C       QUAD
C-----------------------------------------------
        IF(ity==2)THEN
         DO 20 i=lft,llt
          n = i + nft
          IF(ipartq(n)/=iprt) GOTO 20
          IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
             ii(1) = ixq(2,n)
             ii(2) = ixq(3,n)
             ii(3) = ixq(4,n)
             ii(4) = ixq(5,n)
 
             xnorm(1,ii(1)) = one
             xnorm(2,ii(1)) = zero
             xnorm(3,ii(1)) = zero             
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ie = ie + 1
             invert(ie) = 1
             el2fa(nn3+n) = ie
             jj = jj + 4
 20      CONTINUE
C-----------------------------------------------
C       COQUES
C-----------------------------------------------
        ELSEIF(ity==3)THEN
         kpt   =iparg(6,ng)
         ihbe = iparg(23,ng)
         sh_ih = 16
          IF (ihbe>=21.AND.ihbe<=29) sh_ih = 17
          IF (ihbe==22) sh_ih = sh_ih + 6
         DO 130 i=lft,llt
          n = i + nft
          IF(ipartc(n)/=iprt)GOTO 130
          IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
             ii(1) = ixc(2,n)
             ii(2) = ixc(3,n)
             ii(3) = ixc(4,n)
             ii(4) = ixc(5,n)
             ie = ie + 1
 
             CALL facnor(x,d,ii,xnorm,cdg,invert(ie))
 
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             el2fa(nn4+n) = ie
             jj = jj + 4
 130     CONTINUE
C-----------------------------------------------
C       COQUES 3 NOEUDS
C-----------------------------------------------
        ELSEIF(ity==7)THEN
         kpt   =iparg(6,ng)
         DO 170 i=lft,llt
          n = i + nft
          IF(iparttg(n)/=iprt)GOTO 170
          IF (mtn/=0 .AND. mtn/=13) off=elbuf_tab(ng)%GBUF%OFF(i)
             ii(1) = ixtg(2,n)
             ii(2) = ixtg(3,n)
             ii(3) = ixtg(4,n)
             ii(4) = ii(3)
             ie = ie + 1
             CALL facnor(x,d,ii,xnorm,cdg,invert(ie))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             el2fa(nn5+n) = ie
             jj = jj + 4
 170     CONTINUE
 
        ELSE
        ENDIF
 490   CONTINUE
C
 
C-----------------------------------------------
C       PART ADRESS
C-----------------------------------------------
       iadd(npar) = ie
 500  CONTINUE
      ENDIF
C-----------------------------------------------
      RETURN