sort_sets.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	sort_set (lsubmodel, map_tables, set_list, set, clause)

Function/Subroutine Documentation

sort_set()

subroutine sort_set	(	type(submodel_data), dimension(*), intent(in)	lsubmodel,
		type(mapping_struct_)	map_tables,
		integer, dimension(nsets)	set_list,
		type (set_), dimension(nsets), intent(inout)	set,
		type (set_)	clause )

Definition at line 44 of file sort_sets.F.

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, T, ID
      INTEGER SET_ID, ISET_TYPE, CLAUSES_MAX, 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
      
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.
                 
                
.AND.                 IF( ID == SET_ID  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()