xgrhead.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	xgrhead (kxx, geo, inum, itr1, eadd, index, itri, ipartx, nd, igrsurf, cep, xep, ipm)

Function/Subroutine Documentation

xgrhead()

subroutine xgrhead	(	integer, dimension(5,*)	kxx,
			geo,
		integer, dimension(6,*)	inum,
		integer, dimension(*)	itr1,
		integer, dimension(*)	eadd,
		integer, dimension(*)	index,
		integer, dimension(4,*)	itri,
		integer, dimension(*)	ipartx,
		integer	nd,
		type (surf_), dimension(nsurf)	igrsurf,
		integer, dimension(*)	cep,
		integer, dimension(*)	xep,
		integer, dimension(npropmi,*)	ipm )

Definition at line 32 of file xgrhead.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE groupdef_mod
C-----------------------------------------------
C            A R G U M E N T S
C-----------------------------------------------
C     KXX(5,NUMELX)     TABLEAU CONECS+PID+No ElEMENTS MULTIBRIN   E
C     GEO(NPROPG,NUMGEO)TABLEAU DES CARACS DES PID                 E
C     INUM(6,NUMELX)    TABLEAU DE TRAVAIL                         E/S
C     ITR1(NSELR)       TABLEAU DE TRAVAIL                         E/S
C     EADD(NUMELX)      TABLEAU DES ADRESSES DANS IDAM CHGT DAMIER   S
C     INDEX(NUMELX)     TABLEAU DE TRAVAIL                         E/S
C     ITRI(4,NUMELX)    TABLEAU DE TRAVAIL                         E/S
C     IPARTX(NUMELX)    TABLEAU PART                               E/S
C     CEP(NUMELX)    TABLEAU PROC                                  E/S
C     XEP(NUMEX)    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"
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER KXX(5,*),INUM(6,*),IPARTX(*),
     .        EADD(*),ITR1(*),INDEX(*),ITRI(4,*),
     .        ND, CEP(*), XEP(*),
     .        IPM(NPROPMI,*)
      my_real :: geo(npropg,*)
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER 
     .        I, K, NG, ISSN, NPN, NN, N, MID, PID ,
     .        II, J, II2,JJ2,JJ, II3, JJ3, L,NGROU,
     .        MSKMTN,MSKISN,MSKPID, MODE, WORK(70000)
      EXTERNAL my_shiftl,my_shiftr,my_and
      INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
C
      DATA mskmtn /o'07770000000'/
      DATA mskisn /o'00000000700'/
      DATA mskpid /o'07777777777'/
C
      TYPE (SURF_)   , DIMENSION(NSURF)   :: IGRSURF
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
C----------------------------------------------------------
C   TRI GLOBAL SUR TOUS LES CRITERES POUR TOUS LES ELEMENTS
C----------------------------------------------------------
C
      DO i=1,numelx
        eadd(i)=1
        itri(4,i)=i
        index(i)=i
        inum(1,i)=ipartx(i)
        inum(2,i)=kxx(1,i)
        inum(3,i)=kxx(2,i)
        inum(4,i)=kxx(3,i)
        inum(5,i)=kxx(4,i)
        inum(6,i)=kxx(5,i)
      ENDDO
 
      DO i=1,numelx
        xep(i)=cep(i)
      ENDDO
 
      DO i = 1, numelx
        mid= kxx(1,i)
        pid= kxx(2,i)
        mtn= nint(geo(12,pid))
        IF (mtn<28.OR.mtn>31) THEN
          CALL ancmsg(msgid=413,
     .                msgtype=msgerror,
     .                anmode=aninfo_blind_1,
     .                i1=kxx(5,i),
     .                c1='MATERIAL',
     .                i2=ipm(1,mid),
     .                c2='MATERIAL',
     .                i3=mtn)
        ENDIF
 
        issn = 0
        IF(geo(5,pid)/=zero) issn=1
C        
        issn=my_shiftl(issn,6)
        mtn=my_shiftl(mtn,21)
C
        itri(1,i)=mtn+issn
        itri(2,i)=pid
        itri(3,i)=kxx(3,i)
        itri(4,i)=0
      ENDDO
C
      mode=0
      CALL my_orders( mode, work, itri, index, numelx , 4)
C
      DO i=1,numelx
        ipartx(i) =inum(1,index(i))
      ENDDO
      DO i=1,numelx
        cep(i)=xep(index(i))
      ENDDO
      DO  k=1,5
        DO  i=1,numelx
          kxx(k,i)=inum(k+1,index(i))
        ENDDO
      ENDDO
C
C INVERSION DE INDEX (DANS ITR1)
C
      DO i=1,numelx
        itr1(index(i))=i
      ENDDO
 
 
C
C RENUMEROTATION POUR SURFACES
C ow a verifier IBUFSSG - ITYP == 100
       DO i=1,nsurf
         nn=igrsurf(i)%NSEG
         DO j=1,nn 
           IF(igrsurf(i)%ELTYP(j) == 100)
     .        igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
         ENDDO
       ENDDO
C--------------------------------------------------------------
C         DETERMINATION DES SUPER_GROUPES
C--------------------------------------------------------------
      nd=1
      DO i=2,numelx
        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))
        IF(ii/=jj.OR.ii2/=jj2.OR.ii3/=jj3) THEN
          nd=nd+1
          eadd(nd)=i
        ENDIF
      ENDDO
      eadd(nd+1) = numelx+1
C
      RETURN