ani_fasolfr.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/.
!||====================================================================
!||    ani_fasolfr1   ../starter/source/output/anim/ani_fasolfr.F
!||--- called by ------------------------------------------------------
!||    lectur         ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    arret          ../starter/source/system/arret.F
!||--- uses       -----------------------------------------------------
!||====================================================================
      SUBROUTINE ani_fasolfr1(IXS ,IXC     ,IXTG    ,FASTAG, ISOLNOD)
      use element_mod , only : nixs,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      "com01_c.inc"
#include      "com04_c.inc"
#include      "units_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER  
     .   IXS(NIXS,*),IXC(NIXC,*),IXTG(NIXTG,*),
     .   FASTAG(*),ISOLNOD(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: NELENOD
      INTEGER, DIMENSION(:), ALLOCATABLE :: ELSNOD,ELCNOD,ELTGNOD,
     .                                      NODTAG,NODTAG_1
      INTEGER N,NI,I,J,K,II,JJ,KK,LL,NN,JS,KS,
     .        IERROR
      INTEGER FACES(4,6),PWR(7)
      DATA faces/1,2,3,4,
     .           2,1,5,6,
     .           1,5,8,4,
     .           5,6,7,8,
     .           3,4,8,7,
     .           2,6,7,3/
      DATA pwr/1,2,4,8,16,32,64/
C     REAL
C-----------------------------------------------
C
      ALLOCATE(nodtag(numnod), stat=ierror)
      IF (ierror/=0) THEN
        WRITE(istdo,'(A)') ' ANIM ...'
        WRITE(istdo,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY'
        WRITE(iout,'(A)') ' ANIM ...'
        WRITE(iout,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY NODTAG'
        CALL arret(2)
      END IF
      ALLOCATE(nodtag_1(numnod), stat=ierror)
      IF (ierror/=0) THEN
        WRITE(istdo,'(A)') ' ANIM ...'
        WRITE(istdo,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY'
        WRITE(iout,'(A)') ' ANIM ...'
        WRITE(iout,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY NODTAG_1'
        CALL arret(2)
      END IF
      ALLOCATE(nelenod(3,numnod+1), stat=ierror)
      IF (ierror/=0) THEN
        WRITE(istdo,'(A)') ' ANIM ...'
        WRITE(istdo,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY'
        WRITE(iout,'(A)') ' ANIM ...'
        WRITE(iout,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY NELENOD'
        CALL arret(2)
      END IF
      ALLOCATE(elsnod(8*numels), stat=ierror)
      IF (ierror/=0) THEN
        WRITE(istdo,'(A)') ' ANIM ...'
        WRITE(istdo,'(A)')
     .     ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY'
        WRITE(iout,'(A)') ' ANIM ...'
        WRITE(iout,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY ELSNOD'
        CALL arret(2)
      END IF
      ALLOCATE(elcnod(4*numelc), stat=ierror)
      IF (ierror/=0) THEN
        WRITE(istdo,'(A)') ' ANIM ...'
        WRITE(istdo,'(A)')
     .     ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY'
        WRITE(iout,'(A)') ' ANIM ...'
        WRITE(iout,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY ELCNOD'
        CALL arret(2)
      END IF
      ALLOCATE(eltgnod(3*numeltg), stat=ierror)
      IF (ierror/=0) THEN
        WRITE(istdo,'(A)') ' ANIM ...'
        WRITE(istdo,'(A)')
     .     ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY'
        WRITE(iout,'(A)') ' ANIM ...'
        WRITE(iout,'(A)')
     .    ' UNABLE TO ALLOCATE MEMORY FOR WORK ARRAY ELTGNOD'
        CALL arret(2)
      END IF
C
      DO n=1,numels
        fastag(n)=0
      END DO
C
      DO n=1,numnod+1
        nelenod(1,n)=0
        nelenod(2,n)=0
        nelenod(3,n)=0
      END DO
C
C     node -> solid
      DO n=1,numels
        DO i=1,8
          ni=ixs(i+1,n)
          nodtag_1(ni) = 0
        ENDDO
        DO i=1,8
          ni=ixs(i+1,n)
          IF (nodtag_1(ni) == 0) nelenod(1,ni+1)=nelenod(1,ni+1)+1
          nodtag_1(ni) = 1
        END DO
      END DO
C
      DO n=1,numnod
        nelenod(1,n+1)=nelenod(1,n+1)+nelenod(1,n)
      END DO
C
      DO n=1,numels
        DO i=1,8
          ni=ixs(i+1,n)
          nodtag_1(ni) = 0
        ENDDO
        DO i=1,8
          ni=ixs(i+1,n)
          IF (nodtag_1(ni) == 0) THEN
            nelenod(1,ni)=nelenod(1,ni)+1
            elsnod(nelenod(1,ni))=n
            nodtag_1(ni) = 1
          ENDIF
        END DO
      END DO
C
      DO n=numnod,1,-1
        nelenod(1,n+1)=nelenod(1,n)
      END DO
      nelenod(1,1)=0
C
C     node -> 4node shell
      DO n=1,numelc
        DO i=1,4
          ni=ixc(i+1,n)
          nelenod(2,ni+1)=nelenod(2,ni+1)+1
        END DO
      END DO
C
      DO n=1,numnod
        nelenod(2,n+1)=nelenod(2,n+1)+nelenod(2,n)
      END DO
C
      DO n=1,numelc
        DO i=1,4
          ni=ixc(i+1,n)
          nelenod(2,ni)=nelenod(2,ni)+1
          elcnod(nelenod(2,ni))=n
        END DO
      END DO
C
      DO n=numnod,1,-1
        nelenod(2,n+1)=nelenod(2,n)
      END DO
      nelenod(2,1)=0
C
C     node -> 3node shell
      DO n=1,numeltg
        DO i=1,3
          ni=ixtg(i+1,n)
          nelenod(3,ni+1)=nelenod(3,ni+1)+1
        END DO
      END DO
C
      DO n=1,numnod
        nelenod(3,n+1)=nelenod(3,n+1)+nelenod(3,n)
      END DO
C
      DO n=1,numeltg
        DO i=1,3
          ni=ixtg(i+1,n)
          nelenod(3,ni)=nelenod(3,ni)+1
          eltgnod(nelenod(3,ni))=n
        END DO
      END DO
C
      DO n=numnod,1,-1
        nelenod(3,n+1)=nelenod(3,n)
      END DO
      nelenod(3,1)=0
C
      DO n=1,numnod
        DO j=nelenod(1,n)+1,nelenod(1,n+1)
          js=elsnod(j)
          DO k=nelenod(1,n)+1,nelenod(1,n+1)
           IF(k/=j)THEN
            DO ii=1,8
              IF(ixs(ii+1,js)/=0) nodtag(ixs(ii+1,js))=0
            END DO
            ks=elsnod(k)
            DO ii=1,8
              ni=ixs(ii+1,ks)
              nodtag_1(ni) = 0
            ENDDO
            DO ii=1,8
              ni=ixs(ii+1,ks)
              IF (nodtag_1(ni) == 0) THEN
                nodtag(ixs(ii+1,ks))=nodtag(ixs(ii+1,ks))+1
                nodtag_1(ni) = 1
              ENDIF
            END DO
            nn=0
            DO jj=1,6
              ll=fastag(js)
              IF(mod(ll,pwr(jj+1))/pwr(jj)==0)THEN
                nn=0
                DO kk=1,4
            IF(ixs(faces(kk,jj)+1,js)/=0) 
     .              nn=nn+nodtag(ixs(faces(kk,jj)+1,js))
                END DO
                IF(nn == 4)THEN
C                 Factag (JS) Less Face JJ
                  fastag(js)=fastag(js)+pwr(jj)
                END IF
              END IF
            END DO
           END IF
          END DO
C
          DO k=nelenod(2,n)+1,nelenod(2,n+1)
            DO ii=1,8
              IF(ixs(ii+1,js)/=0) nodtag(ixs(ii+1,js))=0
            END DO
            ks=elcnod(k)
            DO ii=1,4
              IF(ixc(ii+1,ks)/=0) 
     .          nodtag(ixc(ii+1,ks))=nodtag(ixc(ii+1,ks))+1
            END DO
            nn=0
            DO jj=1,6
              ll=fastag(js)
              IF(mod(ll,pwr(jj+1))/pwr(jj)==0)THEN
                nn=0
                DO kk=1,4
            IF(ixs(faces(kk,jj)+1,js)/=0) 
     .              nn=nn+nodtag(ixs(faces(kk,jj)+1,js))
                END DO
                IF(nn==4)THEN
C                 Factag (JS) Less Face JJ
                  fastag(js)=fastag(js)+pwr(jj)
                END IF
              END IF
            END DO
          END DO
C
          DO k=nelenod(3,n)+1,nelenod(3,n+1)
            DO ii=1,8
              IF(ixs(ii+1,js)/=0) nodtag(ixs(ii+1,js))=0
            END DO
            ks=eltgnod(k)
            DO ii=1,4
              IF(ixtg(ii+1,ks)/=0) 
     .          nodtag(ixtg(ii+1,ks))=nodtag(ixtg(ii+1,ks))+1
            END DO
            nn=0
            DO jj=1,6
              ll=fastag(js)
              IF(mod(ll,pwr(jj+1))/pwr(jj)==0)THEN
                nn=0
                DO kk=1,4
            IF(ixs(faces(kk,jj)+1,js)/=0) 
     .              nn=nn+nodtag(ixs(faces(kk,jj)+1,js))
                END DO
                IF(nn==4)THEN
C                 Factag (JS) Less Face JJ
                  fastag(js)=fastag(js)+pwr(jj)
                END IF
              END IF
            END DO
          END DO
        END DO
      END DO
C
      nfasolfr=0
      DO n=1,numels
        ll=fastag(n)
        DO jj=1,6
          IF(mod(ll,pwr(jj+1))/pwr(jj)==0)THEN
            nfasolfr=nfasolfr+1
C            FASOLFR(1,NFASOLFR)=N
C            FASOLFR(2,NFASOLFR)=JJ
          END IF
        END DO
      END DO    
      DEALLOCATE(eltgnod, elcnod, elsnod, nelenod,nodtag,nodtag_1)
C     
      RETURN
      END
!||====================================================================
!||    ani_fasolfr2   ../starter/source/output/anim/ani_fasolfr.F
!||--- called by ------------------------------------------------------
!||    lectur         ../starter/source/starter/lectur.F
!||====================================================================
      SUBROUTINE ani_fasolfr2(FASTAG  ,FASOLFR, ISOLNOD )
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"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER  
     .   FASTAG(*), FASOLFR(2,*), ISOLNOD(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N,JJ,LL
      INTEGER PWR(7)
      DATA pwr/1,2,4,8,16,32,64/
C     REAL
C-----------------------------------------------
C
      nfasolfr=0
      DO n=1,numels
       ll=fastag(n)
        DO jj=1,6
          IF(mod(ll,pwr(jj+1))/pwr(jj)==0)THEN
            nfasolfr=nfasolfr+1
            fasolfr(1,nfasolfr)=n
            fasolfr(2,nfasolfr)=jj
          END IF
        END DO
      END DO    
      RETURN
      END