c3grhead.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/.
!||====================================================================
!||    c3grhead               ../starter/source/elements/sh3n/coque3n/c3grhead.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl2               ../starter/source/starter/freform.F
!||--- uses       -----------------------------------------------------
!||    drape_mod              ../starter/share/modules1/drape_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    reorder_mod            ../starter/share/modules1/reorder_mod.F
!||    stack_mod              ../starter/share/modules1/stack_mod.F
!||====================================================================
      SUBROUTINE c3grhead(
     1       IXTG    ,PM      ,GEO     ,INUM    ,ISEL    ,
     2       ITR1    ,EADD    ,INDEX   ,ITRI    ,XNUM    ,
     3       IPARTTG ,ND      ,THK     ,IGRSURF ,IGRSH3N ,
     4       CEP     ,XEP     ,IXTG1   ,ICNOD   ,
     5       IGEO    ,IPM     ,IPART   ,SH3TREE ,NOD2ELTG,
     6       ITRIOFF ,SH3TRIM ,TAGPRT_SMS,
     7       IWORKSH , STACK  ,DRAPE   ,RNOISE,
     8       MULTI_FVM, SH3ANG,DRAPEG, PTSH3N ,MAT_PARAM,
     9       DAMP_RANGE_PART)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE message_mod
      USE stack_mod
      USE multi_fvm_mod
      USE reorder_mod
      USE groupdef_mod
      USE drape_mod
      USE matparam_def_mod
      USE names_and_titles_mod , ONLY : nchartitle
      use element_mod , only : nixtg
C-----------------------------------------------
C            A R G U M E N T S
C-----------------------------------------------
C     IXTG(NIXTG,NUMELTG)TABLEAU CONECS+PID+MID+NOS TRIANGLES       E
C     PM(NPROPM,NUMMAT)  ARRAY OF MATERIAL CHARACTERISTICS           E
C     GEO(NPROPG,NUMGEO) ARRAY OF PID CHARACTERISTICS                 E
C     INUM(9,NUMELTG)     TABLEAU DE TRAVAIL                         E/S
C     ISEL(NSELTG)        TABLEAU DES TRI CHOISIES POUR TH          E/S
C     ITR1(NSELTG)        TABLEAU DE TRAVAIL                         E/S
C     EADD(NUMELTG)      TABLEAU DES ADRESSES DANS IDAM CHGT DAMIER   S 
C     INDEX(NUMELTG)      TABLEAU DE TRAVAIL                         E/S
C     ITRI(7,NUMELTG)     TABLEAU DE TRAVAIL                         E/S
C     CEP(NUMELTG)    TABLEAU PROC                               E/S
C     XEP(NUMELTG)    TABLEAU PROC                               E/S
C     NOD2ELTG(3*NUMELTG+3*NUMELTG6)                                 E/S
C     ITRIOFF(NUMELTG)  FLAG ELEM RBY ON/OFF                         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      "com04_c.inc"
#include      "com01_c.inc"
#include      "com_xfem1.inc"
#include      "param_c.inc"
#include      "vect01_c.inc"
#include      "remesh_c.inc"
#include      "sms_c.inc"
#include      "scr17_c.inc"
#include      "drape_c.inc"
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      integer
     .    ixtg(nixtg,*),isel(*),inum(10,*),nd,icnod(*),ixtg1(4,*),
     .    eadd(*), itr1(*), index(*), itri(8,*),iparttg(*),
     .    cep(*), xep(*),itrioff(*),
     .    igeo(npropgi,*),ipm(npropmi,*), ipart(lipart1,*), 
     .    sh3tree(ksh3tree,*), nod2eltg(*), sh3trim(*),
     .    tagprt_sms(*),iworksh(3,*)
      INTEGER , DIMENSION(NUMELTG) , INTENT(INOUT):: PTSH3N
      INTEGER , INTENT(IN) :: DAMP_RANGE_PART(NPART)     !< flag to compute the damping range
      my_real
     .    pm(npropm,*), geo(npropg,*), xnum(*), thk(*), rnoise(nperturb,*),
     .    sh3ang(*)
C-----------------------------------------------
      TYPE (STACK_PLY) :: STACK
      TYPE(MULTI_FVM_STRUCT) :: MULTI_FVM
      TYPE (DRAPE_)  ,TARGET     :: DRAPE(NUMELC_DRAPE + NUMELTG_DRAPE)
      TYPE (DRAPEG_)                             :: DRAPEG,XNUM_DRAPEG
      TYPE (DRAPE_)  , DIMENSION(:), ALLOCATABLE :: XNUM_DRAPE
      TYPE (DRAPE_PLY_)             , POINTER    :: DRAPE_PLY
C-----------------------------------------------
      TYPE (GROUP_)  , DIMENSION(NGRSH3N)  :: IGRSH3N
      TYPE (SURF_)   , DIMENSION(NSURF)    :: IGRSURF
      TYPE(matparam_struct_) ,DIMENSION(NUMMAT), INTENT(IN) :: MAT_PARAM
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISTOR
      INTEGER WORK(70000)
      INTEGER I, K, MLN, ISSN, NPN,NN,ICO,ID,
     .     mid, pid,
     .     j, ithk,
     .    ipla, ii1, jj1, ii2, jj2, ii, jj, 
     .    igtyp, ii3, jj3,neltg3,
     .   mskmln, msknpn, mskisn, mode,icsen,ifail,nfail,
     .   mskist, mskipl, mskith, mskmid,mskpid,mskirp,msktyp,irep,
     .   ii0,jj0,ilev,prt,iadm,mskirb,irb, ii4, jj4,
     .   ixfem,iwarnhb,ipt,imatly,ipid,ish3n,
     .   ii5,jj5,ii6,jj6,isubstack,ippid,
     .   nb_law58,ipmat,ipert,stat,nslice,kk,npt_drp,ie,
     .   ie0
C     REAL OR REAL*8
      CHARACTER(LEN=NCHARTITLE) :: TITR
C
      INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2, INUM_PTSH3N
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: INUM_WORKSH ! 3,NUMELTG
 
      EXTERNAL MY_SHIFTL,MY_SHIFTR,MY_AND
      INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
      my_real, DIMENSION(:,:), ALLOCATABLE :: XNUM_RNOISE
      my_real, DIMENSION(:), ALLOCATABLE :: ANGLE ! NUMELTG
Clef 1--------------------- ------------
      DATA mskmln /o'00777000000'/
      DATA msktyp /o'00000777000'/
      DATA mskisn /o'00000000700'/
      DATA mskist /o'00000000070'/
      DATA mskipl /o'00000000007'/
Clef 2---------------------------------
      DATA mskith /o'10000000000'/
      DATA mskirp /o'07000000000'/
      DATA msknpn /o'00777000000'/
      DATA mskirb /o'00000000007'/
Clef 3---------------------------------
      DATA mskmid /o'07777777777'/
Clef 4---------------------------------
      DATA mskpid /o'07777777777'/
C-----------------------------------------------
C-----------------------------------------------
      ALLOCATE(angle(numeltg))
      ALLOCATE(inum_worksh(3,numeltg))
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7--
       iwarnhb=0
        IF(nadmesh /= 0)THEN
            ALLOCATE( istor(ksh3tree+1,numeltg) )
        ELSE
            ALLOCATE( istor(0,0) )
        ENDIF
        IF (ndrape > 0 .AND. numeltg_drape > 0) THEN
          ALLOCATE(xnum_drape(numeltg))                                                  
          ALLOCATE(xnum_drapeg%INDX(numeltg))
          xnum_drapeg%INDX = 0                                         
          DO i =1, numeltg
            ie = drapeg%INDX(numelc + i)
            IF(ie == 0) cycle   
            npt_drp = drape(ie)%NPLY_DRAPE
            npt     = drape(ie)%NPLY   
            ALLOCATE(xnum_drape(i)%INDX_PLY(npt)) 
            ALLOCATE(xnum_drape(i)%DRAPE_PLY(npt_drp))        
            xnum_drape(i)%INDX_PLY= 0     
            DO j = 1,npt_drp                            
                nslice = drape(ie)%DRAPE_PLY(j)%NSLICE    
                ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE(nslice,2))    
                ALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE(nslice,2))
                xnum_drape(i)%DRAPE_PLY(j)%RDRAPE = 0             
                xnum_drape(i)%DRAPE_PLY(j)%IDRAPE = 0  
            ENDDO    
          ENDDO      
        ELSE
            ALLOCATE( xnum_drape(0) )
        ENDIF
        IF(abs(isigi) == 3 .OR. abs(isigi) == 4 .OR. abs(isigi) == 5) THEN
           ALLOCATE(inum_ptsh3n(numeltg))
           inum_ptsh3n = 0
        ELSE
           ALLOCATE(inum_ptsh3n(0))
        ENDIF 
C
C----------------------------------------------------------
C   GLOBAL SORTING ON ALL CRITERIA FOR ALL ELEMENTS
C----------------------------------------------------------
C
      IF (nperturb > 0) THEN
        ALLOCATE(xnum_rnoise(nperturb,numeltg),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                           msgtype=msgerror,
     .                           c1='XNUM_RNOISE')
      ENDIF
C
      CALL my_alloc(index2,numeltg)
      IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
         DO i=1,numeltg
           index2(i)= permutation%TRIANGLE(i)
           eadd(i)=1
           itri(7,i)=i
           index(i)=i
           inum(1,i)=iparttg(i)
           inum(2,i)=itrioff(i)
           xnum(i)  = thk(i)
           inum(3,i)=ixtg(1,i)
           inum(4,i)=ixtg(2,i)
           inum(5,i)=ixtg(3,i)
           inum(6,i)=ixtg(4,i)
           inum(7,i)=ixtg(5,i)
           inum(8,i)=ixtg(6,i)
           inum(9,i)=icnod(i)
           inum(10,i)=ixtg(1,i)
           inum_worksh(1,i) = iworksh(1,numelc + i)
           inum_worksh(2,i) = iworksh(2,numelc + i)
           inum_worksh(3,i) = iworksh(3,numelc + i)
           IF (nperturb > 0) THEN                                               
             DO ipert = 1, nperturb                                             
               xnum_rnoise(ipert,i) = rnoise(ipert,i)                           
             ENDDO                                                              
           ENDIF                                                                
           angle(i)=sh3ang(i)                                                   
           !drape structure                                                     
           ie = drapeg%INDX(numelc + i)  
           xnum_drapeg%INDX(i) = ie                                             
           IF(ie == 0) cycle                                                    
           npt = drape(ie)%NPLY   
           xnum_drape(i)%NPLY = npt                                       
           xnum_drape(i)%INDX_PLY(1:npt) = drape(ie)%INDX_PLY(1:npt)            
           npt = drape(ie)%NPLY_DRAPE                                           
           xnum_drape(i)%NPLY_DRAPE = npt                                           
           xnum_drape(i)%THICK =  drape(ie)%THICK                                  
           DO jj = 1, npt                                                       
             drape_ply => drape(ie)%DRAPE_PLY(jj)                               
             nslice =  drape_ply%NSLICE                                         
             xnum_drape(i)%DRAPE_PLY(jj)%NSLICE =  nslice                       
             xnum_drape(i)%DRAPE_PLY(jj)%IPID = drape_ply%IPID                 
             DO kk = 1,nslice                                                   
               xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,1)=drape_ply%IDRAPE(kk,1)  
               xnum_drape(i)%DRAPE_PLY(jj)%IDRAPE(kk,2)=drape_ply%IDRAPE(kk,2)  
               xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,1)=drape_ply%RDRAPE(kk,1)  
               xnum_drape(i)%DRAPE_PLY(jj)%RDRAPE(kk,2)=drape_ply%RDRAPE(kk,2)  
             ENDDO  
             DEALLOCATE(drape_ply%IDRAPE, drape_ply%RDRAPE)   
           ENDDO 
             DEALLOCATE(drape(ie)%DRAPE_PLY)  
             DEALLOCATE(drape(ie)%INDX_PLY)  
         ENDDO
      ELSE
         DO i=1,numeltg
           index2(i)= permutation%TRIANGLE(i)
           eadd(i)=1
           itri(7,i)=i
           index(i)=i
           inum(1,i)=iparttg(i)
           inum(2,i)=itrioff(i)
           xnum(i)  = thk(i)
           inum(3,i)=ixtg(1,i)
           inum(4,i)=ixtg(2,i)
           inum(5,i)=ixtg(3,i)
           inum(6,i)=ixtg(4,i)
           inum(7,i)=ixtg(5,i)
           inum(8,i)=ixtg(6,i)
           inum(9,i)=icnod(i)
           inum(10,i)=ixtg(1,i)
           inum_worksh(1,i) = iworksh(1,numelc + i)
           inum_worksh(2,i) = iworksh(2,numelc + i)
           inum_worksh(3,i) = iworksh(3,numelc + i)
           IF (nperturb > 0) THEN
             DO ipert = 1, nperturb
               xnum_rnoise(ipert,i) = rnoise(ipert,i) 
             ENDDO
           ENDIF
           angle(i)=sh3ang(i)
         ENDDO
      ENDIF
      IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
         inum_ptsh3n(1:numeltg) = ptsh3n(1:numeltg)
       ENDIF
C
      IF(nadmesh/=0)THEN
        DO  k=1,ksh3tree
          DO  i=1,numeltg
            istor(k,i)=sh3tree(k,i)
          ENDDO
        ENDDO
        IF(lsh3trim/=0)THEN
          DO  i=1,numeltg
            istor(ksh3tree+1,i)=sh3trim(i)
          ENDDO
        END IF
      END IF
C
      DO i=1,numeltg
        xep(i)=cep(i)
      ENDDO
C
      DO 100 i = 1, numeltg
        ii = i
C
        IF(nadmesh==0)THEN
          itri(1,i)=0
        ELSE
C
C       ILEV must have a strong weight on the first key
          prt = iparttg(ii)
          iadm= ipart(10,prt)
          IF(iadm==0)THEN
C         not the same group as if adaptivity.
            itri(1,i)=0
          ELSE
            ilev=sh3tree(3,i)
            IF(ilev<0)ilev=-ilev-1
            itri(1,i)=ilev+1
          END IF
        END IF
C
        mid= ixtg(1,ii)
        pid= ixtg(5,ii)
        mln = nint(pm(19,mid))
        IF(mln == 51)trimat=4
C
        jthe = nint(pm(71,mid))
        igtyp = igeo(11,pid)
        npn   = igeo(4,pid)
        ish3n  = igeo(18,pid)
        ixfem = 0
           nfail = mat_param(mid)%NFAIL
        ifail = 0
C
        IF (igtyp == 11) THEN
          DO ipt = 1, npn
           imatly  = igeo(100+ipt,pid)
            nfail  = max(nfail, mat_param(imatly)%NFAIL) 
          ENDDO 
          IF(icrack3d > 0)THEN
C -         new multilayer -
            ixfem = mat_param(mid)%IXFEM
          ENDIF
        ELSEIF (igtyp == 17) THEN
          npn = iworksh(1,numelc + ii)
          isubstack =iworksh(3,numelc + ii)
!!          IIGEO   =  40 + 5*(ISUBSTACK - 1) 
!!          IADI    = IGEO(IIGEO + 3,PID)
!!          IPPID   = IADI
          ippid = 2
          DO ipt = 1, npn
            ipid = stack%IGEO(ippid+ipt,isubstack)
            imatly = igeo(101, ipid)
            nfail  = max(nfail, mat_param(imatly)%NFAIL) 
          ENDDO       
        ELSEIF (igtyp == 51  ) THEN
C---
C new shell property (multiple NPT through each layer)
C---
          nb_law58 = 0
          npn = iworksh(1,numelc + ii)
          isubstack =iworksh(3,numelc + ii)
          ippid = 2
          DO ipt = 1, npn
            ipid = stack%IGEO(ippid+ipt,isubstack)
            imatly = igeo(101, ipid)
            nfail  = max(nfail, mat_param(imatly)%NFAIL) 
C --- PID 51 combined with LAW58 ---
            IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
          ENDDO
C --- set IREP for tri criteria:
          IF (nb_law58 == npn) THEN
            irep = 2
          ELSEIF (nb_law58 > 0) THEN
            irep = irep + 3
          ENDIF
        ELSEIF ( igtyp == 52 ) THEN
C---
C new shell property (multiple NPT through each layer)
C---
          nb_law58 = 0
          npn = iworksh(1,numelc + ii)
          isubstack =iworksh(3,numelc + ii)
          ippid = 2
          ipmat = ippid + npn
          DO ipt = 1, npn
            ipid   = stack%IGEO(ippid + ipt,isubstack)
            imatly = stack%IGEO(ipmat + ipt,isubstack)
            nfail  = max(nfail, mat_param(imatly)%NFAIL) 
C --- PID 51 combined with LAW58 ---
            IF (nint(pm(19,imatly)) == 58) nb_law58 = nb_law58 + 1
          ENDDO
C --- set IREP for tri criteria:
          IF (nb_law58 == npn) THEN
            irep = 2
          ELSEIF (nb_law58 > 0) THEN
            irep = irep + 3
          ENDIF        
C
        ELSE ! IGTYP == 1
          IF(icrack3d > 0)THEN
C -         new monolayer -
            ixfem = mat_param(mid)%IXFEM
            IF (ixfem == 1) THEN
              ixfem = 2
              icrack3d = ixfem
            ENDIF
          END IF
        ENDIF
        IF (nfail > 0) ifail = 1
c        
C thermal material expansion
        iexpan  = ipm(218, mid)       
        ico = icnod(ii)
        IF(ish3n>3.AND.ish3n<=29)THEN
          id = igeo(1,pid)
          CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
          CALL ancmsg(msgid=435,
     .                msgtype=msgwarning,
     .                anmode=aninfo_blind_2,
     .                i1=id,
     .                c1=titr,
     .                i2=ish3n,
     .                i3=ixtg(nixtg,ii))
          iwarnhb=iwarnhb+1
          ish3n=2
        ENDIF
        ithk = nint(geo(35,pid))
        ipla = nint(geo(39,pid))
        irep = igeo(6,pid)
        icsen= igeo(3,pid)
        IF (icsen > 0) icsen=1
C
        IF(npn==0.AND.(mln==36.OR.mln==86))THEN
          IF(ipla==0) ipla=1
          IF(ipla==2) ipla=0
        ELSEIF(npn==0.AND.mln==2)THEN
          IF(ipla==2) ipla=0
        ELSE
         IF(ipla==2) ipla=0
         IF(ipla==3) ipla=2
        ENDIF
        IF(ithk==2)THEN
          ithk = 0
        ELSEIF(mln==32)THEN
          ithk = 1
        ENDIF
        ipla = iabs(ipla)
        ithk = iabs(ithk)
        istrain = nint(geo(11,pid))
        IF(mln==19.OR.mln>=25.OR.mln==15)istrain = 1
        issn = iabs(nint(geo(3,pid)))
C sorting on elem deletes rigidbody
C IRB = 0 : elem actif
C IRB = 1 : inactive elem and optimized for SPMD
C IRB = 2: Elem inactive but optimized to be active in SPMD
        irb = itrioff(i)
C
C---     Clef2 
        jsms = 0
        IF(isms/=0)THEN
          IF(idtgrs/=0)THEN
            IF(tagprt_sms(iparttg(ii))/=0)jsms=1
          ELSE
            jsms=1
          END IF
        END IF
C       JSMS=MY_SHIFTL(JSMS,0)
        itri(2,i) = jsms
C       NEXT=MY_SHIFTL(NEXT,1)
C
C---     Clef3 
C
C       IPLA   = MY_SHIFTL(IPLA,0)
        istrain= my_shiftl(istrain,3)
        issn   = my_shiftl(issn,6)
C
        igtyp  = my_shiftl(igtyp,9)
        mln    = my_shiftl(mln,18)    
C     Beware full;
C       ICO must remain the heaviest weight in this key.
        ico   = my_shiftl(ico,29) 
        itri(3,i)=ipla+istrain+issn+igtyp+mln+ico 
C
C---clef4
C
C       IRB    = MY_SHIFTL(IRB,0)
        ifail  = my_shiftl(ifail,4)
        iexpan = my_shiftl(iexpan,5)
        jthe =  my_shiftl(jthe,6)
        ish3n  = my_shiftl(ish3n,11)
        icsen = my_shiftl(icsen,16)
        npn   = my_shiftl(npn,17)
        irep  = my_shiftl(irep,26)
        ithk  = my_shiftl(ithk,30)
        IF(ixfem > 0)ixfem  = my_shiftl(ixfem,9)
C
        itri(4,i)=ithk+irep+npn+icsen+ish3n+jthe+irb+ifail+ixfem
C---     Clef3 
C       MID=MY_SHIFTL(MID,0)
        itri(5,i)=mid
C---     Clef4 
C       PID=MY_SHIFTL(PID,0)
        itri(6,i)=pid
C --- clef7 used for type17 iworkc=0 with/out type17 PID
        itri(7,i) =  iworksh(2,numelc + i)
C --- clef 8---------------------------------          
        itri(8,i )= damp_range_part(iparttg(ii))        
 100  CONTINUE
C
      mode=0
      CALL my_orders( mode, work, itri, index, numeltg , 8)
C
      DO  i=1,numeltg
        iparttg(i)=inum(1,index(i))
        thk(i)   =xnum(index(i))
        itrioff(i)=inum(2,index(i))
        icnod(i) = inum(9,index(i))
      ENDDO
 
      DO i=1,numeltg
        cep(i)=xep(index(i))
        permutation%TRIANGLE(i)=index2(index(i))
      ENDDO
 
      DO  k=1,nixtg
        DO  i=1,numeltg
          ixtg(k,i)=inum(k+2,index(i))
        ENDDO
      ENDDO
C
      IF (numeltg6>0) THEN
        neltg3 = numeltg-numeltg6
        DO i = 1, numeltg6
          ii = i + neltg3
          inum(1,ii)=ixtg1(1,i)
          inum(2,ii)=ixtg1(2,i)
          inum(3,ii)=ixtg1(3,i)
        ENDDO
        DO i = 1, numeltg6
          ii = i + neltg3
          ixtg1(1,i)=inum(1,index(ii))
          ixtg1(2,i)=inum(2,index(ii))
          ixtg1(3,i)=inum(3,index(ii))
        ENDDO
      ENDIF 
C 
      IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
        ie = drapeg%NUMSH4
        DO i=1,numeltg
         iworksh(1,numelc + i)= inum_worksh(1,index(i))
         iworksh(2,numelc + i)= inum_worksh(2,index(i))
         iworksh(3,numelc + i)= inum_worksh(3,index(i))
         IF (nperturb > 0) THEN
           DO ipert = 1, nperturb
             rnoise(ipert,i) = xnum_rnoise(ipert,index(i)) 
           ENDDO
         ENDIF
         sh3ang(i)=angle(index(i))
         !
         ie0 = xnum_drapeg%INDX(index(i))
         drapeg%INDX(numelc + i) = 0
         IF(ie0 == 0) cycle
         ie = ie + 1
         npt = xnum_drape(index(i))%NPLY ! number of layer shell
         drape(ie)%NPLY = npt
         drapeg%INDX(numelc + i)= ie
         ALLOCATE(drape(ie)%INDX_PLY(npt))   
         drape(ie)%INDX_PLY(1:npt) =  xnum_drape(index(i))%INDX_PLY(1:npt)                                  
         npt = xnum_drape(index(i))%NPLY_DRAPE
         ALLOCATE(drape(ie)%DRAPE_PLY(npt))                                      
         drape(ie)%NPLY_DRAPE= npt                
         drape(ie)%THICK =  xnum_drape(index(i))%THICK               
         DO jj = 1, npt         
           drape_ply => drape(ie)%DRAPE_PLY(jj)                                  
           nslice = xnum_drape(index(i))%DRAPE_PLY(jj)%NSLICE                            
           drape_ply%NSLICE = nslice   
           drape_ply%IPID =  xnum_drape(index(i))%DRAPE_PLY(jj)%IPID
           ALLOCATE(drape_ply%IDRAPE(nslice,2), drape_ply%RDRAPE(nslice,2))
           drape_ply%IDRAPE = 0
           drape_ply%RDRAPE = zero 
           DO kk = 1,nslice                                                               
            drape_ply%IDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,1)      
            drape_ply%IDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%IDRAPE(kk,2)      
            drape_ply%RDRAPE(kk,1) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,1)      
            drape_ply%RDRAPE(kk,2) = xnum_drape(index(i))%DRAPE_PLY(jj)%RDRAPE(kk,2)      
           ENDDO                                                                          
         ENDDO 
        ENDDO
      ELSE
        DO i=1,numeltg
         iworksh(1,numelc + i)= inum_worksh(1,index(i))
         iworksh(2,numelc + i)= inum_worksh(2,index(i))
         iworksh(3,numelc + i)= inum_worksh(3,index(i))
         IF (nperturb > 0) THEN
           DO ipert = 1, nperturb
             rnoise(ipert,i) = xnum_rnoise(ipert,index(i)) 
           ENDDO
         ENDIF
          sh3ang(i)=angle(index(i))
        ENDDO 
      ENDIF
      !
      IF(abs(isigi)==3.OR.abs(isigi)== 4.OR.abs(isigi)==5)THEN
         DO i=1,numeltg
          ptsh3n(i) = inum_ptsh3n(index(i))
         ENDDO  
       ENDIF
      IF(nadmesh/=0)THEN
        DO  k=1,ksh3tree
          DO  i=1,numeltg
            sh3tree(k,i)=istor(k,index(i))
          ENDDO
        ENDDO
        IF(lsh3trim/=0)THEN
          DO  i=1,numeltg
            sh3trim(i)=istor(ksh3tree+1,index(i))
          ENDDO
        END IF
      END IF
C     
C INDEX INVERSION (IN ITR1)
C
      DO i=1,numeltg
        itr1(index(i))=i
      ENDDO
C RENAMING OF THE TREE
      IF(nadmesh/=0)THEN
        DO  i=1,numeltg
          IF(sh3tree(1,i)/=0)
     .       sh3tree(1,i)=itr1(sh3tree(1,i))
          IF(sh3tree(2,i)/=0)
     .       sh3tree(2,i)=itr1(sh3tree(2,i))
        ENDDO
      END IF
C
C RENAMING FOR SURFACES
C
      DO i=1,nsurf
        nn=igrsurf(i)%NSEG
        DO j=1,nn
          IF(igrsurf(i)%ELTYP(j) == 7)
     .       igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
        ENDDO
      ENDDO
C
C RENAMING FOR SHELL3N GROUPS
C
      DO i=1,ngrsh3n
        nn=igrsh3n(i)%NENTITY
        DO j=1,nn
          igrsh3n(i)%ENTITY(j) = itr1(igrsh3n(i)%ENTITY(j))
        ENDDO
      ENDDO
C
C renumerotation CONNECTIVITE INVERSE
C
      DO i=1,3*numeltg+3*numeltg6
        IF(nod2eltg(i) /= 0)nod2eltg(i)=itr1(nod2eltg(i))
      END DO
C--------------------------------------------------------------
C         DETERMINATION OF SUPER_GROUPS
C--------------------------------------------------------------
      nd=1
      DO i=2,numeltg
        ii0=itri(1,index(i))
        jj0=itri(1,index(i-1))
        ii =itri(2,index(i))
        jj =itri(2,index(i-1))
        ii1=itri(3,index(i))
        jj1=itri(3,index(i-1))
        ii2=itri(4,index(i))
        jj2=itri(4,index(i-1))
        ii3=itri(5,index(i))
        jj3=itri(5,index(i-1))
        ii4=itri(6,index(i))
        jj4=itri(6,index(i-1))
C for stack/ply pid
        ii5=itri(7,index(i))
        jj5=itri(7,index(i-1))
C damp freq range        
        ii6=itri(8,index(i))
        jj6=itri(8,index(i-1))            
        IF (ii0/=jj0.OR.
     .      ii/=jj.OR.
     .      ii1/=jj1.OR.
     .      ii2/=jj2.OR.
     .      ii3/=jj3.OR.
     .      ii4/=jj4.OR.
     .      ii5/=jj5.OR.
     .      ii6/=jj6) THEN
               nd=nd+1
               eadd(nd)=i
        ENDIF
      ENDDO
      eadd(nd+1) = numeltg+1
      DO i=1,numeltg
      IF(iwarnhb/=0)THEN
         pid = ixtg(nixtg-1,i)
         id=igeo(1,pid)
         CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
         CALL ancmsg(msgid=436,
     .               msgtype=msgwarning,
     .               anmode=aninfo,
     .               i1=id,
     .               c1=titr)
         iwarn=iwarn-1
      ENDIF
      ENDDO
c
      IF (nperturb > 0) THEN
        IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise) 
      ENDIF
C
      DEALLOCATE(index2)
      DEALLOCATE( istor )
      IF(ndrape > 0 .AND. numeltg_drape > 0) THEN
        DO i =1, numeltg       
           ie = xnum_drapeg%INDX(i)
           IF(ie == 0) cycle                                
           npt_drp = xnum_drape(i)%NPLY_DRAPE  
           DO j = 1,npt_drp                                              
              DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%RDRAPE)          
              DEALLOCATE(xnum_drape(i)%DRAPE_PLY(j)%IDRAPE)  
           ENDDO   
           DEALLOCATE(xnum_drape(i)%DRAPE_PLY,xnum_drape(i)%INDX_PLY) 
         ENDDO
         DEALLOCATE( xnum_drape ,xnum_drapeg%INDX)
      ELSE
         DEALLOCATE( xnum_drape )      
      ENDIF
      IF(ALLOCATED(inum_ptsh3n))DEALLOCATE(inum_ptsh3n)
 
 
      DEALLOCATE(inum_worksh, angle)
      RETURN
      END