h3d_quad_vector.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/.
!||====================================================================
!||    h3d_quad_vector        ../engine/source/output/h3d/h3d_results/h3d_quad_vector.F
!||--- called by ------------------------------------------------------
!||    genh3d                 ../engine/source/output/h3d/h3d_results/genh3d.F
!||--- calls      -----------------------------------------------------
!||    h3d_write_vectors      ../engine/source/output/h3d/h3d_results/h3d_write_vectors.F
!||    initbuf                ../engine/share/resol/initbuf.F
!||    qrota_vect             ../engine/source/output/anim/generate/qrota_vect.F
!||--- uses       -----------------------------------------------------
!||    alefvm_mod             ../common_source/modules/ale/alefvm_mod.F
!||    elbufdef_mod           ../common_source/modules/mat_elem/elbufdef_mod.F90
!||    element_mod            ../common_source/modules/elements/element_mod.F90
!||    initbuf_mod            ../engine/share/resol/initbuf.F
!||    multi_fvm_mod          ../common_source/modules/ale/multi_fvm_mod.F90
!||    names_and_titles_mod   ../common_source/modules/names_and_titles_mod.F
!||    schlieren_mod          ../engine/share/modules/schlieren_mod.F
!||    stack_mod              ../engine/share/modules/stack_mod.F
!||====================================================================
      SUBROUTINE h3d_quad_vector(
     .                  ELBUF_TAB   ,QUAD_VECTOR,IFUNC   ,IPARG       ,GEO        ,
     .                  IXQ         ,IXC       ,IXTG      ,PM         ,
     .                  EL2FA       ,NBF       ,IADP        ,
     .                  NBF_L       ,EHOUR     ,ANIM      ,NBPART      ,IADG       ,
     .                  IPM         ,IGEO      ,THKE      ,ERR_THK_SH4 ,ERR_THK_SH3,
     .                  INVERT      ,X         ,V         ,W           ,
     .                  NV46        ,NERCVOIS  ,NESDVOIS  ,LERCVOIS    ,LESDVOIS,
     .                  STACK       ,ID_ELEM   ,INFO1       ,INFO2      , 
     .                  IS_WRITTEN_QUAD,IPARTQ,IPARTTG   ,LAYER_INPUT ,IPT_INPUT  ,
     .                  PLY_INPUT   ,GAUSS_INPUT,IUVAR_INPUT,H3D_PART  ,KEYWORD   ,
     .                  BUFMAT      ,MULTI_FVM ,IR_INPUT  ,IS_INPUT    ,IT_INPUT)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE initbuf_mod
      USE elbufdef_mod    
      USE schlieren_mod 
      USE stack_mod 
      USE multi_fvm_mod              
      USE alefvm_mod
      USE names_and_titles_mod, ONLY: ncharline100
      use element_mod , only : nixq,nixc,nixtg
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      "mvsiz_p.inc"
#include      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      my_real
     .   quad_vector(3,*),x(3,numnod),v(3,numnod),w(3,numnod),thke(*),ehour(*),geo(npropg,numgeo),
     .   anim(*),pm(npropm,*),err_thk_sh4(*), err_thk_sh3(*)
      INTEGER IPARG(NPARG,NGROUP),IXC(NIXC,NUMELC),IXTG(NIXTG,NUMELTG),EL2FA(*),
     .   IXQ(NIXQ,NUMELQ),IFUNC,NBF,
     .   IADP(*),NBF_L, NBPART,IADG(NSPMD,*),IPM(NPROPMI,NUMMAT),
     .   IGEO(NPROPGI,NUMGEO),INVERT(*),  NV46,ID_ELEM(*),
     .   INFO1,INFO2,IS_WRITTEN_QUAD(*),IPARTQ(*),IPARTTG(*),H3D_PART(*),
     .   LAYER_INPUT ,IPT_INPUT,GAUSS_INPUT,PLY_INPUT,IUVAR_INPUT,
     .   IR_INPUT,IS_INPUT,IT_INPUT,IS_WRITTEN_VECTOR(MVSIZ)
      TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
      TYPE (STACK_PLY) :: STACK
      CHARACTER(LEN=NCHARLINE100) :: KEYWORD
      TYPE (MULTI_FVM_STRUCT), INTENT(IN) :: MULTI_FVM
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      my_real
     .   dam1(mvsiz),dam2(mvsiz),
     .   wpla(mvsiz),dmax(mvsiz),wpmax(mvsiz),fail(mvsiz),
     .   epst1(mvsiz),epst2(mvsiz),epsf1(mvsiz),epsf2(mvsiz),
     .   value(3),ff0,gg0,hh0,ll0,mm0,nn0,mass(mvsiz)
      my_real
     .   off, p,vonm2,s1,s2,s12,s3,dmgmx,fac,
     .   dir1_1,dir1_2,dir2_1,dir2_2,aa,bb,v1,v2,v3,x21,x32,x34,
     .   x41,y21,y32,y34,y41,z21,z32,z34,z41,suma,vr,vs,x31,y31,
     .   z31,e11,e12,e13,e21,e22,e23,sum,area,x2l,var,
     .   e1x,e1y,e1z,e2x,e2y,e2z,e3x,e3y,e3z,rx,ry,rz,sx,sy,sz,
     .   vg(5),vly(5),ve(5),bufmat(*),
     .   s11,s22,s33,s4,s5,s6,crit,value1,value2
      my_real
     .   evar(3,mvsiz)
      INTEGER I, NG, NEL, NPTR, NPTS, NPTT, NLAY, ILAY, 
     .        ir,is,it,il,mlw, nuvar,ius,lenf,ptf,ptm,pts,nfail,
     .        n,nn,k,k1,k2,jturb,mt,imid,ialel,ipid,ish3n,nni,
     .        nn1,nn2,nn3,nn4,nn5,nn6,nn9,nf,buf,nvarf,
     .        offset,ihbe,nptm,npg, mpt,ipt,iadd,iadr,ipmat,ifailt,
     .        iigeo,iadi,isubstack,ithk,nercvois(*),nesdvois(*),
     .        lercvois(*),lesdvois(*),id_ply,nb_plyoff,iok,iadbuf,nuparam,
     .        imat,ivisc,ipos,itrimat
      INTEGER 
     .        pte(4),ptp(4),ptmat(4),ptvar(4),npt_all,iply,
     .        id_elem_tmp(mvsiz),nix,iok_part(mvsiz),jj(6),npgt,iuvar,
     .        is_written_value(mvsiz)
 
 
      TYPE(g_bufel_)  ,POINTER :: GBUF     
      TYPE(L_BUFEL_)  ,POINTER :: LBUF     
 
 
      my_real,
     .  DIMENSION(:), POINTER  :: uvar
 
 
 
      TARGET :: bufmat
C-----------------------------------------------
      ilay = layer_input
      iuvar = iuvar_input
      ir = ir_input
      is = is_input
      it = it_input
C
      DO i=1,numelq
         is_written_quad(i) = 0
      ENDDO
C-----------
      DO 900 ng=1,ngroup
       CALL initbuf(iparg    ,ng      ,                    
     2          mlw     ,nel     ,nft     ,iad     ,ity     ,  
     3          npt     ,jale    ,ismstr  ,jeul    ,jturb   ,  
     4          jthe    ,jlag    ,jmult   ,jhbe    ,jivf    ,  
     5          nvaux   ,jpor    ,jcvt    ,jclose  ,jplasol ,  
     6          irep    ,iint    ,igtyp   ,israt   ,isrot   ,  
     7          icsen   ,isorth  ,isorthg ,ifailure,jsms    )
       IF(mlw /= 13) THEN
          nft   =iparg(3,ng)
          iad   =iparg(4,ng)
          isubstack = iparg(71,ng)
          ivisc = iparg(61,ng)
          iok_part(1:nel) = 0 
          lft=1
          llt=nel
!
          DO i=1,6
            jj(i) = nel*(i-1)
          ENDDO  
c
          value(1:3) = zero
          DO i=1,nel
            is_written_value(i) = 0
          ENDDO       
          evar(1:3,1:nel) = zero
          is_written_vector(1:nel) = 0
C-----------------------------------------------
C           QUAD
C-----------------------------------------------
         IF (ity == 2) THEN
 
            gbuf => elbuf_tab(ng)%GBUF
            lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
            uvar => elbuf_tab(ng)%BUFLY(1)%MAT(1,1,1)%VAR
            jale=(iparg(7,ng)+iparg(11,ng))
            jturb=iparg(12,ng)*jale
            nptr  = elbuf_tab(ng)%NPTR
            npts  = elbuf_tab(ng)%NPTS
            nptt  = elbuf_tab(ng)%NPTT
            nlay  = elbuf_tab(ng)%NLAY
            nuvar = elbuf_tab(ng)%BUFLY(1)%NVAR_MAT
c
            DO  i=1,nel 
              id_elem(nft+i) = ixq(nixq,nft+i)
              IF( h3d_part(ipartq(nft+i)) == 1) iok_part(i) = 1
            ENDDO
C---------------------    
            DO i=1,nel
              quad_vector(1:3,nft+i) = zero   ! Default = zero in all cases !
            ENDDO
c
            iuvar = iuvar_input
C--------------------------------------------------
            IF (keyword == 'VECT/VEL') THEN 
C--------------------------------------------------
               IF (mlw == 151) THEN
                  DO i = 1, nel
                     evar(1,i) = multi_fvm%VEL(1, i + nft)
                     evar(2,i) = multi_fvm%VEL(2, i + nft)
                     evar(3,i) = multi_fvm%VEL(3, i + nft)
                     is_written_vector(i) = 1
                  ENDDO
               ELSE
                  DO i=1,nel
                     IF(gbuf%G_MOM>0 .AND. alefvm_param%IEnabled > 0)THEN
                        evar(1,i) = gbuf%MOM(jj(1) + i) / gbuf%RHO(i) 
                        evar(2,i) = gbuf%MOM(jj(2) + i) / gbuf%RHO(i)
                        evar(3,i) = gbuf%MOM(jj(3) + i) / gbuf%RHO(i)
                        is_written_vector(i) = 1
                     ENDIF
                  ENDDO
               ENDIF
               IF (jcvt == 0 .OR. isorth /= 0) THEN
C                OUTPUT TENSOR STORED IN GLOBAL SYSTEM TO BE TRANSFERRED IN THE ELEMENT LOCAL ONE
                 CALL qrota_vect(x,ixq(1,nft+1),jcvt,evar,gbuf%GAMA,nel)
               ENDIF
C--------------------------------------------------
            ELSEIF (keyword == 'VECT/ACC') THEN
C--------------------------------------------------
               IF (mlw == 151 .AND. ALLOCATED(multi_fvm%ACC)) THEN
                  DO i = 1, nel
                     evar(1,i) = multi_fvm%ACC(1, i + nft)
                     evar(2,i) = multi_fvm%ACC(2, i + nft)
                     evar(3,i) = multi_fvm%ACC(3, i + nft)
                     is_written_vector(i) = 1
                  ENDDO
               ENDIF
C--------------------------------------------------
            ENDIF  ! KEYWORD
C-----------------------------------------------
          CALL h3d_write_vectors(iok_part,is_written_quad,quad_vector,nel,0,nft,evar,is_written_vector)
C-----------------------------------------------
          ENDIF  ! ITY
 
C-----------------------------------------------
       ENDIF     ! MLW /= 13
 900  CONTINUE   ! NG 
C-----------------------------------------------
      RETURN
      END