tgrhead.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    tgrhead        ../starter/source/elements/truss/tgrhead.F
!||--- called by ------------------------------------------------------
!||    lectur         ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||--- uses       -----------------------------------------------------
!||====================================================================
      SUBROUTINE tgrhead(
     1       IXT ,   PM  , GEO  ,   INUM    ,  ISEL,
     2       ITR1,   EADD, INDEX,   ITRI    ,      
     3       IPARTT, ND,   IGRSURF, IGRTRUSS,
     4       CEP,    XEP,  ITRUOFF ,
     5       TAGPRT_SMS,ITAGPRLD_TRUSS)
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     IXT(5,NUMELT)     TABLEAU CONECS+MID+PID+NOS TRUSSES         E
C     GEO(NPROPG,NUMGEO)TABLEAU DES CARACS DES PID                 E
C     INUM(6,NUMELT)    TABLEAU DE TRAVAIL                         E/S
C     ISEL(NSELT)       TABLEAU DESPOUTRES CHOISIS POUR TH         E/S
C     ITR1(NSELT)       TABLEAU DE TRAVAIL                         E/S
C     EADD(NUMELT)      TABLEAU DES ADRESSES DANS IDAM CHGT DAMIER   S
C     INDEX(NUMELT)     TABLEAU DE TRAVAIL                         E/S
C     ITRI(5,NUMELT)    TABLEAU DE TRAVAIL                         E/S
C     IPARTT(NUMELT)    TABLEAU PART                               E/S
C     CEP(NUMELT)    TABLEAU PROC                               E/S
C     XEP(NUMELT)    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 IXT(5,*),ISEL(*),INUM(7,*),IPARTT(*),
     .        EADD(*),ITR1(*),INDEX(*),ITRI(5,*),
     .        ND, CEP(*), XEP(*),
     .        ITRUOFF(*), TAGPRT_SMS(*)
      INTEGER ,INTENT(INOUT), DIMENSION(NUMELT) ::ITAGPRLD_TRUSS
      my_real :: pm(npropm,*), geo(npropg,*)
C-----------------------------------------------
      TYPE (GROUP_)  , DIMENSION(NGRTRUS)  :: IGRTRUSS
      TYPE (SURF_)   , DIMENSION(NSURF)    :: IGRSURF
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER :: I,J,K,L,NG, ISSN, NN,N,MLN,MID,PID ,NGROU
      INTEGER :: II,JJ,II2,JJ2,II3,JJ3,II4,JJ4,II5,JJ5
      INTEGER :: MSKMLN,MSKISN,MSKPID, MSKMID, MODE
      INTEGER :: WORK(70000),IPRLD
      EXTERNAL MY_SHIFTL,MY_SHIFTR,MY_AND
      INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
 
      DATA mskmln /o'07770000000'/
      DATA mskisn /o'00000000700'/
      DATA mskmid /o'07777777777'/
      DATA mskpid /o'07777777777'/
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,numelt
        eadd(i)=1
        index(i)=i
        inum(1,i)=ipartt(i)
        inum(2,i)=itruoff(i)
        inum(3,i)=ixt(1,i)
        inum(4,i)=ixt(2,i)
        inum(5,i)=ixt(3,i)
        inum(6,i)=ixt(4,i)
        inum(7,i)=ixt(5,i)
      ENDDO
 
      DO i=1,numelt
        xep(i)=cep(i)
      ENDDO
C
C
      DO i = 1, numelt
        ii = i
        mid= ixt(1,ii)
        mln= pm(19,mid)
        pid= ixt(4,ii)
        issn = 0
        IF(geo(5,pid)/=0.) issn=1
        iprld = itagprld_truss(ii)
        IF (iprld>0) mln = mln+iprld
C
        issn=my_shiftl(issn,6)
        mln=my_shiftl(mln,21)
C
        itri(1,i)=mln+issn
        itri(2,i)=itruoff(i)
C
        jsms = 0
        IF(isms/=0)THEN
          IF(idtgrs/=0)THEN
            IF(tagprt_sms(ipartt(ii))/=0)jsms=1
          ELSE
            jsms=1
          END IF
        END IF
C       JSMS=MY_SHIFTL(JSMS,0)
        itri(3,i) = jsms
C       NEXT=MY_SHIFTL(NEXT,1)
c
C       key4
        itri(4,i) = mid
C       key5
        itri(5,i) = pid
 
      ENDDO
C
      mode=0
      CALL my_orders( mode, work, itri, index, numelt , 4)
C
      DO i=1,numelt
        ipartt(i) =inum(1,index(i))
        itruoff(i) =inum(2,index(i))
      ENDDO
      DO  k=1,5
        DO  i=1,numelt
          ixt(k,i)=inum(k+2,index(i))
        ENDDO
      ENDDO
 
      DO i=1,numelt
        cep(i)=xep(index(i))
      ENDDO
C
C INVERSION DE INDEX (DANS ITR1)
C
      DO i=1,numelt
        itr1(index(i))=i
      ENDDO
C
C RENUMEROTATION POUR TH
C
C
C RENUMEROTATION POUR SURFACES
C
      DO i=1,nsurf
        nn=igrsurf(i)%NSEG
        DO j=1,nn
          IF(igrsurf(i)%ELTYP(j) == 4)
     .       igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
        ENDDO
      ENDDO
C
C RENUMEROTATION POUR GROUPES DE TRUSSES
C
      DO i=1,ngrtrus
        nn=igrtruss(i)%NENTITY
        DO j=1,nn
          igrtruss(i)%ENTITY(j) = itr1(igrtruss(i)%ENTITY(j))
        ENDDO
      ENDDO
C REORDERING FOR ITAGPRLD_TRUSS
      inum(2,1:numelt)=itagprld_truss(1:numelt)
      DO i=1,numelt
        itagprld_truss(i) =inum(2,index(i))
      ENDDO
C
C--------------------------------------------------------------
C         DETERMINATION DES SUPER_GROUPES
C--------------------------------------------------------------
      nd=1
      DO i=2,numelt
        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) = numelt+1
c-----------
      RETURN
      END