xgrhead.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/.
!||====================================================================
!||    xgrhead        ../starter/source/elements/xelem/xgrhead.F
!||--- called by ------------------------------------------------------
!||    lectur         ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg         ../starter/source/output/message/message.F
!||--- uses       -----------------------------------------------------
!||    message_mod    ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE xgrhead(
     1       KXX,  GEO,     INUM,    ITR1,
     2       EADD, INDEX,   ITRI,    IPARTX,     
     3       ND,   IGRSURF,
     4       CEP,  XEP,IPM)
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)     ARRAY CONECS+PID+No MULTISTRAND ELEMENTS    E
C     GEO(NPROPG,NUMGEO)ARRAY OF PID CHARACTERISTICS                E
C     INUM(6,NUMELX)    WORKING ARRAY                              E/S
C     ITR1(NSELR)       WORKING ARRAY                              E/S
C     EADD(NUMELX)      ARRAY OF ADDRESSES IN IDAM CHGT DAMIER       S
C     INDEX(NUMELX)     WORKING ARRAY                              E/S
C     ITRI(4,NUMELX)    WORKING ARRAY                              E/S
C     IPARTX(NUMELX)    PART ARRAY                                 E/S
C     CEP(NUMELX)    PROC ARRAY                                    E/S
C     XEP(NUMEX)    PROC ARRAY                                    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, ISSN, NN, MID, PID ,
     .        II, J, II2,JJ2,JJ, II3, JJ3,
     .        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   GLOBAL TRI ON ALL CRITERIA FOR ALL 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 INDEX INVERSION (IN ITR1)
C
      DO i=1,numelx
        itr1(index(i))=i
      ENDDO
 
 
C
C RENAMING FOR 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 OF SUPER_GROUPS
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
      END