pgrhead.F File Reference

#include "implicit_f.inc"
#include "vect01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "sms_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	pgrhead (ixp, pm, geo, inum, itr1, eadd, index, itri, ipartp, nd, igrsurf, igrbeam, cep, xep, igeo, ipouoff, tagprt_sms, ipm, itagprld_beam, ibeam_vector, rbeam_vector, xnum)

Function/Subroutine Documentation

pgrhead()

subroutine pgrhead	(	integer, dimension(6,*)	ixp,
			pm,
			geo,
		integer, dimension(9,*)	inum,
		integer, dimension(*)	itr1,
		integer, dimension(*)	eadd,
		integer, dimension(*)	index,
		integer, dimension(5,numelp)	itri,
		integer, dimension(*)	ipartp,
		integer	nd,
		type (surf_), dimension(nsurf)	igrsurf,
		type (group_), dimension(ngrbeam)	igrbeam,
		integer, dimension(*)	cep,
		integer, dimension(*)	xep,
		integer, dimension(npropgi,numgeo)	igeo,
		integer, dimension(*)	ipouoff,
		integer, dimension(*)	tagprt_sms,
		integer, dimension(npropmi,nummat)	ipm,
		integer, dimension(numelp), intent(inout)	itagprld_beam,
		integer, dimension(numelp), intent(inout)	ibeam_vector,
		dimension(3,numelp), intent(inout)	rbeam_vector,
		dimension(3,numelp), intent(inout)	xnum )

Definition at line 30 of file pgrhead.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE groupdef_mod
C-----------------------------------------------
C            A R G U M E N T S
C-----------------------------------------------
C     IXP(6,NUMELP)     TABLEAU CONECS+MID+PID+NOS POUTRES         E
C     GEO(NPROPG,NUMGEO)TABLEAU DES CARACS DES PID                 E
C     INUM(7,NUMELP)    TABLEAU DE TRAVAIL                         E/S
C     ITR1(NSELP)       TABLEAU DE TRAVAIL                         E/S
C     EADD(NUMELP)      TABLEAU DES ADRESSES DANS IDAM CHGT DAMIER   S
C     INDEX(NUMELP)     TABLEAU DE TRAVAIL                         E/S
C     ITRI(5,NUMELP)    TABLEAU DE TRAVAIL                         E/S
C     IPARTP(NUMELP)    TABLEAU PART                               E/S
C     CEP(NUMELP)    TABLEAU PROC                               E/S
C     XEP(NUMELP)    TABLEAU PROC                               E/S
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      "vect01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "sms_c.inc"
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER IXP(6,*),INUM(9,*),IPARTP(*),IGEO(NPROPGI,NUMGEO),
     .        EADD(*),ITR1(*),INDEX(*),ITRI(5,NUMELP),
     .        ND, CEP(*), XEP(*),IPOUOFF(*),
     .        TAGPRT_SMS(*),IPM(NPROPMI,NUMMAT)
      INTEGER ,INTENT(INOUT), DIMENSION(NUMELP) ::ITAGPRLD_BEAM
      INTEGER ,INTENT(INOUT) :: IBEAM_VECTOR(NUMELP)
      my_real pm(npropm,nummat), geo(npropg,numgeo)
      my_real ,INTENT(INOUT) :: rbeam_vector(3,numelp)
      my_real ,INTENT(INOUT) :: xnum(3,numelp)
C-----------------------------------------------
      TYPE (GROUP_)  , DIMENSION(NGRBEAM)  :: IGRBEAM
      TYPE (SURF_)   , DIMENSION(NSURF)    :: IGRSURF
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER :: I, K,  MLN, ISSN, NN, MID, PID,IGTYP
      INTEGER :: II, J, II2,JJ2,JJ,II3,JJ3,II4,JJ4,II5,JJ5,NPG,MODE
      INTEGER ::  WORK(70000)
      INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND,IPRLD
      EXTERNAL my_shiftl,my_shiftr,my_and
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
C   TRI GLOBAL SUR TOUS LES CRITERES POUR TOUS LES ELEMENTS
C----------------------------------------------------------
C
      DO i=1,numelp
        eadd(i)=1
        index(i)=i
        inum(1,i)=ipartp(i)
        inum(2,i)=ixp(1,i)
        inum(3,i)=ixp(2,i)
        inum(4,i)=ixp(3,i)
        inum(5,i)=ixp(4,i)
        inum(6,i)=ixp(5,i)
        inum(7,i)=ixp(6,i)
        inum(8,i)=ipouoff(i)
        inum(9,i)=ibeam_vector(i)  
        xnum(1:3,i)=rbeam_vector(1:3,i)             
      ENDDO
 
      DO i=1,numelp
        xep(i)=cep(i)
      ENDDO
C
C
      DO i = 1, numelp
        ii = i
        mid= ixp(1,ii)
        mln= int(pm(19,mid))
        pid= ixp(5,ii)
        issn = 0
        IF(geo(5,pid)/=zero) issn=1
        iprld = itagprld_beam(ii)
        npg   = igeo(3,pid)
        igtyp = igeo(11,pid) + iprld
        jthe = nint(pm(71,mid))
        iexpan = ipm(218,mid)
c
        igtyp = my_shiftl(igtyp,12)
        issn  = my_shiftl(issn,6)
        jthe  = my_shiftl(jthe,9)
        iexpan  = my_shiftl(iexpan,12)
        mln   = my_shiftl(mln,21)
C
        itri(1,i) = mln + igtyp + issn + jthe + iexpan
        itri(2,i) = ipouoff(i)
C
        jsms = 0
        IF(isms/=0)THEN
          IF(idtgrs/=0)THEN
            IF(tagprt_sms(ipartp(ii))/=0)jsms=1
          ELSE
            jsms=1
          END IF
        END IF
C       JSMS = MY_SHIFTL(JSMS,0)
        npg  = my_shiftl(npg,12)
        itri(3,i) = jsms+npg
C       NEXT = MY_SHIFTL(NEXT,1)
     
C---     Key 4 
C       MID = MY_SHIFTL(MID,0)
        itri(4,i) = mid
C---     Key 5 
C       PID = MY_SHIFTL(PID,0)
        itri(5,i) = pid
 
      ENDDO
C
      mode=0
      CALL my_orders( mode, work, itri, index, numelp , 5)
C
      DO i=1,numelp
        ipartp(i) = inum(1,index(i))
        ipouoff(i)= inum(8,index(i))
        ibeam_vector(i)= inum(9,index(i))
        rbeam_vector(1:3,i)= xnum(1:3,index(i))
      ENDDO
      DO i=1,numelp
        cep(i)=xep(index(i))
      ENDDO
      DO  k=1,6
        DO  i=1,numelp
          ixp(k,i)=inum(k+1,index(i))
        ENDDO
      ENDDO
C
C INVERSION DE INDEX (DANS ITR1)
C
      DO i=1,numelp
        itr1(index(i))=i
      ENDDO
C
C RENUMEROTATION POUR SURFACES
C
      DO i=1,nsurf
        nn=igrsurf(i)%NSEG
        DO j=1,nn
          IF(igrsurf(i)%ELTYP(j) == 5)
     .       igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
        ENDDO
      ENDDO
C
C RENUMEROTATION POUR GROUPES DE POUTRES
C
      DO i=1,ngrbeam
        nn=igrbeam(i)%NENTITY
        DO j=1,nn
          igrbeam(i)%ENTITY(j) = itr1(igrbeam(i)%ENTITY(j))
        ENDDO
      ENDDO
C REORDERING FOR ITAGPRLD_BEAM
      inum(8,1:numelp)=itagprld_beam(1:numelp)
      DO i=1,numelp
        itagprld_beam(i) = inum(8,index(i))
      ENDDO
C
C--------------------------------------------------------------
C         DETERMINATION DES SUPER_GROUPES
C--------------------------------------------------------------
      nd=1
      DO i=2,numelp
        ii  = itri(1,index(i))
        jj  = itri(1,index(i-1))
        ii2 = itri(2,index(i))
        jj2 = itri(2,index(i-1))
        ii3 = itri(3,index(i))
        jj3 = itri(3,index(i-1))
        ii4 = itri(4,index(i))
        jj4 = itri(4,index(i-1))
        ii5 = itri(5,index(i))
        jj5 = itri(5,index(i-1))
        IF (ii/=jj .OR. ii2/=jj2 .OR. ii3/=jj3 .OR. ii4/=jj4 .OR. ii5/=jj5) THEN
          nd=nd+1
          eadd(nd)=i
        ENDIF
      ENDDO
      eadd(nd+1) = numelp+1
C
      RETURN