create_setcol_clause.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/.
!||====================================================================
!||    create_setcol_array    ../starter/source/model/sets/create_setcol_clause.F
!||--- called by ------------------------------------------------------
!||    hm_set                 ../starter/source/model/sets/hm_set.F
!||    sort_set               ../starter/source/model/sets/sort_sets.F
!||--- calls      -----------------------------------------------------
!||    create_setcol_list     ../starter/source/model/sets/create_setcol_clause.F
!||    create_setcol_list_g   ../starter/source/model/sets/create_setcol_clause.F
!||--- uses       -----------------------------------------------------
!||    hm_option_read_mod     ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    submodel_mod           ../starter/share/modules1/submodel_mod.f
!||====================================================================
      SUBROUTINE create_setcol_array(SET,SETCOL_ARRAY ,ARRAY_SIZE, 
     .                               ISETCOLM  , NSET_COLLECT,
     .                               JCLAUSE ,OPT_G ,IS_AVAILABLE ,
     .                               LSUBMODEL)
C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Treat the PART Clause, read PARTs from HM_READER & fill clause
C   Calls CREATE_PART_LIST (simple list)
C   Calls CREATE_PART_LIST_G (PART_G : All parts from a MIN to MAX with increment)
C------------------------------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME          DESCRIPTION                         
C
C     CLAUSE        (SET structure) Clause to be treated
C     IPARTM1       MAP Table UID -> LocalID
C     JCLAUSE       parameter with HM_READER (current clause read)
C     Opt_G         Opt_G operator 1 if PART_G is set, 0 else
C     IS_AVAILABLE  Bool / Result of HM_interface
C     LSUBMODEL     SUBMODEL Structure.
C============================================================================
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE setdef_mod
      USE submodel_mod
      USE message_mod
      USE hm_option_read_mod
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 (SET_), DIMENSION(NSETS),INTENT(INOUT) :: SET
      INTEGER JCLAUSE,OPT_G,ARRAY_SIZE,NSET_COLLECT
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSETS,2) :: ISETCOLM
C-----------------------------------------------
      INTEGER SETCOL_ARRAY(*)
      TYPE(submodel_data),INTENT(IN):: LSUBMODEL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
!
        IF (opt_g == 1 ) THEN
             CALL create_setcol_list_g(set,setcol_array, array_size ,isetcolm ,nset_collect ,jclause ,is_available ,lsubmodel)
        ELSE
             CALL create_setcol_list  (set,setcol_array, array_size ,isetcolm ,nset_collect ,jclause ,is_available ,lsubmodel)
        ENDIF
C-----------------------------------------------
      END
!||====================================================================
!||    create_setcol_list          ../starter/source/model/sets/create_setcol_clause.F
!||--- called by ------------------------------------------------------
!||    create_setcol_array         ../starter/source/model/sets/create_setcol_clause.F
!||--- calls      -----------------------------------------------------
!||    hm_get_int_array_2indexes   ../starter/source/devtools/hm_reader/hm_get_int_array_2indexes.F
!||    hm_get_int_array_index      ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
!||    set_usrtos                  ../starter/source/model/sets/ipartm1.F
!||--- uses       -----------------------------------------------------
!||    hm_option_read_mod          ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod                 ../starter/share/message_module/message_mod.F
!||    submodel_mod                ../starter/share/modules1/submodel_mod.f
!||====================================================================
      SUBROUTINE create_setcol_list(
     .               SET,ARRAY, ARRAY_SIZE, ISETCOLM ,NSET_COLLECT ,JCLAUSE ,IS_AVAILABLE ,LSUBMODEL)
C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Create PART Clause from LIST
C------------------------------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME          DESCRIPTION                         
C
C     CLAUSE        (SET structure) Clause to be treated
C     IPARTM1       MAP Table UID -> LocalID
C     JCLAUSE       parameter with HM_READER (current clause read)
C     IS_AVAILABLE  Bool / Result of HM_interface
C     LSUBMODEL     SUBMODEL Structure.
C============================================================================
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE setdef_mod
      USE submodel_mod
      USE message_mod
      USE hm_option_read_mod
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 (SET_), DIMENSION(NSETS),INTENT(INOUT) :: SET
      INTEGER JCLAUSE, ARRAY_SIZE,NSET_COLLECT
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSETS,2) :: ISETCOLM
      INTEGER ARRAY(*)
 
      TYPE(submodel_data),INTENT(IN):: LSUBMODEL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,IDS,NINDX,LIST_SIZE,IDS_MAX,PARTM,SETCOL
      INTEGER IWORK(70000)
!
      INTEGER, ALLOCATABLE, DIMENSION(:) :: PART_READ_TMP,INDEX
C
      INTEGER SET_USRTOS
      EXTERNAL SET_USRTOS
C=======================================================================
 
      array_size=0
 
      CALL hm_get_int_array_index('idsmax' ,ids_max ,jclause,is_available,lsubmodel)
 
      ALLOCATE(part_read_tmp(ids_max))
      part_read_tmp(1:ids_max) = 0
 
      ALLOCATE(index(2*ids_max))
      index = 0
 
      nindx = 0
      list_size = 0
 
      ! Read & convert Part list
      ! -------------------------
      DO i=1,ids_max
         CALL hm_get_int_array_2indexes('ids',ids,jclause,i,is_available,lsubmodel)
!
         setcol = 0
         DO j=1,nset_collect
           IF(isetcolm(j,1)==ids .AND.  set(isetcolm(j,2))%SET_ACTIV==1) THEN
               setcol = isetcolm(j,2)
               EXIT
           ENDIF
           IF(isetcolm(j,1)>ids) EXIT
         ENDDO
 
         
         IF(setcol > 0)THEN                 ! 0 if SET was not found
           nindx=nindx+1                   !   nb of CLAUSE parts
           part_read_tmp(nindx) = setcol
         ENDIF
      ENDDO ! DO K=1,IDS_MAX
 
      ! Sort the Readed PARTs and remove eventual duplicates
      ! ---------------------------------------------------- 
 
      DO i=1,nindx
        index(i) = i
      ENDDO
      CALL my_orders(0,iwork,part_read_tmp,index,nindx,1)
 
      DO i=1,nindx
        array(i)=part_read_tmp(index(i))
      ENDDO
 
      CALL remove_duplicates( array,nindx,list_size)
 
      ! Copy in final SET
      ! ------------------
      array_size = list_size  
      
!---
 
C-------------------------
       DEALLOCATE(part_read_tmp)
       DEALLOCATE(index)
C-------------------------
      RETURN
      END
 
!||====================================================================
!||    create_setcol_list_g        ../starter/source/model/sets/create_setcol_clause.F
!||--- called by ------------------------------------------------------
!||    create_setcol_array         ../starter/source/model/sets/create_setcol_clause.F
!||--- calls      -----------------------------------------------------
!||    hm_get_int_array_2indexes   ../starter/source/devtools/hm_reader/hm_get_int_array_2indexes.F
!||    hm_get_int_array_index      ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
!||    set_usrtos_nearest          ../starter/source/model/sets/ipartm1.F
!||--- uses       -----------------------------------------------------
!||    hm_option_read_mod          ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod                 ../starter/share/message_module/message_mod.F
!||    submodel_mod                ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE create_setcol_list_g(
     .               SET,ARRAY, ARRAY_SIZE,  ISETCOLM, NSET_COLLECT, JCLAUSE ,IS_AVAILABLE ,LSUBMODEL)
C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Create PART Clause from Generation All parts from Min to Max with Increment (Opt_G)
C--------------------------------------------------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME          DESCRIPTION                         
C
C     CLAUSE        (SET structure) Clause to be treated
C     IPARTM1       MAP Table UID -> LocalID
C     JCLAUSE       parameter with HM_READER (current clause read)
C     IS_AVAILABLE  Bool / Result of HM_interface
C     LSUBMODEL     SUBMODEL Structure.
C============================================================================
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE setdef_mod
      USE submodel_mod
      USE message_mod
      USE hm_option_read_mod
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 (SET_), DIMENSION(NSETS),INTENT(INOUT) :: SET
      INTEGER JCLAUSE,ARRAY_SIZE, NSET_COLLECT
      INTEGER ARRAY(ARRAY_SIZE)
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSET_COLLECT,2) :: ISETCOLM
!
      
      TYPE(submodel_data),INTENT(IN):: LSUBMODEL(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,IGS,IDS,NINDX,LIST_SIZE,IDS_MAX,PARTM,GENE_MAX,K,P,P1
      INTEGER START_GENE,END_GENE,INCR_GENE,PSTART,PSTOP,STACK,STACK_ONE,NB_RESULT
      INTEGER IWORK(70000)
      INTEGER SZ_DICHO
!-
      INTEGER, ALLOCATABLE, DIMENSION(:) :: PART_READ_TMP,PART_READ_ONE,IDEX,RESULT
      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: SETCOL_DICHO
C
      INTEGER  SET_USRTOS_NEAREST
      EXTERNAL SET_USRTOS_NEAREST
C=======================================================================
      ALLOCATE(setcol_dicho(nsets,2))
      sz_dicho = 0
      DO i=1,nset_collect
        ids = isetcolm(i,1)
        igs = isetcolm(i,2)
        IF(set(igs)%SET_ACTIV == 1)THEN
           sz_dicho=sz_dicho+1
           setcol_dicho(sz_dicho,1) = ids
           setcol_dicho(sz_dicho,2) = igs
        ENDIF
      ENDDO
 
      CALL hm_get_int_array_index('genemax' ,gene_max ,jclause,is_available,lsubmodel)
 
      ALLOCATE(part_read_tmp(nsets))
      ALLOCATE(part_read_one(nsets))
      ALLOCATE(result(nsets))
 
      stack=0
 
      DO k=1,gene_max
          CALL hm_get_int_array_2indexes('start'  ,start_gene,jclause,k,is_available,lsubmodel)
          CALL hm_get_int_array_2indexes('end'    ,end_gene  ,jclause,k,is_available,lsubmodel)
          CALL hm_get_int_array_2indexes('by'     ,incr_gene ,jclause,k,is_available,lsubmodel)
 
          ! set value by default for increment to 1
          IF (incr_gene == 0) incr_gene = 1
 
          pstart = set_usrtos_nearest(start_gene, setcol_dicho, sz_dicho,1)
          pstop  = set_usrtos_nearest(end_gene,   setcol_dicho, sz_dicho,2)
     
          stack_one=0               ! assemble in PART_READ_ONE Stack_one
          DO p=pstart, pstop
             p1 = setcol_dicho(p,1)
             IF ( mod( p1-start_gene , incr_gene) == 0)THEN
                  stack_one = stack_one+1
                  part_read_one(stack_one) = p
             ENDIF
          ENDDO
 
          IF(stack==0) THEN
 
             part_read_tmp(1:stack_one) = part_read_one(1:stack_one)
             stack=stack_one
 
          ELSE
 
             ! This code will not go if  GENE_MAX == 1 / Result does not need to be allocated
             CALL union_2_sorted_sets( part_read_tmp, stack ,
     *                                 part_read_one, stack_one ,
     *                                 result,        nb_result   )
             part_read_tmp(1:nb_result)=result(1:nb_result)
             stack = nb_result
 
          ENDIF
 
 
      ENDDO
 
      array_size = stack
      array(1:stack) = part_read_tmp(1:stack)
 
      DEALLOCATE (part_read_one)
      DEALLOCATE (part_read_tmp)
      DEALLOCATE (result)
      END
!||====================================================================
!||    create_setcol_clause   ../starter/source/model/sets/create_setcol_clause.F
!||--- calls      -----------------------------------------------------
!||    insert_clause_in_set   ../starter/source/model/sets/insert_clause_in_set.F
!||--- uses       -----------------------------------------------------
!||    set_mod                ../starter/share/modules1/set_mod.F
!||====================================================================
      SUBROUTINE create_setcol_clause(SET,
     *                                SETL,SETL_SIZE,
     *                                CLAUSE,
     *                                IXS       ,IXS10    ,                      IXQ    ,
     *                                IXC       ,IXTG     ,IXT       ,IXP       ,IXR    ,
     *                                                                           SH4TREE,
     .                                SH3TREE   ,KNOD2ELS ,NOD2ELS   ,KNOD2ELC  ,NOD2ELC,
     .                                KNOD2ELTG ,NOD2ELTG ,IPARTC    ,IPARTG    ,IPARTS ,
     .                                IPART     ,OPT_A    ,OPT_O     ,KNOD2ELQ  ,NOD2ELQ,
     .                                X         ,KEYSET   ,OPT_E     ,DELBUF    )
C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Create SET of SET Clause
C--------------------------------------------------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME          DESCRIPTION                         
C
C     SET           (SET structure) SET ARRAY
C     SETL          List of SETs from Clause 
C     SETL_SIZE     Number of SETs from Clause 
C     CLAUSE        (SET structure) clause to fill.
C     
C============================================================================
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE setdef_mod
      USE set_scratch_mod
      USE names_and_titles_mod , ONLY : ncharfield
      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"
#include      "param_c.inc"
#include      "sphcom.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER SETL_SIZE
      INTEGER, DIMENSION(NSETS),    INTENT(IN) :: SETL
      TYPE (SET_),DIMENSION(NSETS), INTENT(IN) :: SET
      TYPE (SET_) :: CLAUSE
      TYPE (SET_SCRATCH) ::  DELBUF
      INTEGER  OPT_A,OPT_O,OPT_E
C
      INTEGER IXS(NIXS,*),IXS10(6,*),
     .        IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),IXT(NIXT,*),
     .        IXP(NIXP,*),IXR(NIXR,*),
     .        SH4TREE(*),SH3TREE(*),KNOD2ELS(*),KNOD2ELC(*),KNOD2ELTG(*),
     .        KNOD2ELQ(*),NOD2ELS(*),NOD2ELC(*),NOD2ELTG(*),NOD2ELQ(*),
     .        IPARTS(*),IPARTC(*),IPARTG(*),IPART(LIPART1,*)
      my_real
     .    x(3,*)
      CHARACTER(LEN=NCHARFIELD) :: KEYSET
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
       INTEGER I,IGS
C-----------------------------------------------
       DO i=1,setl_size
          igs = setl(i)
 
          ! Each from list SET is add in the clause with SET_ADD
          ! The goal is to merge all entities from SET in the clause.
          ! Call to insert_clause_in_set can be used for that...
          CALL insert_clause_in_set(clause    ,set(igs) ,set_add   ,
     *                              ixs       ,ixs10    ,                      ixq    ,
     *                              ixc       ,ixtg     ,ixt       ,ixp       ,ixr    ,
     *                                                                         sh4tree,
     .                              sh3tree   ,knod2els ,nod2els   ,knod2elc  ,nod2elc,
     .                              knod2eltg ,nod2eltg ,ipartc    ,ipartg    ,iparts ,
     .                              ipart     ,opt_a    ,opt_o     ,knod2elq  ,nod2elq,
     .                              x         ,keyset   ,opt_e     ,delbuf    )
C
       ENDDO
C-----------------------------------------------
       END
 
!||====================================================================
!||    create_set_collect     ../starter/source/model/sets/create_setcol_clause.F
!||--- called by ------------------------------------------------------
!||    hm_set                 ../starter/source/model/sets/hm_set.F
!||--- calls      -----------------------------------------------------
!||    insert_clause_in_set   ../starter/source/model/sets/insert_clause_in_set.F
!||--- uses       -----------------------------------------------------
!||    set_mod                ../starter/share/modules1/set_mod.F
!||====================================================================
      SUBROUTINE create_set_collect(SET       ,SET_ID   ,IGS   ,SETCOL_ARRAY ,ARRAY_SIZE,
     *                              IXS       ,IXS10    ,                      IXQ    ,
     *                              IXC       ,IXTG     ,IXT       ,IXP       ,IXR    ,
     *                                                                         SH4TREE,
     *                              SH3TREE   ,KNOD2ELS ,NOD2ELS   ,KNOD2ELC  ,NOD2ELC,
     *                              KNOD2ELTG ,NOD2ELTG ,IPARTC    ,IPARTG    ,IPARTS ,
     *                              IPART     ,OPT_A    ,OPT_O     ,KNOD2ELQ  ,NOD2ELQ,
     *                              X         ,KEYSET   ,OPT_E     ,DELBUF    )
C-----------------------------------------------
C   ROUTINE DESCRIPTION :
C   ===================
C   Create SET of SET Clause
C--------------------------------------------------------------------------------------
C   DUMMY ARGUMENTS DESCRIPTION:
C   ===================
C
C     NAME          DESCRIPTION                         
C
C     SET           (SET structure) SET ARRAY
C     SETL          List of SETs from Clause 
C     SETL_SIZE     Number of SETs from Clause 
C     CLAUSE        (SET structure) clause to fill.
C     
C============================================================================
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE setdef_mod
      USE set_scratch_mod
      USE names_and_titles_mod , ONLY : ncharfield
      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"
#include      "param_c.inc"
#include      "sphcom.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER SET_ID,ARRAY_SIZE ,IGS
      INTEGER  OPT_A,OPT_O,OPT_E
      INTEGER, DIMENSION(ARRAY_SIZE,2),    INTENT(IN) :: SETCOL_ARRAY
      TYPE (SET_),DIMENSION(NSETS), INTENT(INOUT) :: SET
      TYPE (SET_SCRATCH) ::  DELBUF
      INTEGER IXS(NIXS,*),IXS10(6,*),
     .        IXQ(NIXQ,*),IXC(NIXC,*),IXTG(NIXTG,*),IXT(NIXT,*),
     .        ixp(nixp,*),ixr(nixr,*),
     .        sh4tree(*),sh3tree(*),knod2els(*),knod2elc(*),knod2eltg(*),
     .        knod2elq(*),nod2els(*),nod2elc(*),nod2eltg(*),nod2elq(*),
     .        iparts(*),ipartc(*),ipartg(*),ipart(lipart1,*)
      my_real x(3,*)
      CHARACTER(LEN=NCHARFIELD) :: KEYSET
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
       INTEGER I,CUR
C-----------------------------------------------
       DO I=1,array_size
          
          IF(setcol_array(i,1) == set_id .AND. setcol_array(i,2) /= igs) THEN    ! The SET IGS is the active one...
             cur =  setcol_array(i,2)                                             ! Others needs to be merged.
 
 
             ! Each from list SET is add in the clause with SET_ADD
             ! The goal is to merge all entities from SET in the clause.
             ! Call to insert_clause_in_set can be used for that...
             CALL insert_clause_in_set(set(igs)  ,set(cur) ,set_add   ,
     .                                 ixs       ,ixs10    ,                      ixq    ,
     .                                 ixc       ,ixtg     ,ixt       ,ixp       ,ixr    ,
     .                                                                            sh4tree,
     .                                 sh3tree   ,knod2els ,nod2els   ,knod2elc  ,nod2elc,
     .                                 knod2eltg ,nod2eltg ,ipartc    ,ipartg    ,iparts ,
     .                                 ipart     ,opt_a    ,opt_o     ,knod2elq  ,nod2elq,
     .                                 x         ,keyset   ,opt_e     ,delbuf    )
          ENDIF
C
       ENDDO
C-----------------------------------------------
       END