sort_sets.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/.
!||====================================================================
!||    sort_set                 ../starter/source/model/sets/sort_sets.F
!||--- called by ------------------------------------------------------
!||    hm_set                   ../starter/source/model/sets/hm_set.F
!||--- calls      -----------------------------------------------------
!||    arret                    ../starter/source/system/arret.F
!||    create_set_array         ../starter/source/model/sets/create_set_clause.F
!||    create_setcol_array      ../starter/source/model/sets/create_setcol_clause.F
!||    hm_get_int_array_index   ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
!||    hm_get_intv              ../starter/source/devtools/hm_reader/hm_get_intv.F
!||    hm_get_string            ../starter/source/devtools/hm_reader/hm_get_string.F
!||    hm_get_string_index      ../starter/source/devtools/hm_reader/hm_get_string_index.F
!||    hm_option_read_key       ../starter/source/devtools/hm_reader/hm_option_read_key.F
!||    hm_option_start          ../starter/source/devtools/hm_reader/hm_option_start.F
!||    set_merge_simple         ../starter/source/model/sets/set_merge_simple.F
!||--- uses       -----------------------------------------------------
!||    hm_option_read_mod       ../starter/share/modules1/hm_option_read_mod.F
!||    mapping_option_mod       ../starter/share/modules1/dichotomy_mod.F
!||    set_mod                  ../starter/share/modules1/set_mod.F
!||    submodel_mod             ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE sort_set (LSUBMODEL ,MAP_TABLES, SET_LIST ,SET,CLAUSE)
C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Main Routine to Sort SETs according to their dependencies (/SET of /SET)
C   If a SET has SET clause (child SETs), ensure that those are treated before.
C
C   All Sets are parsed to find Child Sets, fill a Graph with SET & Childs 
C   Go through the Graph to generate the list
C-----------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME          DESCRIPTION                         
C     LSUBMODEL     SUBMODEL Structure
C     MAP_TABLES    Mapping table structure
C     SET_LIST      List of sorted SETs
C     SET           SET Structure / ACTIV Flag will be defined for /SET/COLLECT
C===========================================================================================
C-----------------------------------------------
C   D e f i n i t i o n s 
C-----------------------------------------------
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE submodel_mod
      USE hm_option_read_mod
      USE setdef_mod
      USE mapping_option_mod
      USE names_and_titles_mod , ONLY : nchartitle, ncharfield, ncharkey, ncharline
      USE set_mod , ONLY : set_add
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-----------------------------------------------
      TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
      TYPE(mapping_struct_) :: MAP_TABLES
      TYPE (SET_), DIMENSION(NSETS),INTENT(INOUT) :: SET
      INTEGER SET_LIST(NSETS)
      TYPE (SET_) ::  CLAUSE
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER IGS,IGS2,ID1,ID2,IG,I,J,SET_CLAUSE_SIZE,SET_ARRAY_SIZE,NEW_SIZE,IERROR,S,T,ID
      INTEGER SET_ID,ISET_TYPE,CLAUSES_MAX,ITMP,ICODE,NCOLLECT,SETCOL_ARRAY_SIZE
      INTEGER OPT_D,OPT_O,OPT_G,OPT_B,OPT_A,OPT_E,OPT_I,OPT_C
      INTEGER IDEBUG
      LOGICAL IS_AVAILABLE
      INTEGER, DIMENSION(:),ALLOCATABLE  :: SET_ARRAY,SET_CLAUSE_ARRAY,RESULT,SETCOL_ARRAY
      INTEGER, DIMENSION(:),ALLOCATABLE  :: COLLECT_LIST,IS_COLLECT
      INTEGER CLAUSE_OPERATOR
      
C-----------------------------------------------
C     Characters
      CHARACTER MESS*40
      CHARACTER(LEN=NCHARFIELD) :: KEYSET,SET_TYPE,KEY_TYPE
      CHARACTER(LEN=NCHARTITLE) :: TITLE,TITLE2,SET_TITLE
      CHARACTER(LEN=NCHARKEY) :: KEYPART,KEY
C-----------------------------------------------
      idebug=0
 
      IF (idebug == 1)THEN
         print*,' ' 
         print*,' ' 
         print*,' -----------------------------------------------'
         print*,'  SORTING SETS'
         print*,' -----------------------------------------------'
         print*,' ' 
      ENDIF
 
      ALLOCATE(set_array(nsets))
      ALLOCATE(setcol_array(nsets))
      ALLOCATE(set_clause_array(nsets))
      ALLOCATE(is_collect(nsets))
      ALLOCATE(result(nsets))
      ALLOCATE(collect_list(map_tables%NSET_COLLECT))
      
 
      !-------------------------------------------------
      ! SET%IS_ACTIVE & /SET/COLLECT
      ! ----------------------------
      ! Loops to define which set is active
      ! In /SET/COLLECT only one SET of the SERIES is active
      ! And assembled by the others.
      ! All secondary SETs needs to be treated before the 
      ! the active SET. 
      ! /SET/GENERAL : all SETs are active
      !-------------------------------------------------
 
      DO igs=1,nsets
        set(igs)%SET_ACTIV=-1
        is_collect(igs)=0
      ENDDO
      
      IF (map_tables%NSET_COLLECT > 0)THEN
 
        igs = map_tables%ISETCOLM(1,2)
        is_collect(igs)=1
        set(igs)%SET_ACTIV=1
        
        DO i=2,map_tables%NSET_COLLECT
           igs = map_tables%ISETCOLM(i,2)
           igs2 = map_tables%ISETCOLM(i-1,2)
 
           id1 = map_tables%ISETCOLM(i,1)
           id2 = map_tables%ISETCOLM(i-1,1)
 
           is_collect(igs)=1
           IF(id1 /= id2) THEN
             set(igs)%SET_ACTIV=1
           ELSE
             set(igs)%SET_ACTIV=0
           ENDIF
        ENDDO
      ENDIF 
      DO igs=1,nsets
         IF(is_collect(igs) == 0) set(igs)%SET_ACTIV=1
      ENDDO     
      !-------------------------------------------------
    
      CALL hm_option_start('/SET')
 
      DO igs=1,nsets
        
        set_array_size=0
 
        CALL hm_option_read_key (lsubmodel,
     .                           option_id   = set_id,
     .                           option_titr = set_title,
     .                           keyword2    = key)
 
 
        CALL hm_get_string('set_Type' , set_type ,ncharfield, is_available)
        CALL hm_get_intv  ('iset_Type', iset_type,is_available,lsubmodel)
 
        CALL hm_get_intv('clausesmax',clauses_max,is_available,lsubmodel)
 
 
 
 
          !  Parse all clauses find SET clauses 
          ! -------------------------
          DO j=1,clauses_max  ! max KEY's of the current /SET
             CALL hm_get_string_index('KEY_type', keyset, j, ncharline, is_available)
  
             CALL hm_get_int_array_index('opt_D',opt_d,j,is_available,lsubmodel)
             CALL hm_get_int_array_index('opt_O',opt_o,j,is_available,lsubmodel)
             CALL hm_get_int_array_index('opt_G',opt_g,j,is_available,lsubmodel)
             CALL hm_get_int_array_index('opt_B',opt_b,j,is_available,lsubmodel)
             CALL hm_get_int_array_index('opt_A',opt_a,j,is_available,lsubmodel) 
             CALL hm_get_int_array_index('opt_E',opt_e,j,is_available,lsubmodel)
             CALL hm_get_int_array_index('opt_I',opt_i,j,is_available,lsubmodel)
             CALL hm_get_int_array_index('opt_C',opt_c,j,is_available,lsubmodel)
 
           
             IF(trim(keyset) == 'SET' )THEN
  
              !  get the list of SETs for the current clause
              ! ---------------------------------------------
               set_clause_size = 0
               CALL create_set_array(set_clause_array  , set_clause_size, 
     .                               map_tables%ISETM  , map_tables%NSET_GENERAL,
     .                               j  ,opt_g ,is_available ,
     .                               lsubmodel,clause,0)              
 
               IF( set_clause_size > 0 ) THEN
  
                 new_size = 0
                 CALL set_merge_simple( set_array       , set_array_size  ,
     *                                  set_clause_array, set_clause_size ,
     *                                  result          , new_size        ,
     *                                  set_add )
 
                 set_array(1:new_size) = result(1:new_size)
                 set_array_size = new_size
               ENDIF
 
             ELSEIF (trim(keyset) == 'SETCOL' )THEN
                CALL create_setcol_array(set,setcol_array,setcol_array_size  ,
     *                                   map_tables%ISETCOLM,map_tables%NSET_COLLECT,
     *                                   j,opt_g ,is_available ,
     *                                   lsubmodel) 
 
                IF(setcol_array_size > 0 ) THEN
  
                 new_size = 0
                 CALL set_merge_simple( set_array       , set_array_size    ,
     *                                  setcol_array    , setcol_array_size ,
     *                                  result          , new_size        ,
     *                                  set_add )
 
                 set_array(1:new_size) = result(1:new_size)
                 set_array_size = new_size
               ENDIF
 
                
             ENDIF 
 
 
          ENDDO           ! DO J=1,CLAUSES_MAX
 
 
          IF(trim(key) == 'COLLECT')THEN                 ! SET COLLECT - find all other SETs with Same ID. 
 
            IF (set(igs)%SET_ACTIV==1 ) THEN
 
              DO j=1,map_tables%NSET_COLLECT             ! Find all SET with same ID but "inactive" / set them as dependent from this SET.
 
                 id = map_tables%ISETCOLM(j,1)
                 ig = map_tables%ISETCOLM(j,2)
 
                 IF (id > set_id) EXIT                   ! ISETCOLM is sorted by UID, when ID is greater we have finished.
                 
                
                 IF( id == set_id .AND. set(ig)%SET_ACTIV==0)THEN      
                    set_array_size = set_array_size + 1
                    set_array(set_array_size)=ig
                 ENDIF
 
              ENDDO
            ENDIF
 
          ENDIF
 
        IF (idebug == 1)THEN
             WRITE(6,'(A,I8,A,I8,A,I8)') 'SET ',set_id,'-> ',igs,' Number of Child list : ',set_array_size
             WRITE(6,'(A, 100I8)') 'Child List      ',( set_array(t), t=1,set_array_size)
             WRITE(6,'(A)') ' ' 
         ENDIF
 
         ! Create an Edge in the Dependency Graph
         CALL set_graph_add_set ( igs, set_array, set_array_size) 
           
 
      ENDDO
 
      !  ALL Edges are done
      ! --------------------
      CALL set_graph_sort ( set_list , ierror)
      
      IF (ierror < 0) THEN
         print*,'ERROR CIRCULAR DEPENDENCY ON SET ',-ierror
         CALL arret(2)
      ENDIF
 
      IF (idebug == 1)THEN
         print*,' ' 
         print*,' -----------------------------------------------'
         WRITE(6,'(A)') 'SORTED SETS'
         print*,set_list(1:nsets)
         print*,' ' 
         print*,' -----------------------------------------------'
         print*,' ' 
      ENDIF
 
      CALL set_graph_clean()
 
      END