iniphase.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/.
!||====================================================================
!||    iniphase        ../starter/source/initial_conditions/inivol/iniphase.F
!||--- called by ------------------------------------------------------
!||    inifill         ../starter/source/initial_conditions/inivol/inifill.F
!||--- uses       -----------------------------------------------------
!||====================================================================
      SUBROUTINE iniphase(N2D      ,NUMELS    ,NUMELTG   ,NUMELQ   ,
     .                    NUMNOD   ,NGROUP    ,
     .                    IXS      ,IPART_    ,IPHASE    ,IDP      ,
     .                    KVOL     ,NUPARAM   ,UPARAM    ,NTRACE   ,
     .                    ITAGNSOL ,ISOLNOD   ,PART_FILL ,NBIP     ,
     .                    NBSUBMAT ,MLW       ,ELBUF_TAB ,NG       , MULTI_FVM,
     .                    IXQ      ,IXTG      ,ITYP      ,NEL  )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE elbufdef_mod
      USE multi_fvm_mod
      USE constant_mod , ONLY : nine_over_10
      use element_mod , only :nixs,nixq,nixtg
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER,INTENT(IN) :: N2D !< 2d/3d flag
      INTEGER,INTENT(IN) :: NUMELS, NUMELTG, NUMELQ, NUMNOD, NGROUP !array sizes
      INTEGER,INTENT(IN) :: NBSUBMAT
      INTEGER IXS(NIXS,NUMELS),IPART_(*),IPHASE(NBSUBMAT+1,*),IDP,NUPARAM
      INTEGER ITAGNSOL(NUMNOD)
      INTEGER :: NBIP(NBSUBMAT,NEL)   !< number of internal points
      INTEGER :: NTRACE               !<  maximum number of internal points (NBIP <= NTRACE, default 7*7*7)
      INTEGER ISOLNOD,PART_FILL(*)
      INTEGER,INTENT(IN) :: IXQ(NIXQ,NUMELQ) !< quad connectivity buffer
      INTEGER,INTENT(IN) :: IXTG(NIXTG,NUMELTG) !< triangles connectivity buffer
      INTEGER, INTENT(IN) :: ITYP !< elem types of the current group (quad, triangles, hexa,)
      my_real kvol(nbsubmat,nel)      !< volume fractions
      my_real uparam(nuparam)
      INTEGER,INTENT(IN) :: MLW !< material law (type)
      INTEGER,INTENT(IN) :: NG  !< current elem group
      TYPE(elbuf_struct_), TARGET, DIMENSION(NGROUP), INTENT(IN) :: ELBUF_TAB
      TYPE (MULTI_FVM_STRUCT), INTENT(IN) :: MULTI_FVM
      INTEGER, INTENT(IN) :: NEL !< number of elements in the group
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I,K,J !< loop and temporary integers
      INTEGER :: IMAT  !< submat identifier (in 1:NBSUBMAT)
      INTEGER :: IX(4) !< working array for shell nodes
      my_real :: AV(NBSUBMAT) !< working array for volume fractions
      TYPE(G_BUFEL_) ,POINTER :: GBUF  !< global elem buffer
      TYPE(L_BUFEL_) ,POINTER :: LBUF  !< local elem buffer (submaterials)
C-----------------------------------------------
C---
C FILL ELEMENTS INPUT PHASES
C---
        av(1:nbsubmat) = zero
 
        IF(mlw==51)THEN
          !when using LAW51 nbsubmat=4
          av(1) = uparam(4)
          av(2) = uparam(5)
          av(3) = uparam(6)
          av(4) = uparam(46)
        ELSE
          gbuf => elbuf_tab(ng)%GBUF
          DO i=1,multi_fvm%NBMAT
            lbuf  => elbuf_tab(ng)%BUFLY(i)%LBUF(1,1,1) 
            av(i) = lbuf%VOL(1) / gbuf%VOL(1)              !same value for idx=1,NEL then idx=1 here.
          ENDDO
        ENDIF
C
        DO i=1,nel
          IF(ipart_(i) /= 0) THEN
            IF (ipart_(i) /= idp  .AND. part_fill(ipart_(i)) == 0) THEN
              kvol(1:nbsubmat,i)   = av(1:nbsubmat)
              part_fill(ipart_(i)) = 1
            ELSEIF (ipart_(i) == idp) THEN
              imat=maxloc(av(1:nbsubmat),1) ! The default phase is the one that is most prevalent.
              iphase(1,i)       = imat
              iphase(nbsubmat+1,i) = 1 !number of present submaterials
              kvol(imat,i)         = zero
              IF (nbip(imat,i) == 0) THEN
                nbip(imat,i) = ntrace
              ENDIF
              IF (isolnod == 8) THEN
                DO k=2,9
                  j = ixs(k,i)
                  IF(itagnsol(j) == 0)itagnsol(j) = 1
                END DO
              ELSEIF (isolnod == 4) THEN
                ix(1) =ixs(2,i)
                ix(2) =ixs(4,i)
                ix(3) =ixs(7,i)
                ix(4) =ixs(6,i)
                DO k=1,4
                  j = ix(k)
                  IF(itagnsol(j) == 0)itagnsol(j) = 1
                END do!next K
              ELSEIF(ityp == 7 .AND. n2d > 0)THEN
                  IF(itagnsol(ixtg(2,i)) == 0)itagnsol(ixtg(2,i)) = 1
                  IF(itagnsol(ixtg(3,i)) == 0)itagnsol(ixtg(3,i)) = 1
                  IF(itagnsol(ixtg(4,i)) == 0)itagnsol(ixtg(4,i)) = 1
              ELSEIF(ityp == 2)THEN
                  IF(itagnsol(ixq(2,i)) == 0)itagnsol(ixq(2,i)) = 1
                  IF(itagnsol(ixq(3,i)) == 0)itagnsol(ixq(3,i)) = 1
                  IF(itagnsol(ixq(4,i)) == 0)itagnsol(ixq(4,i)) = 1
                  IF(itagnsol(ixq(5,i)) == 0)itagnsol(ixq(5,i)) = 1
              endif!ISOLNOD
              part_fill(idp) = 1
            END if!(IPART_(I) /= IDP )
          ENDIF !IF(IPART(I) /= 0)
        END do!next I
C-----
      RETURN
      END