parsor.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/.
!||====================================================================
!||    parsor        ../starter/source/output/anim/parsor.f
!||--- called by ------------------------------------------------------
!||    dd_ani        ../starter/source/output/anim/dd_ani.F
!||--- calls      -----------------------------------------------------
!||    facnor        ../starter/source/output/anim/facnor.F
!||    facnor2       ../starter/source/output/anim/facnor.F
!||--- uses       -----------------------------------------------------
!||====================================================================
      SUBROUTINE parsor(X    ,D    ,XNORM ,IADD ,CDG  ,
     .                  BUFEL,IPARG,IXS   ,IXQ  ,IXC  ,
     .                  IXTG ,IXT  ,IXP   ,IXR  ,INVERT,
     .                  KXSP ,IXSP  )
      use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,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      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "sphcom.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      my_real
     .        x(*),d(*),xnorm(3,*),cdg(*),bufel(*)
      INTEGER IADD(*),IPARG(NPARG,*), 
     .        ixs(nixs,*),ixq(nixq,*),ixc(nixc,*),ixtg(nixtg,*),
     .        ixt(nixt,*),ixp(nixp,*),ixr(nixr,*),
     .        invert(*),kxsp(nisp,*), ixsp(kvoisph,*)
C-----------------------------------------------
C     REAL
      my_real
     .   off
      INTEGER II(4),IE,NG, ITY, LFT, LLT, KPT, N, I, J, N1, N2,
     .        ipid, nel, iad, npar, nft, imid,ialel, mtn
      INTEGER PROC, P, jj
C-----------------------------------------------
C     NORMALE
C-----------------------------------------------
      DO 5 i=1,numnod
      DO 5 j=1,3
       xnorm(j,i) = zero
 5    CONTINUE
      ie = 0
C-----------------------------------------------
C     MID
C-----------------------------------------------
      npar = 0
C
C-----------------------------------------------
C       PART DU DOMAINE DECOMPOSITION
C-----------------------------------------------
C
      DO proc = 1, nspmd
        npar = npar + 1
        DO 800 ng=1,ngroup
        mtn   =iparg(1,ng)
        nel   =iparg(2,ng)
        nft   =iparg(3,ng)
        iad   =iparg(4,ng)
        ity   =iparg(5,ng)
        p     =iparg(32,ng)+1
        lft=1
        llt=nel
C  test if proc must process this group
        IF (p/=proc) GOTO 790
C-----------------------------------------------
C       SOLID 8N
C-----------------------------------------------
        IF(ity==1)THEN
         ialel=iparg(7,ng)+iparg(11,ng)
         IF(ialel==0)THEN
         DO 610 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I-1)
C         IF(OFF==0.)GOTO 610
             ii(1) = ixs(3,n)
             ii(2) = ixs(2,n)
             ii(3) = ixs(5,n)
             ii(4) = ixs(4,n)
             CALL facnor2(x,ii,xnorm,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ii(1) = ixs(6,n)
             ii(2) = ixs(7,n)
             ii(3) = ixs(8,n)
             ii(4) = ixs(9,n)
             CALL facnor2(x,ii,xnorm,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ii(1) = ixs(2,n)
             ii(2) = ixs(3,n)
             ii(3) = ixs(7,n)
             ii(4) = ixs(6,n)
             CALL facnor2(x,ii,xnorm,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ii(1) = ixs(4,n)
             ii(2) = ixs(5,n)
             ii(3) = ixs(9,n)
             ii(4) = ixs(8,n)
             CALL facnor2(x,ii,xnorm,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ii(1) = ixs(3,n)
             ii(2) = ixs(4,n)
             ii(3) = ixs(8,n)
             ii(4) = ixs(7,n)
             CALL facnor2(x,ii,xnorm,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ii(1) = ixs(6,n)
             ii(2) = ixs(9,n)
             ii(3) = ixs(5,n)
             ii(4) = ixs(2,n)
             CALL facnor2(x,ii,xnorm,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ie = ie + 6
 610     CONTINUE
         ENDIF
C-----------------------------------------------
C       QUAD
C-----------------------------------------------
        ELSEIF(ity==2)THEN
         DO 620 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I-1)
C         IF(OFF==0.)GOTO 620
             ii(1) = ixq(2,n)
             ii(2) = ixq(3,n)
             ii(3) = ixq(4,n)
             ii(4) = ixq(5,n)
             xnorm(1,ii(1)) = one
             xnorm(2,ii(1)) = zero
             xnorm(3,ii(1)) = zero
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             invert(n) = 1
             CALL write_i_c(ii,4)
             ie = ie + 1
 620     CONTINUE
C-----------------------------------------------
C       COQUES
C-----------------------------------------------
        ELSEIF(ity==3)THEN
         kpt   =iparg(6,ng)
         DO 630 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I+16*NEL-1)
C         IF(OFF==0.)GOTO 630
             ii(1) = ixc(2,n)
             ii(2) = ixc(3,n)
             ii(3) = ixc(4,n)
             ii(4) = ixc(5,n)
             CALL facnor(x,d,ii,xnorm,cdg,invert(n))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ie = ie + 1
 630     CONTINUE
C-----------------------------------------------
C       TRUSS
C-----------------------------------------------
        ELSEIF(ity==4)THEN
         DO 640 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I-1)
C         IF(OFF==0.)GOTO 640
             ii(1) = ixt(2,n)-1
             ii(2) = ixt(3,n)-1
             ii(3) = ixt(3,n)-1
             ii(4) = ixt(2,n)-1
             invert(n) = 0
             CALL write_i_c(ii,4)
             ie = ie + 1
 640     CONTINUE
C-----------------------------------------------
C       POUTRES
C-----------------------------------------------
        ELSEIF(ity==5)THEN
         DO 650 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I-1)
C         IF(OFF==0.)GOTO 650
             ii(1) = ixp(2,n)-1
             ii(2) = ixp(3,n)-1
             ii(3) = ixp(3,n)-1
             ii(4) = ixp(2,n)-1
             invert(n) = 0
             CALL write_i_c(ii,4)
             ie = ie + 1
 650     CONTINUE
C-----------------------------------------------
C       RESSORTS
C-----------------------------------------------
        ELSEIF(ity==6)THEN
         DO 660 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I-1)
C         IF(OFF==0.)GOTO 660
             ii(1) = ixr(2,n)-1
             ii(2) = ixr(3,n)-1
             IF(mtn==3)THEN
               ii(3) = ixr(4,n)-1
               ii(4) = ixr(3,n)-1
             ELSE
               ii(3) = ixr(3,n)-1
               ii(4) = ixr(2,n)-1
             ENDIF
             invert(n) = 0
             CALL write_i_c(ii,4)
             ie = ie + 1
 660     CONTINUE
C-----------------------------------------------
C       COQUES 3 NOEUDS
C-----------------------------------------------
        ELSEIF(ity==7)THEN
         kpt   =iparg(6,ng)
         DO 670 i=lft,llt
          n = i + nft
C         OFF = BUFEL(IAD+I+16*NEL-1)
C         IF(OFF==0.)GOTO 670
             ii(1) = ixtg(2,n)
             ii(2) = ixtg(3,n)
             ii(3) = ixtg(4,n)
             ii(4) = ii(3)
             CALL facnor(x,d,ii,xnorm,cdg,invert(n+numelc))
             ii(1) = ii(1)-1
             ii(2) = ii(2)-1
             ii(3) = ii(3)-1
             ii(4) = ii(4)-1
             CALL write_i_c(ii,4)
             ie = ie + 1
 670     CONTINUE
C-----------------------------------------------
C       SPH Particules
C-----------------------------------------------
        ELSEIF(ity==51)THEN
C Ditto beam for visualization of Domdec Sph
          DO i=lft,llt
             n = i + nft
             n1 = kxsp(3,n)
C We take the first 12 neighboring cells
             DO jj = 1,min(12,kxsp(4,n))
               n2 = ixsp(jj,n) 
               IF(n1<n2)THEN
                 ii(1) = n1-1
                 ii(2) = n2-1
                 ii(3) = n2-1
                 ii(4) = n1-1
                 invert(n) = 0
                 CALL write_i_c(ii,4)
                 ie = ie + 1
               ENDIF
             ENDDO
          END DO
        ELSE
        ENDIF
 790    CONTINUE
 800   CONTINUE
C-----------------------------------------------
C       PART ADRESS
C-----------------------------------------------
       iadd(npar) = ie
      END DO
C
      RETURN
      END