sgrhead.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/.
!||====================================================================
!||    sgrhead                ../starter/source/elements/solid/solide/sgrhead.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||--- uses       -----------------------------------------------------
!||    cluster_mod            ../starter/share/modules1/cluster_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    r2r_mod                ../starter/share/modules1/r2r_mod.F
!||    reorder_mod            ../starter/share/modules1/reorder_mod.F
!||====================================================================
      SUBROUTINE sgrhead(
     1       IXS        ,PM            ,GEO       ,INUM    ,ISEL   ,
     2       ITR1       ,EADD          ,INDEX     ,ITRI    ,IPARTS ,      
     3       ND         ,IGRSURF       ,IGRBRIC   ,ISOLNOD ,
     4       CEP        ,XEP           ,IXS10     ,IXS20   ,IXS16  ,
     5       IGEO       ,IPM           ,NOD2ELS   ,ISOLOFF ,
     6       TAGPRT_SMS ,SPH2SOL       ,SOL2SPH   ,MAT_PARAM,
     7       SOL2SPH_TYP,IFLAG_BPRELOAD,CLUSTERS  ,RNOISE  ,
     8       DAMP_RANGE_PART,TRIMAT)
C-----------------------------------------------
C            A R G U M E N T S
C-----------------------------------------------
C     IXS(11,NUMELS)       ARRAY: CONECS+PID+MID+NOS SOLIDS          E
C     PM(NPROPM,NUMMAT)    ARRAY: MATERIAL PARAMETERS (real)         E
C     IPM(NPROPMI,NUMMAT)  ARRAY: MATERIAL PARAMETERS (integer)      E
C     GEO(NPROPG,NUMGEO)   ARRAY: PROPERTY PARAMETERS (real)         E
C     IGEO(NPROPGI,NUMGEO) ARRAY: PROPERTY PARAMETERS (integer)      E
C     INUM(13,NUMELS)      ARRAY: WORKING                            E/S
C     ISEL(NSELS)          ARRAY: SELECTED SOLIDS FOR TH            E/S
C     ITR1(NSELS)          ARRAY: WORKING                            E/S
C     EADD(NUMELS)         ARRAY: IDAM INDEXES / checkboard            S
C     INDEX(NUMELS)        ARRAY: WORKING                            E/S
C     ITRI(8,NUMELS)       ARRAY: WORKING                            E/S
C     IPARTS(NUMELS)       ARRAY: PART                               E/S
C     CEP(NUMELS)          ARRAY: WORKING                            E/S
C     XEP(NUMELS)          ARRAY: WORKING                            E/S
C     NOD2ELS(8*NUMELS+6*NUMELS10+12*NUMELS20+16*NUMELS16)           E/S
C     ISOLOFF(NUMELS)      FLAG ELEM RBY ON/OFF                      E/S
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE message_mod
      USE r2r_mod
      USE reorder_mod
      USE groupdef_mod
      USE cluster_mod
      USE matparam_def_mod
      USE names_and_titles_mod , ONLY : nchartitle
      use element_mod , only : nixs
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"
#include      "r2r_c.inc"
#include      "sphcom.inc"
#include      "boltpr_c.inc"
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER IXS(NIXS,NUMELS),ISEL(*),INUM(16,*),IPARTS(*),
     .        EADD(*),ITR1(*),INDEX(*),ITRI(8,*),
     .        ND, ISOLNOD(*), CEP(*),
     .        XEP(*),IXS10(6,*),IXS20(12,*),IXS16(8,*),
     .        NOD2ELS(*), ISOLOFF(*),
     .        TAGPRT_SMS(*), SPH2SOL(*), 
     .        SOL2SPH(2,*),SOL2SPH_TYP(*),IFLAG_BPRELOAD(*)
      INTEGER,INTENT(IN) :: IPM(NPROPMI,NUMMAT)
      INTEGER,INTENT(INOUT) :: IGEO(NPROPGI,NUMGEO)
      INTEGER, INTENT(IN)   :: DAMP_RANGE_PART(NPART)   ! < flag to compute the damping range
      my_real,INTENT(IN) :: PM(NPROPM,NUMMAT), GEO(NPROPG,NUMGEO)
      my_real,INTENT(INOUT) ::  RNOISE(NPERTURB,NUMELS)
C-----------------------------------------------
      TYPE (GROUP_)  , DIMENSION(NGRBRIC) :: IGRBRIC
      TYPE (SURF_)   , DIMENSION(NSURF)   :: IGRSURF
      TYPE (CLUSTER_) ,DIMENSION(NCLUSTER) :: CLUSTERS
      TYPE(matparam_struct_) , TARGET, DIMENSION(NUMMAT),INTENT(IN) :: MAT_PARAM
      INTEGER,INTENT(INOUT) :: TRIMAT
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER 
     .        i,j,k,l,il,mln, ng, issn, npn, nn, n, mid, pid ,irep,
     .        ii,ii0,jj0,ii1,jj1,ii2,jj2,jj,ii3,jj3,ii4,jj4,ii5,jj5,
     .        ii6,jj6,jhbe,iso,igt,iint,mode,ieos,ivisc,ivisc0,tshell, 
     .        iplast, ialel,mt,nfail,nfail0,itet4,icpre,icstr,irb ,
     .        nlay,nptr,npts,nptt,imat,inum_r2r(1+r2r_siu*numels),
     .        nsphdir,ipartsph,nuvar,isvis,iboltp,itet10,nloc_fail,
     .        ipert,stat
      INTEGER WORK(70000)
      EXTERNAL MY_SHIFTL,MY_SHIFTR,MY_AND
      INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
      INTEGER ID, JALE_FROM_MAT, JALE_FROM_PROP
      CHARACTER(LEN=NCHARTITLE) :: TITR
      INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX2
      INTEGER :: CLUSTER_TYP,CLUSTER_NEL
      INTEGER, DIMENSION(:), ALLOCATABLE :: SAVE_CLUSTER
      my_real, DIMENSION(:,:), ALLOCATABLE :: xnum_rnoise
C-----------------------------------------------
C   S O U R C E   L I N E S
C-----------------------------------------------
 
C   GLOBAL SORTING ON ALL CRITERIA FOR ALL ELEMENTS
  
      CALL my_alloc(index2,numels) 
C
      IF (nperturb > 0) THEN
        ALLOCATE(xnum_rnoise(nperturb,numels),stat=stat)
        IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
     .                           msgtype=msgerror,
     .                           c1='XNUM_RNOISE')
      ENDIF
C
      DO i=1,numels
        index2(i)=permutation%SOLID(i)
        eadd(i)=1
        itri(5,i)=i
        index(i)=i
        inum(1,i)=iparts(i)
        inum(2,i)=ixs(1,i)
        inum(3,i)=ixs(2,i)
        inum(4,i)=ixs(3,i)
        inum(5,i)=ixs(4,i)
        inum(6,i)=ixs(5,i)
        inum(7,i)=ixs(6,i)
        inum(8,i)=ixs(7,i)
        inum(9,i)=ixs(8,i)
        inum(10,i)=ixs(9,i)
        inum(11,i)=ixs(10,i)
        inum(12,i)=ixs(11,i)
        inum(13,i)=isolnod(i)
        IF (nsubdom>0) inum_r2r(i) = tag_elsf(i)
        IF (nperturb > 0) THEN
          DO ipert = 1, nperturb
            xnum_rnoise(ipert,i) = rnoise(ipert,i) 
          ENDDO
        ENDIF
      ENDDO
      IF(nsphsol /= 0)THEN
        DO i=1,numels8
          inum(14,i)=sol2sph(1,i)
          inum(15,i)=sol2sph(2,i)
          inum(16,i)=sol2sph_typ(i)
        ENDDO
      END IF
C
      DO i=1,numels
        xep(i)=cep(i)
      ENDDO
C
      DO i = 1, numels
        ii = i
        npn = 1
        jhbe= 1
        jpor=0
        mid = ixs(1,ii)
        mln = nint(pm(19,abs(mid)))
        IF(mln == 51)trimat=4
        IF (mid < 0) THEN
          IF (mln==6.AND.jpor/=2) mln=17
          IF (mln==46) mln=47
          mid = iabs(mid)
        ENDIF
        IF (mln == 36 .or. mln == 47) THEN
          nuvar = ipm(8,mid)
        ELSE
          nuvar = 0   ! no matter what
        ENDIF
        pid= ixs(10,ii)
        iso= isolnod(ii)
        iplast= 1
        icpre = 0
        icstr = 0
        irep = 0
        istrain = 0        
        nfail0    = mat_param(mid)%NFAIL
        nloc_fail = mat_param(mid)%NLOC
        ieos = 0
        ivisc0 = 0
        nlay  = 1
        tshell = 0
        isvis = 0
        IF (pid/=0) THEN
          npn  = igeo(4,pid)
          issn = iabs(igeo(5,pid))
          irep = igeo(6,pid)
          jhbe = igeo(10,pid)
          igt  = igeo(11,pid)
          istrain = igeo(12,pid)
          icpre  = iabs(igeo(13,pid))     
          icstr  = igeo(14,pid)    
          iint = igeo(15,pid)
          jcvt = iabs(igeo(16,pid))
          itet4  = igeo(20,pid)
          itet10 = igeo(50,pid)
          IF (igt == 22) THEN                   
            nlay = igeo(30,pid)                 
            DO il=1,nlay                        
              imat = igeo(100+il,pid)           
              nfail0 = max(nfail0,mat_param(imat)%NFAIL)
              IF (mat_param(imat)%IVISC > 0) ivisc0 = 1
            ENDDO
          ELSEIF (mat_param(mid)%IVISC > 0) THEN
            ivisc0 = 1
          ENDIF
C IVISCO0 cannot put in the PID because is for MID (it can be used in IGEO)
          igeo(34,pid) = ivisc0
c----------            
          IF (igt /= 15) iplast = igeo(9,pid)
          IF (igt==15) jpor=2*nint(geo(28,pid))
          jclos=0
          IF (geo(130,pid)>0.) jclos=1
C--------------Navier Storks Vis          
          IF (geo(16,pid)/=zero.OR.geo(17,pid)/=zero) isvis=1
        ENDIF
        IF((jhbe == 14 .OR. jhbe == 222).AND.iso==8) numels8a=numels8a+1
        IF (jhbe == 12)  jhbe = 4
        IF (jhbe==2)   jhbe = 0
c        
        jale_from_mat = nint(pm(72,mid))
        jale_from_prop = igeo(62,pid)
        jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
        jlag=0
        IF(jale == 0 .AND. mln /= 18)jlag=1
        jeul=0
        IF(jale==2)THEN
          jale=0
          jeul=1
        ELSEIF(jale == 3) THEN
          jlag = 1
          jale = 1
        ENDIF
        IF(mln/=50)jtur=nint(pm(70,mid))
        jthe=nint(pm(71,mid))
        IF (jlag==0 .AND. pid/=0) issn=4
C sorting on elem delete for rigidbody
C IRB = 0 : active elem
C IRB = 1 : inactive elem and optimized for SPMD
C IRB = 2 : inactive elem but optimized to be active in SPMD
        irb = isoloff(i)
C
        jsms=0
        IF(isms/=0)THEN
          IF(idtgrs/=0)THEN
            IF(tagprt_sms(iparts(ii))/=0)jsms=1
          ELSE
            jsms=1
          END IF
        END IF
        ieos  = ipm(4,mid)
C
        nsphdir =igeo(37,pid)
        ipartsph=igeo(38,pid)
        igeo(35,pid) = isvis
C Bolt preloading flag
        iboltp = 0
        IF(npreload > 0)THEN
          iboltp = iflag_bpreload(ii)
        ENDIF
        
C
C    1---------------------------------
C
C     classify shell16 after brick20
        IF(iso==16)iso=21
C       IGT =MY_SHIFTL(IGT,0)
        jsms=my_shiftl(jsms,26)
        iso =my_shiftl(iso,27)
C       CAUTION ISO must remain in the strongest weight
        itri(1,i)=iso+jsms+igt
C    2---------------------------------
C       IPARTSPH=MY_SHIFTL(IPARTSPH,0)
        itri(2,i)=ipartsph ! must remain alone for this key (part index)
C    3---------------------------------
C       JTHE=MY_SHIFTL(JTHE,0)
        jtur=my_shiftl(jtur,1)
        jeul=my_shiftl(jeul,2)
        jlag=my_shiftl(jlag,3)
        jale=my_shiftl(jale,4)
        issn=my_shiftl(issn,5)
        jhbe=my_shiftl(jhbe,9)
        jpor=my_shiftl(jpor,13)
        irb=my_shiftl(irb,18)
        mln =my_shiftl(mln,22)
        itri(3,i)=mln+jhbe+issn+jale+jlag+jeul+jtur+jthe+jpor+irb
C
C    4---------------------------------
        npn   =my_shiftl(npn,3)
        iplast=my_shiftl(iplast,13)
        icpre =my_shiftl(icpre,16)
        icstr =icstr/100+2*mod(icstr/10,10)+4*mod(icstr,10)
        icstr =my_shiftl(icstr,18)
        irep=my_shiftl(irep,20)
        jcvt=my_shiftl(jcvt,22)
        iint=my_shiftl(iint,24)
        istrain=my_shiftl(istrain,26)
        itet4=my_shiftl(itet4,27)
        nfail  =  my_shiftl(nfail0,29) 
        itri(4,i)=jclos+npn+iplast+icpre+icstr+irep+iint+jcvt+istrain
     .           +itet4+nfail
C    5---------------------------------
        itri(5,i)=mid
C    6---------------------------------
        itri(6,i)=pid
C    7---------------------------------
        ieos      = my_shiftl(ieos,0) 
        ivisc     = my_shiftl(ivisc0,4)
        nuvar     = my_shiftl(nuvar,5) 
        isvis     = my_shiftl(isvis,15) 
        iboltp    = my_shiftl(iboltp,16)
        itet10    = my_shiftl(itet10,17)
        nloc_fail = my_shiftl(nloc_fail,19)
C       next  = MY_SHIFTL(next,21)
        itri(7,i)=ieos+ivisc+nuvar+isvis+iboltp+itet10+nloc_fail
C    8---------------------------------        
        itri(8,i )= damp_range_part(iparts(ii))        
      ENDDO
C
      mode=0
      CALL my_orders( mode, work, itri, index, numels , 8)
C
      DO i=1,numels
        iparts(i) =inum(1,index(i))
        isolnod(i)=inum(13,index(i))
        IF (nsubdom>0) tag_elsf(i)=inum_r2r(index(i))
        IF (nperturb > 0) THEN
          DO ipert = 1, nperturb
            rnoise(ipert,i) = xnum_rnoise(ipert,index(i)) 
          ENDDO
        ENDIF
      ENDDO
 
      DO i=1,numels
        cep(i)=xep(index(i))
        permutation%SOLID(i)=index2(index(i))
      ENDDO
      
      DO  k=1,11
        DO  i=1,numels
          ixs(k,i)=inum(k+1,index(i))
        ENDDO
      ENDDO
C
C ISOLOFF
C
      DO i = 1, numels
        inum(3,i) = isoloff(i)
      END DO
C
      DO i = 1, numels
        isoloff(i) = inum(3,index(i))
      END DO
C
C BOLT_PRELOAD
C
      IF (npreload > 0) THEN
       DO i = 1, numels
         inum(4,i) = iflag_bpreload(i)
       END DO
C
       DO i = 1, numels
         iflag_bpreload(i) = inum(4,index(i))
       END DO
      ENDIF
 
C
      IF (numels10+numels20+numels16 > 0) THEN
        DO i = 1, numels10
          ii = i + numels8
          inum(1,ii)=ixs10(1,i)
          inum(2,ii)=ixs10(2,i)
          inum(3,ii)=ixs10(3,i)
          inum(4,ii)=ixs10(4,i)
          inum(5,ii)=ixs10(5,i)
          inum(6,ii)=ixs10(6,i)
        ENDDO
C
        DO i = 1, numels10
          ii = i + numels8
          ixs10(1,i)=inum(1,index(ii))
          ixs10(2,i)=inum(2,index(ii))
          ixs10(3,i)=inum(3,index(ii))
          ixs10(4,i)=inum(4,index(ii))
          ixs10(5,i)=inum(5,index(ii))
          ixs10(6,i)=inum(6,index(ii))
        ENDDO
C
        DO i = 1, numels20
          ii = i + numels8 + numels10
          inum(1,ii) =ixs20(1,i)
          inum(2,ii) =ixs20(2,i)
          inum(3,ii) =ixs20(3,i)
          inum(4,ii) =ixs20(4,i)
          inum(5,ii) =ixs20(5,i)
          inum(6,ii) =ixs20(6,i)
          inum(7,ii) =ixs20(7,i)
          inum(8,ii) =ixs20(8,i)
          inum(9,ii) =ixs20(9,i)
          inum(10,ii)=ixs20(10,i)
          inum(11,ii)=ixs20(11,i)
          inum(12,ii)=ixs20(12,i)
        ENDDO
C
        DO i = 1, numels20
          ii = i + numels8 + numels10
          ixs20(1,i)=inum(1,index(ii))
          ixs20(2,i)=inum(2,index(ii))
          ixs20(3,i)=inum(3,index(ii))
          ixs20(4,i)=inum(4,index(ii))
          ixs20(5,i)=inum(5,index(ii))
          ixs20(6,i)=inum(6,index(ii))
          ixs20(7,i)=inum(7,index(ii))
          ixs20(8,i)=inum(8,index(ii))
          ixs20(9,i)=inum(9,index(ii))
          ixs20(10,i)=inum(10,index(ii))
          ixs20(11,i)=inum(11,index(ii))
          ixs20(12,i)=inum(12,index(ii))
        ENDDO
C
        DO i = 1, numels16
          ii = i + numels8 + numels10 + numels20
          inum(1,ii) =ixs16(1,i)
          inum(2,ii) =ixs16(2,i)
          inum(3,ii) =ixs16(3,i)
          inum(4,ii) =ixs16(4,i)
          inum(5,ii) =ixs16(5,i)
          inum(6,ii) =ixs16(6,i)
          inum(7,ii) =ixs16(7,i)
          inum(8,ii) =ixs16(8,i)
        ENDDO
C
        DO i = 1, numels16
          ii = i + numels8 + numels10 + numels20
          ixs16(1,i)=inum(1,index(ii))
          ixs16(2,i)=inum(2,index(ii))
          ixs16(3,i)=inum(3,index(ii))
          ixs16(4,i)=inum(4,index(ii))
          ixs16(5,i)=inum(5,index(ii))
          ixs16(6,i)=inum(6,index(ii))
          ixs16(7,i)=inum(7,index(ii))
          ixs16(8,i)=inum(8,index(ii))
        ENDDO
C      
      ENDIF
C
C INDEX INVERSION (IN ITR1)
C
      DO i=1,numels
        itr1(index(i))=i
      ENDDO
C
C RENUMBERING FOR SURFACES
C
      DO i=1,nsurf
        nn=igrsurf(i)%NSEG
        DO j=1,nn
          IF (igrsurf(i)%ELTYP(j) == 1)
     .        igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
        ENDDO
      ENDDO
C
C RENUMBERING FOR SOLID GROUPS
C
      DO i=1,ngrbric
        nn=igrbric(i)%NENTITY
        DO j=1,nn
          igrbric(i)%ENTITY(j) = itr1(igrbric(i)%ENTITY(j))
        ENDDO
      ENDDO
C
C RENUMBERING FOR SPH CONVERSION
C
      IF(nsphsol /= 0)THEN
        DO i=1,numsph
          IF(sph2sol(i) /= 0)sph2sol(i)=itr1(sph2sol(i))
        ENDDO
C
C rebuild SOL2SPH
        DO i=1,numels8
          sol2sph(1,i)=inum(14,index(i))
          sol2sph(2,i)=inum(15,index(i))
          sol2sph_typ(i)=inum(16,index(i))
        END DO
      END IF
C
C renumbering INVERSE CONNECTIVITY
C
      DO i=1,8*numels+6*numels10+12*numels20+8*numels16
        IF(nod2els(i) /= 0)nod2els(i)=itr1(nod2els(i))
      END DO
 
!   -----------------------
!   reordering for cluster typ=1 (solid cluster)
      DO i=1,ncluster
        cluster_typ = clusters(i)%TYPE
        IF(cluster_typ==1) THEN
            cluster_nel = clusters(i)%NEL
            ALLOCATE( save_cluster( cluster_nel ) )
            save_cluster( 1:cluster_nel ) = clusters(i)%ELEM( 1:cluster_nel )
            DO j=1,cluster_nel
                clusters(i)%ELEM(j) = itr1( save_cluster( j ) )
            ENDDO
            DEALLOCATE( save_cluster )
        ENDIF
      ENDDO
!   -----------------------
C
C--------------------------------------------------------------
C         SUPER_GROUPS DETERMINATION
C--------------------------------------------------------------
      nd=1
      DO i=2,numels
        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))
        ii5=itri(7,index(i))
        jj5=itri(7,index(i-1))
        ii6=itri(8,index(i))
        jj6=itri(8,index(i-1))
        IF(ii0/=jj0.OR.ii/=jj.OR.ii1/=jj1.OR.ii2/=jj2.OR.
     .     ii5/=jj5.OR.ii3/=jj3.OR.ii4/=jj4.OR.
     .     ii6/=jj6) THEN
          nd=nd+1
          eadd(nd)=i
        ENDIF
      ENDDO
      eadd(nd+1) = numels+1
      DEALLOCATE(index2)
c
      IF (nperturb > 0) THEN
        IF (ALLOCATED(xnum_rnoise)) DEALLOCATE(xnum_rnoise) 
      ENDIF
C-----------
      RETURN
      END