qgrtails.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/.
!||====================================================================
!||    qgrtails               ../starter/source/elements/solid_2d/quad/qgrtails.f
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl2               ../starter/source/starter/freform.F
!||    zeroin                 ../starter/source/system/zeroin.F
!||--- uses       -----------------------------------------------------
!||    inivol_def_mod         ../starter/share/modules1/inivol_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    r2r_mod                ../starter/share/modules1/r2r_mod.F
!||====================================================================
      SUBROUTINE qgrtails(
     1       IXQ    ,PM      ,IPARG  ,GEO    ,
     2       EADD   ,ND      ,DD_IAD ,IDX    ,
     3       INUM   ,INDEX   ,CEP    ,IPARTQ ,
     4       ITR1   ,IGRSURF ,IGRQUAD,MAT_PARAM,
     5       IGEO   ,IPM     ,IQUAOFF,INIVOL,PRINT_FLAG)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE r2r_mod
      USE groupdef_mod
      USE inivol_def_mod , ONLY : inivol_struct_, num_inivol
      USE matparam_def_mod
      USE names_and_titles_mod , ONLY : nchartitle
      USE ale_mod , ONLY : ale
      use element_mod , only : nixq
C-----------------------------------------------
C            A R G U M E N T S
C-----------------------------------------------
C     IXQ(7,NUMELQ)      TABLEAU CONECS+PID+MID+NOS SOLIDES 4N      E
C     PM(NPROPM,NUMMAT)  ARRAY OF MATERIAL PROPERTIES           E
C     IPARG(NPARG,NGROUP)TABLEAU DES CARACTERISTIQUES DES GROUPES   E/S
C     GEO(NPROPG,NUMGEO) ARRAY OF PID CHARACTERISTICS                 E
C     EADD(NUMELQ)       TABLEAU DES ADRESEES DANS IDAM CHGT DAMIER E 
C     DD_IAD             ARRAY OF DD IN SUPER GROUPS          S
C     INUM(8,NUMELQ)     TABLEAU DE TRAVAIL                         E/S
C     INDEX(NUMELQ)      TABLEAU DE TRAVAIL                         E/S
C     CEP(NUMELQ)        TABLEAU DE TRAVAIL                         E/S
C     IPARTQ(NUMELQ)     TABLEAU DE TRAVAIL                         E/S
C     ITR1(NSELQ)        TABLEAU DE TRAVAIL                         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      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
#include      "param_c.inc"
#include      "scr17_c.inc"
#include      "r2r_c.inc"
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER ND, IDX
      INTEGER IGEO(NPROPGI,NUMGEO),IPM(NPROPMI,NUMMAT), IXQ(NIXQ,NUMELQ),IPARG(NPARG,*),
     .        EADD(*),DD_IAD(NSPMD+1,*),INUM(9,*),INDEX(*),
     .        CEP(*),IPARTQ(*),ITR1(*),
     .        IQUAOFF(*)
      INTEGER, INTENT(IN) :: PRINT_FLAG !< flag to print the element group data
      TYPE (INIVOL_STRUCT_) , DIMENSION(NUM_INIVOL) :: INIVOL
      MY_REAL PM(NPROPM,NUMMAT), GEO(NPROPG,NUMGEO)
C-----------------------------------------------
      TYPE (GROUP_)  , DIMENSION(NGRQUAD)  :: IGRQUAD
      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 
     .   ngr1, mln, ng, n, mid, pid, ii, nel, ne1,
     .   p, nel_prec, lb_l, igt, jhbe, i,
     .   ml1, ml2, mt1, mt2,nb,ineg,ieos,
     .   mode, work(70000),nn,j,
     .   iplast,ifail,nfail,
     .   ngp(nspmd+1),icpre,ipartr2r,ismst,tag_invol,
     .   jale_from_mat,jale_from_prop
      INTEGER ID,MFT,ILOC,JJ
      CHARACTER(LEN=NCHARTITLE)::TITR
      LOGICAL lFOUND
C--------------------------------------------------------------
C         bounding of MVSIZ groups
C--------------------------------------------------------------
      ngr1 = ngroup + 1
C
C Phase 1: Domain Decomposition
C
      idx=idx+nd*(nspmd+1)
      CALL zeroin(1,nd*(nspmd+1),dd_iad(1,nspgroup+1))
C     NSPGROUP = NSPGROUP + ND
      nft = 0
C initialisation dd_iad
      DO n=1,nd
       DO p=1,nspmd+1
         dd_iad(p,nspgroup+n) = 0
       END DO
      ENDDO
C
C Phase 2: MVSIZ Group Bounds
C ngroup is global, iparg is global but organized based on dd
C
      DO n=1,nd
        nel = eadd(n+1)-eadd(n)
C
        DO i = 1, nel
          index(i) = i
          inum(1,i)=ipartq(nft+i)
          inum(2,i)=ixq(1,nft+i)
          inum(3,i)=ixq(2,nft+i)
          inum(4,i)=ixq(3,nft+i)
          inum(5,i)=ixq(4,nft+i)
          inum(6,i)=ixq(5,nft+i)
          inum(7,i)=ixq(6,nft+i)
          inum(8,i)=ixq(7,nft+i)
          inum(9,i)=iquaoff(nft+i)
        ENDDO
      
        mode=0
        CALL my_orders( mode, work, cep(nft+1), index, nel , 1)
        DO i = 1, nel
          ipartq(i+nft)=inum(1,index(i))
          ixq(1,i+nft)=inum(2,index(i))
          ixq(2,i+nft)=inum(3,index(i))
          ixq(3,i+nft)=inum(4,index(i))
          ixq(4,i+nft)=inum(5,index(i))
          ixq(5,i+nft)=inum(6,index(i))
          ixq(6,i+nft)=inum(7,index(i))
          ixq(7,i+nft)=inum(8,index(i))
          iquaoff(i+nft)=inum(9,index(i))
          itr1(nft+index(i)) = nft+i
        ENDDO
 
C dd-iad
        p = cep(nft+index(1))
        nb = 1
        DO i = 2, nel
          IF (cep(nft+index(i))/=p) THEN
            dd_iad(p+1,nspgroup+n) = nb
            nb = 1
            p = cep(nft+index(i))
          ELSE
            nb = nb + 1
          ENDIF
        ENDDO
        dd_iad(p+1,nspgroup+n) = nb
        DO p = 2, nspmd
          dd_iad(p,nspgroup+n) = dd_iad(p,nspgroup+n)
     .                         + dd_iad(p-1,nspgroup+n)
        ENDDO
        DO p = nspmd+1,2,-1
          dd_iad(p,nspgroup+n) = dd_iad(p-1,nspgroup+n)+1
        ENDDO
        dd_iad(1,nspgroup+n) = 1
C          
C maj CEP
C
        DO i = 1, nel
          index(i) = cep(nft+index(i))          
        ENDDO
        DO i = 1, nel
          cep(nft+i) = index(i)          
        ENDDO
        nft = nft + nel
      ENDDO
 
C
C renumbering for surfaces
C
      DO i=1,nsurf
        nn=igrsurf(i)%NSEG
        DO j=1,nn
          IF(igrsurf(i)%ELTYP(j) == 2)
     .       igrsurf(i)%ELEM(j) = itr1(igrsurf(i)%ELEM(j))
        ENDDO
      ENDDO
C
C renumbering for shell groups
C
      DO i=1,ngrquad
        nn=igrquad(i)%NENTITY
        DO j=1,nn
          igrquad(i)%ENTITY(j) = itr1(igrquad(i)%ENTITY(j))
        ENDDO
      ENDDO
C
      ineg =  0
      DO 300 n=1,nd
      
       nft = 0
       lb_l = lbufel
       DO p = 1, nspmd
        ngp(p)=0
        nel = dd_iad(p+1,nspgroup+n)-dd_iad(p,nspgroup+n)
        IF (nel>0) THEN
         nel_prec = dd_iad(p,nspgroup+n)-dd_iad(1,nspgroup+n)
         ngp(p)=ngroup
         ng  = (nel-1)/nvsiz + 1
         DO 220 i=1,ng
C ngroup global
          ngroup=ngroup+1
          ii = eadd(n)+nft
          mid = ixq(1,ii)
          pid = ixq(6,ii)
          ipartr2r = 0
          IF (nsubdom>0) ipartr2r = tag_mat(mid)
          npt =1
          jhbe=0
          jpor=0
          jcvt = 0
          isorth=0
          iplast= 1
          icpre=0
          ismst = 0
          igt = 0
          IF(pid/=0)THEN
            IF(igeo(10,pid)==17 .OR.
     .         (n2d==1.AND.igeo(10,pid)==22)) THEN
              npt = igeo(4,pid)
              jhbe = igeo(10,pid)
            ENDIF
            icpre  = igeo(13,pid)
            igt    = igeo(11,pid)
            istrain= igeo(12,pid)
            jcvt   = igeo(16,pid)
            isorth = igeo(17,pid)
            ismst  = igeo(5,pid)
            IF (igt /= 15) iplast = igeo(9,pid)
            IF(igt==15) jpor=2*nint(geo(28,pid))
          ENDIF
          mln = nint(pm(19,abs(mid)))
          IF(mid<0)THEN
            IF(mln==6.AND.jpor/=2)mln=17
            IF(mln==46)mln=47
            mid=abs(mid)
            ixq(1,ii)=mid
            ineg = 1
          ENDIF
          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
          ENDIF
 
          !ALE REZONING/REMAPING : number of MAT/EOS variables to treat (used by staggered scheme only : arezon.F)
          !  With ALE framework, since the Mesh is arbitrary, the variable must be updated to map thei expected location and not follow the arbitrary mesh displacement
          !  this numbering here will be used in arezon.F to loop over variables to rezon/remap
          IF(jale == 1)THEN
            ale%REZON%NUM_NUVAR_MAT = max(ale%REZON%NUM_NUVAR_MAT, mat_param(mid)%REZON%NUM_NUVAR_MAT )
            ale%REZON%NUM_NUVAR_EOS = max(ale%REZON%NUM_NUVAR_EOS, mat_param(mid)%REZON%NUM_NUVAR_EOS )
          ENDIF
 
          !ALE UVAR REZONING  (81:MAT,  82:EOS)
          IF(jale == 1)THEN
            iparg(81,ngroup) = mat_param(mid)%REZON%NUM_NUVAR_MAT
            iparg(82,ngroup) = mat_param(mid)%REZON%NUM_NUVAR_EOS
          ENDIF
 
          jtur=nint(pm(70,mid))
          jthe=nint(pm(71,mid))
                    
          jmult=0
          IF(mln==20)THEN
            jmult=nint(pm(20,mid))
            mt1=nint(pm(21,mid))
            mt2=nint(pm(22,mid))
            ml1=nint(pm(19,mt1))
            ml2=nint(pm(19,mt2))
          ELSE
            jmult=0
            ml1=0
            ml2=0
          ENDIF
C--------------------
C-   ICPRE,ISMSTR JCVT Automatic           
C--------------------
          IF (igt == 14.OR.igt == 6) THEN
            IF (icpre < 0) icpre =0
            IF (ismst < 0) ismst =4
            IF (jcvt<0) THEN
             jcvt = 0 
             IF (jlag>0) jcvt = 1
            END IF
          END IF
C--------------------
C TEST COMPATIBILITE
C--------------------
 
          id=igeo(1,pid)
          CALL fretitl2(titr,igeo(npropgi-ltitr+1,pid),ltitr)
          IF (ismst /= 2 .AND. ismst /= 4) THEN
            CALL ancmsg(msgid=1223,
     .                  msgtype=msgerror,
     .                  anmode=aninfo_blind_2,
     .                  i1=id,
     .                  c1=titr,
     .                  prmod=msg_cumu)
          ENDIF
          IF (mln==68 ) THEN
            CALL ancmsg(msgid=1224,
     .                  msgtype=msgerror,
     .                  anmode=aninfo_blind_1,
     .                    i1=id,
     .                    c1=titr)
          ENDIF
          IF (jhbe==17.AND.(jale+jeul /= 0)) THEN   
            CALL ancmsg(msgid=1222,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_2,
     .                  i1=id,
     .                  c1=titr,
     .                  prmod=msg_cumu)
            jhbe = 2
            IF (geo(13,pid) == zero) geo(13,pid) = em01
            npt = 1
            igeo(4,pid) = npt
            igeo(10,pid) = jhbe
          END IF
C
          IF(jcvt/=0.AND.(jlag==0.OR.mln==20))THEN
            CALL fretitl2(titr,
     .                    igeo(npropgi-ltitr+1,pid),ltitr)
            CALL ancmsg(msgid=610,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_1,
     .                  i1=id,
     .                  c1=titr,
     .                  i2=ixq(7,ii))
            jcvt=0
          END IF
          israt=ipm(3,mid)
          ifail = 0
          nfail = mat_param(mid)%NFAIL
          istrain = 1
          ieos=ipm(4,mid)
 
C
C   - initial volume franction -
C
          lfound=.false.
          tag_invol=0
          IF(num_inivol > 0)THEN
          ! Warning : In same group you can have different PArts, A loop over elem in groups has to be introduced to check if INIVOL PART is there.
            mft = eadd(n)-1 + nft
            ne1=min( nvsiz, nel + nel_prec - nft)
            DO iloc = 1 ,ne1
              DO jj=1,num_inivol
                IF(inivol(jj)%PART_ID == ipartq(iloc+mft)) THEN
                  tag_invol = 1
                  lfound=.true.
                  EXIT
                ENDIF
                IF(lfound)EXIT
              ENDDO
            END DO
          END IF
                      
C-------------------------------------------------
C STOCKAGE IPARG
C-------------------------------------------------
          CALL zeroin(1,nparg,iparg(1,ngroup))
C
          iparg(1,ngroup) = mln
          ne1 = min( nvsiz, nel + nel_prec - nft)
          iparg(2,ngroup) = ne1
          iparg(3,ngroup)=  eadd(n)-1 + nft
          iparg(4,ngroup) = 1   ! obsolete
c          IPARG(4,NGROUP) = LBUFEL+1
          iparg(5,ngroup) = 2
          iparg(6,ngroup) = npt
          iparg(7,ngroup) = jale
          iparg(11,ngroup)= jeul
          iparg(12,ngroup)= jtur
          IF(jale == 0 .AND. jeul == 0)THEN
            iparg(13,ngroup)=-abs(jthe)  ! -1 nodal temperature    +1 centroid temperature
          ELSE
            iparg(13,ngroup)=+abs(jthe)  ! -1 nodal temperature    +1 centroid temperature
          ENDIF
          iparg(14,ngroup)= jlag
          iparg(18,ngroup)= mid
          iparg(20,ngroup)= jmult
          ! Multifluid law, setting NLAY
          IF (mln == 151) iparg(20, ngroup) = ipm(20, mid)
          iparg(10,ngroup)= icpre
          iparg(23,ngroup)= jhbe
          iparg(24,ngroup)= 0
          iparg(25,ngroup)= ml1
          iparg(26,ngroup)= ml2
          iparg(27,ngroup)= jpor
          iparg(29,ngroup)= iplast
C Group/Processor Splition
          iparg(32,ngroup)= p-1
C  Be careful in all rigor> = 46
          iparg(34,ngroup)= nint(pm(10,mid))
          iparg(37,ngroup)= jcvt
          iparg(38,ngroup)= igt
          iparg(40,ngroup)= israt
          iparg(42,ngroup)= isorth
          iparg(43,ngroup)= ifail
          iparg(44,ngroup)= istrain
          !inivol
          iparg(53,ngroup) = tag_invol
C         equation of state
          iparg(55,ngroup)= ieos
          iparg(62,ngroup)= pid
C         flag for group of duplicated elements in multidomains
          IF (nsubdom>0) iparg(77,ngroup)= ipartr2r 
          nft = nft + ne1
  220    CONTINUE
         ngp(p)=ngroup-ngp(p)
        ENDIF
       ENDDO
C Dd_iad => nb groups by sub -domain
       ngp(nspmd+1)=0
       DO p = 1, nspmd
         ngp(nspmd+1)=ngp(nspmd+1)+ngp(p)
         dd_iad(p,nspgroup+n)=ngp(p)
       END DO
       dd_iad(nspmd+1,nspgroup+n)=ngp(nspmd+1)
C
  300 CONTINUE
C                                      
      nspgroup = nspgroup + nd
C CFD treatment on MID negative on all solids if ineg=1
      IF (ineg==1) THEN
        DO i = 1, numelq
          ixq(1,i) = abs(ixq(1,i))
        ENDDO
      ENDIF
C
      IF(print_flag>6) THEN
          WRITE(iout,1000)
          WRITE(iout,1001)(n,iparg(1,n),iparg(2,n),iparg(3,n)+1,
     +                iparg(4,n),iparg(6,n),iparg(7,n),iparg(11,n),    
     +                iparg(12,n),iparg(13,n),iparg(23,n),
     +                iparg(24,n),iparg(18,n),iparg(27,n),
     +                iparg(29,n)+1,iparg(43,n),iparg(55,n),
     +                n=ngr1,ngroup)
      ENDIF
       CALL ancmsg(msgid=1222,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_2,
     .                  prmod=msg_print)
       CALL ancmsg(msgid=1223,
     .                  msgtype=msgerror,
     .                  anmode=aninfo_blind_2,
     .                  prmod=msg_print)
C
 1000 FORMAT(//,7x,'4-NODE 2D SOLID ELEMENT GROUPS'/
     +          7x,'---------------------'//
     +'     GROUP      MAT.     ELEM.     FIRST    BUFFER     GAUSS',
     +'    A.L.E.     EULER    TURBU.    THERM.     HOUR-     INTEG',
     +'       VAR    POROUS   PLASTI.   FAILURE      IEOS   '/
     +'         #       LAW    NUMBER     ELEM.   ADDRESS    POINTS',
     +'      FLAG      FLAG      FLAG      FLAG     GLASS      FLAG',
     +'       MID    MEDIUM      FLAG      FLAG      TYPE   '/)
 1001 FORMAT(17(i10))
C
      RETURN
      END