spgrhead.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/.
!||====================================================================
!||    spgrhead           ../starter/source/elements/sph/spgrhead.F
!||--- called by ------------------------------------------------------
!||    lectur             ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    get_u_geo          ../starter/source/user_interface/uaccess.F
!||--- uses       -----------------------------------------------------
!||    message_mod        ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE spgrhead(KXSP    ,IXSP    ,IPARG     ,PM  ,IPART,
     2                    IPARTSP ,EADD    ,CEPSP     ,ND  ,IPM  ,
     3                    IGEO    ,SPBUF   ,SPH2SOL   ,
     4                    SOL2SPH ,IRST    ,MAT_PARAM ,IXSPS)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE message_mod
      USE matparam_def_mod
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      "sphcom.inc"
#include      "param_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, DIMENSION(KVOISPH,NUMSPH),INTENT(INOUT) :: IXSPS
      INTEGER KXSP(NISP,*),IPARG(NPARG,*),IXSP(KVOISPH,*),
     .        IPART(LIPART1,*),IPARTSP(*), EADD(*), CEPSP(*),
     .        ipm(npropmi,nummat), igeo(npropgi,numgeo),
     .        nd, sph2sol(*), sol2sph(2,*), irst(3,nsphsol)
      my_real pm(npropm,nummat), spbuf(nspbuf,numsph)
      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 NE, NG, MT, MLN, I, J, MODE, II0, JJ0, 
     .        II, JJ, II1, JJ1, II2, JJ2, II3, JJ3, II4, JJ4,
     .        N, IGTYP,IORDER,IPRT,ISLEEP,IUN,IFAIL,IEOS, IKIND, STAT,
     .        jale_from_mat, jale_from_prop
      INTEGER WORK(70000)
      INTEGER, DIMENSION(:,:),ALLOCATABLE :: ITRI
      INTEGER, DIMENSION(:),ALLOCATABLE   :: INDEX
      INTEGER, DIMENSION(:,:),ALLOCATABLE :: INUM
      INTEGER, DIMENSION(:),ALLOCATABLE   :: XEP
      my_real, DIMENSION(:,:),ALLOCATABLE :: rnum
      DATA iun/1/
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER  MY_SHIFTL,MY_SHIFTR,MY_AND
      EXTERNAL MY_SHIFTL,MY_SHIFTR,MY_AND
      my_real, EXTERNAL :: GET_U_GEO
C-----------------------------------------------
 
C======================================================================|
C  GENERAL SORTING : ALL CRITERIA, ALL ELEMENTS
C----------------------------------------------------------
      CALL my_alloc(itri,7,numsph)
      CALL my_alloc(index,2*numsph)
      CALL my_alloc(inum,13,numsph)
      CALL my_alloc(xep,numsph)
      CALL my_alloc(rnum,nspbuf,numsph)
      
      DO i=1,numsph
        IF(nsphsol==0)THEN
          itri(1,i)=0
        ELSE
          itri(1,i)=sph2sol(i)
        END IF
        itri(7,i)=i
        index(i)=i
        inum(1,i)=ipartsp(i)
        inum(2,i)=kxsp(1,i)
        inum(3,i)=kxsp(2,i)
        inum(4,i)=kxsp(3,i)
        inum(5,i)=kxsp(4,i)
        inum(6,i)=kxsp(5,i)
        inum(7,i)=kxsp(6,i)
        inum(8,i)=kxsp(7,i)
        inum(9,i)=kxsp(8,i)
C tri spbuf     
        DO j=1,nspbuf
         rnum(j,i)=spbuf(j,i)
        END DO
       ENDDO
 
      DO i=1,numsph
        xep(i)=cepsp(i)
      END DO
 
      DO i = 1, numsph
        DO j = 1, kvoisph
          ixsps(j,i) = ixsp(j,i)
        END DO
      END DO
C
      DO i = 1, numsph
        iprt  =ipartsp(i)
        mt    =ipart(1,iprt)
        mln   =nint(pm(19,abs(mt)))
        ng    =ipart(2,iprt)
        igtyp = igeo(11,ng)
        isorth= min(iun,igeo(2,ng))
        israt = ipm(3,mt)
        ieos  = ipm(4,mt)
C   warning : -1<=IORDER<=1
        iorder=get_u_geo(5,ng)
        isleep=kxsp(2,i)
        IF(nsphsol==0)THEN
          itri(1,i)=0
        ELSE
          itri(1,i)=sph2sol(i)
        END IF
C
        jale_from_mat = nint(pm(72,mt))
        jale_from_prop = igeo(62,ng)
        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
        END IF
        jtur=nint(pm(70,mt))
        jthe=nint(pm(71,mt))
        ifail = 0
        IF (mat_param(mt)%NFAIL > 0) ifail = 1
C Key 1
        jthe=my_shiftl(jthe,1)
        jtur=my_shiftl(jtur,2)
        jeul=my_shiftl(jeul,3)
        jlag=my_shiftl(jlag,4)
        jale=my_shiftl(jale,5)
C        ISSN=MY_SHIFTL(ISSN,6)
C        JHBE=MY_SHIFTL(JHBE,9)
C        JPOR=MY_SHIFTL(JPOR,12)
! do not sort in the following cases
        IF(mln<28.OR.mln==36.OR.mln==46.OR.mln==47)mln=0
        mln   = my_shiftl(mln,21)
        ifail = my_shiftl(ifail,31)
        itri(2,i)=mln+jale+jlag+jeul+jtur+jthe+ifail
C
        itri(3,i)=ng
C
        itri(4,i)=mt
C Key 4
        iorder= my_shiftl(iorder,0)
        isorth= my_shiftl(isorth,2)
        israt = my_shiftl(israt,3)
        ieos  = my_shiftl(ieos,5) 
C       next  = MY_SHIFTL(next,9) 
        itri(5,i)=iorder+israt+isorth+ieos
C Key5 5
        itri(6,i)=isleep
      END DO
C
      mode = 0
      CALL my_orders( mode, work, itri, index, numsph , 7)
C
      DO i=1,numsph
        ipartsp(i)= inum(1,index(i))
        kxsp(1,i) = inum(2,index(i))
        kxsp(2,i) = inum(3,index(i))
        kxsp(3,i) = inum(4,index(i))
        kxsp(4,i) = inum(5,index(i))
        kxsp(5,i) = inum(6,index(i))
        kxsp(6,i) = inum(7,index(i))
        kxsp(7,i) = inum(8,index(i))
        kxsp(8,i) = inum(9,index(i))
 
c      sorting spbuf
       DO j=1,nspbuf
         spbuf(j,i) = rnum(j,index(i))
       ENDDO 
      END DO
C
      DO i=1,numsph
        cepsp(i) = xep(index(i))
      END DO
C
      DO i = 1, numsph
        DO j = 1, kvoisph
          ixsp(j,i) = ixsps(j,index(i))
        END DO
      END DO
C
      IF(nsphsol/=0)THEN
C
        DO i=1,numsph
          inum(10,i)=sph2sol(i)
          IF(i >= first_sphsol .AND. i <  first_sphsol+nsphsol)THEN
            inum(11,i)=irst(1,i-first_sphsol+1)
            inum(12,i)=irst(2,i-first_sphsol+1)
            inum(13,i)=irst(3,i-first_sphsol+1)
          END IF
        END DO
C
        DO i=1,numsph
          sph2sol(i) = inum(10,index(i))
          IF(i >= first_sphsol .AND. i < first_sphsol+nsphsol)THEN
C INDEX(I) < FIRST_SPHSOL <=> internal error
            irst(1,i-first_sphsol+1)=inum(11,index(i))
            irst(2,i-first_sphsol+1)=inum(12,index(i))
            irst(3,i-first_sphsol+1)=inum(13,index(i))
          END IF
        END DO
C
C Rebuild SOL2SPH, SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
        DO n=1,numels8
          sol2sph(1,n)=0
          sol2sph(2,n)=0
        END DO
        n=sph2sol(first_sphsol)
        sol2sph(1,n)=0
        sol2sph(2,n)=sol2sph(1,n)+1
        DO i=first_sphsol+1,first_sphsol+nsphsol-1
          IF(sph2sol(i)==n)THEN
            sol2sph(2,n)=sol2sph(2,n)+1
          ELSE
            n=sph2sol(i)
            sol2sph(1,n)=i-1
            sol2sph(2,n)=sol2sph(1,n)+1
          END IF
        END DO          
C
      END IF
C reneumbering th groups and surface buffer
C--------------------------------------------------------------
C         DETERMINATION DES SUPER_GROUPES
C--------------------------------------------------------------
      nd=1
      eadd(1) = 1
      DO i=2,numsph
        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))
        IF((ii0==0.AND.ii0/=jj0) .OR. ii/=jj .OR. ii1/=jj1.OR.ii2/=jj2 .OR. ii3/=jj3.OR.ii4/=jj4) THEN
          nd=nd+1
          eadd(nd)=i
        END IF
      END DO
      eadd(nd+1) = numsph+1
      ne = 0
      DO n=1,nd
        ne = ne + eadd(n+1)-eadd(n)
      ENDDO
      DEALLOCATE(itri)
      DEALLOCATE(index)
      DEALLOCATE(inum)
      DEALLOCATE(xep)
      DEALLOCATE(rnum)
 
C-----------
      RETURN
      END