w_cluster.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/.
!||====================================================================
!||    w_cluster     ../engine/source/output/cluster/w_cluster.F
!||--- called by ------------------------------------------------------
!||    wrrestp       ../engine/source/output/restart/wrrestp.F
!||--- calls      -----------------------------------------------------
!||    write_db      ../common_source/tools/input_output/write_db.F
!||    write_i_c     ../common_source/tools/input_output/write_routtines.c
!||--- uses       -----------------------------------------------------
!||    cluster_mod   ../engine/share/modules/cluster_mod.F
!||====================================================================
      SUBROUTINE w_cluster(CLUSTER)
C-----------------------------------------------
C  Description:
C        -IN: Array of CLUSTER structures 
C        -OUT: nothing
C  Writes the structure into the restart file
C  (reading done READ_CLUSTER)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE cluster_mod
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      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE (CLUSTER_) ,DIMENSION(NCLUSTER) :: CLUSTER
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
      INTEGER I, J,K, IEL, NEL,NELG, NNOD
      INTEGER II,IFAIL,ITY,ID,RL,IL
      INTEGER ILCLUSTER(NCLUSTER),RLCLUSTER(NCLUSTER)
      INTEGER RLCLUSTER_MAX,ILCLUSTER_MAX
      my_real,
     .   DIMENSION(:), ALLOCATABLE :: rcltab  
      INTEGER, DIMENSION(:), ALLOCATABLE :: ICLTAB
C=======================================================================
 
      IF(ncluster > 0) THEN
        ilcluster(1:ncluster)  = 0 
        rlcluster(1:ncluster) =  zero
      ENDIF
      rlcluster_max = 0
      ilcluster_max = 0
   
      DO i = 1, ncluster
        ity   = cluster(i)%TYPE
        nel   = cluster(i)%NEL
        nnod  = cluster(i)%NNOD
        ifail = cluster(i)%IFAIL
        ilcluster(i) = 8 + 2 * (nel + nnod)
        rlcluster(i) = 1 
        IF (ifail > 0) rlcluster(i) = rlcluster(i) + 4 
        IF (ifail == 3) rlcluster(i) = rlcluster(i) + 8  
        IF ( rlcluster_max < rlcluster(i) ) THEN 
          rlcluster_max = rlcluster(i)
        ENDIF 
        IF ( ilcluster_max < ilcluster(i) ) THEN 
          ilcluster_max = ilcluster(i)
        ENDIF 
      ENDDO !NCLUSTER
 
      IF(ncluster > 0) THEN
        CALL write_i_c(ilcluster,ncluster)
        CALL write_i_c(rlcluster,ncluster)
        ALLOCATE (icltab(ilcluster_max)) ! Integer CLuster TABle
        ALLOCATE (rcltab(rlcluster_max)) ! Real CLuster TABle
      ENDIF
 
      DO i = 1, ncluster
        icltab(1:ilcluster(i)) = 0 
        rcltab(1:rlcluster(i)) = zero
        il = 0
        rl = 0
        icltab(il+1) = cluster(i)%ID
        icltab(il+2) = cluster(i)%TYPE
        icltab(il+3) = cluster(i)%IFAIL
        icltab(il+4) = cluster(i)%IGR
        icltab(il+5) = cluster(i)%NEL
        icltab(il+6) = cluster(i)%NNOD
        icltab(il+7) = cluster(i)%SKEW 
        icltab(il+8) = cluster(i)%OFF
        il = il + 8
        rcltab(rl+1) = cluster(i)%FAIL
        rl = rl + 1
        nel  = cluster(i)%NEL
        nnod = cluster(i)%NNOD
c
        DO j = 1,nel
          id = cluster(i)%ELEM(j)
          icltab(il + j)     = cluster(i)%NG(j) !element local group number
          icltab(il + j+nel) = id ! element index in the group
        ENDDO  ! J = 1,NEL
c
        il = il + nel*2      
        DO j = 1,nnod
          icltab(il + j)      = cluster(i)%NOD1(j)
          icltab(il + j+nnod) = cluster(i)%NOD2(j)
        ENDDO
 
        il = il + nnod*2      
        IF (cluster(i)%IFAIL > 0) THEN
          rcltab(rl + 1) = cluster(i)%FMAX(1)
          rcltab(rl + 2) = cluster(i)%FMAX(2)
          rcltab(rl + 3) = cluster(i)%MMAX(1)
          rcltab(rl + 4) = cluster(i)%MMAX(2)
          rl = rl + 4     
        ENDIF
 
        IF (cluster(i)%IFAIL == 3) THEN
          rcltab(rl + 1) = cluster(i)%AX(1)
          rcltab(rl + 2) = cluster(i)%AX(2)
          rcltab(rl + 3) = cluster(i)%AX(3)
          rcltab(rl + 4) = cluster(i)%AX(4)
          rcltab(rl + 5) = cluster(i)%NX(1)
          rcltab(rl + 6) = cluster(i)%NX(2)
          rcltab(rl + 7) = cluster(i)%NX(3)
          rcltab(rl + 8) = cluster(i)%NX(4)
        ENDIF
 
        CALL write_db(rcltab,rlcluster(i))
        CALL write_i_c(icltab,ilcluster(i))
 
      ENDDO  !  I = 1, NCLUSTER
 
      IF(ncluster > 0) THEN
        DEALLOCATE (rcltab)
        DEALLOCATE (icltab)
      ENDIF
 
 
C-----------
      RETURN
      END