i12for3.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/.
C  |         INTTI12F                        /interf/intti12.F
!||====================================================================
!||    i12for3    ../engine/source/interfaces/interf/i12for3.F
!||--- called by ------------------------------------------------------
!||    intti12f   ../engine/source/interfaces/interf/intti12.F
!||====================================================================
      SUBROUTINE i12for3(
     1  NSN  ,NMN  ,A      ,IRECT,CRST  ,
     2  MSR  ,NSV  ,IRTL   ,MS   ,WEIGHT,
     3  STIFN,MMASS,TAGKINE,SKEW ,WA    ,
     4  TETS , TETM,ILEV   ,IREF)
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 NSN, NMN,
     .   IRECT(4,*), MSR(*), NSV(*), IRTL(*), WEIGHT(*),TAGKINE(*)
      INTEGER ILEV,IREF
      my_real
     .   a(*), crst(2,*), ms(*), stifn(*), mmass(*),wa(3,*),
     .   skew(lskew,*),tetm(*),tets(*)
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NIR, I, J, I3, J3, I2, J2, I1, J1, II, L, JJ,JL
      my_real
     .   H(4), XMSJ, SS, TT, XMSI, FXI, FYI, FZI,SP,SM,TP,TM,
     .   P(9),CST,SST,FXR, FYR, FZR
C-----------------------------------------------
      nir=2
      IF(n2d==0)nir=4
      IF(ilev==1)THEN
        DO i=1,9
          p(i)=skew(i,iref+1)
        ENDDO
        DO ii=1,nmn
          wa(1,ii)=zero
          wa(2,ii)=zero
          wa(3,ii)=zero
        ENDDO
      ENDIF
 
       !Cel sauvegarde de la masse initiale
        DO ii=1,nmn
          j=msr(ii)
          mmass(ii)=ms(j)
        ENDDO
 
      DO ii=1,nsn
        IF(tagkine(ii)>0)THEN
          i=nsv(ii)
          l=irtl(ii)
          ss=crst(1,ii)
          tt=crst(2,ii)
          i3=3*i
          i2=i3-1
          i1=i2-1
          xmsi=ms(i)
          fxi=a(i1)
          fyi=a(i2)
          fzi=a(i3)
          sp=one+ss
          sm=one-ss
          tp=fourth*(one+tt)
          tm=fourth*(one-tt)
          h(1)=tm*sm
          h(2)=tm*sp
          h(3)=tp*sp
          h(4)=tp*sm
          IF(ilev==1)THEN
           IF(tets(ii)<10000. )THEN
            cst=cos(tets(ii))
            sst=sin(tets(ii))
            fxr=fxi*p(1)+fyi*p(2)+fzi*p(3)
            fyr=fxi*p(4)+fyi*p(5)+fzi*p(6)
            fzr=fxi*p(7)+fyi*p(8)+fzi*p(9)
            fxi=fxr
            fyi=    fyr*cst+fzr*sst
            fzi=   -fyr*sst+fzr*cst
            DO jj=1,nir
              jl=irect(jj,l)
              j=msr(jl)
              wa(1,jl)=wa(1,jl)+fxi*h(jj)
              wa(2,jl)=wa(2,jl)+fyi*h(jj)
              wa(3,jl)=wa(3,jl)+fzi*h(jj)
              ms(j)=ms(j)+xmsi*h(jj)
              stifn(j)=stifn(j)+stifn(i)*h(jj)
            ENDDO
           ELSE
            DO jj=1,nir
              j=msr(irect(jj,l))
              j3=3*j
              j2=j3-1
              j1=j2-1
              a(j1)=a(j1)+fxi*h(jj)
              a(j2)=a(j2)+fyi*h(jj)
              a(j3)=a(j3)+fzi*h(jj)
              ms(j)=ms(j)+xmsi*h(jj)
              stifn(j)=stifn(j)+stifn(i)*h(jj)
            ENDDO
           ENDIF
          ELSE
            DO jj=1,nir
              j=msr(irect(jj,l))
              j3=3*j
              j2=j3-1
              j1=j2-1
              a(j1)=a(j1)+fxi*h(jj)
              a(j2)=a(j2)+fyi*h(jj)
              a(j3)=a(j3)+fzi*h(jj)
              ms(j)=ms(j)+xmsi*h(jj)
              stifn(j)=stifn(j)+stifn(i)*h(jj)
 
            ENDDO
          ENDIF !(ILEV==1)
        stifn(i)=em20
        a(i1)=zero
        a(i2)=zero
        a(i3)=zero
        ENDIF
      ENDDO
      
      IF(ilev==1 )THEN
        DO ii=1,nmn
          cst=cos(tetm(ii))
          sst=sin(tetm(ii))
          fxr=wa(1,ii)
          fyr=wa(2,ii)*cst-wa(3,ii)*sst
          fzr=wa(2,ii)*sst+wa(3,ii)*cst
          wa(1,ii)=fxr*p(1)+fyr*p(4)+fzr*p(7)
          wa(2,ii)=fxr*p(2)+fyr*p(5)+fzr*p(8)
          wa(3,ii)=fxr*p(3)+fyr*p(6)+fzr*p(9)
          j=msr(ii)
          j3=3*j
          j2=j3-1
          j1=j2-1
          a(j1)=a(j1)+wa(1,ii)
          a(j2)=a(j2)+wa(2,ii)
          a(j3)=a(j3)+wa(3,ii)
        ENDDO
      ENDIF
 
      RETURN
      END