create_subs_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_subs_clause   ../starter/source/model/sets/create_subs_clause.F
!||--- called by ------------------------------------------------------
!||    hm_set               ../starter/source/model/sets/hm_set.F
!||--- calls      -----------------------------------------------------
!||    create_subs_list     ../starter/source/model/sets/create_subs_clause.F
!||    create_subs_list_g   ../starter/source/model/sets/create_subs_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_subs_clause(
     .                        CLAUSE   ,ISUBSM  ,JCLAUSE ,OPT_G ,IS_AVAILABLE ,
     .                        LSUBMODEL,SUBSET  )
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     ISUBSM        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
      USE groupdef_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-----------------------------------------------
      INTEGER JCLAUSE,OPT_G
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSUBS,2) :: ISUBSM
C-----------------------------------------------
      TYPE (SET_) ::  CLAUSE
      TYPE(SUBMODEL_DATA),INTENT(IN):: LSUBMODEL(*)
      TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
!
        IF (opt_g == 1 ) THEN
             CALL create_subs_list_g(clause,  isubsm  ,jclause ,is_available ,lsubmodel,
     .                               subset)
        ELSE
             CALL create_subs_list  (clause,  isubsm  ,jclause ,is_available ,lsubmodel,
     .                               subset)
        ENDIF
C-----------------------------------------------
      END
!||====================================================================
!||    create_subs_list            ../starter/source/model/sets/create_subs_clause.F
!||--- called by ------------------------------------------------------
!||    create_subs_clause          ../starter/source/model/sets/create_subs_clause.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                      ../starter/source/output/message/message.F
!||    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_subs_list(
     .               CLAUSE,  ISUBSM  ,JCLAUSE ,IS_AVAILABLE ,LSUBMODEL,
     .               SUBSET)
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     ISUBSM        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
      USE groupdef_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-----------------------------------------------
      INTEGER JCLAUSE
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSUBS,2) :: ISUBSM
!
      TYPE (SET_) ::  CLAUSE
      TYPE(submodel_data),INTENT(IN):: LSUBMODEL(*)
      TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,IDS,NINDX,LIST_SIZE,IDS_MAX,SUBSM,PARTM,ISET,IP
      INTEGER IWORK(70000)
!
      INTEGER, ALLOCATABLE, DIMENSION(:) :: SUBS_READ_TMP,SORTED_SUBS,INDEXS,
     . part_read_tmp,sorted_parts,indexp
C
      INTEGER SET_USRTOS
      EXTERNAL set_usrtos
C=======================================================================
 
      CALL hm_get_int_array_index('idsmax' ,ids_max ,jclause,is_available,lsubmodel)
 
      ALLOCATE(subs_read_tmp(ids_max))
      ALLOCATE(sorted_subs(ids_max))
 
      ALLOCATE(part_read_tmp(npart))
      ALLOCATE(sorted_parts(npart))
 
      ALLOCATE(indexs(2*ids_max)) ! subsets
      indexs = 0
 
      ALLOCATE(indexp(2*npart)) ! parts of subsets
      indexp = 0
 
      nindx = 0
      list_size = 0
 
      ! Read & convert Subsets
      ! ---------------------
      DO i=1,ids_max
         CALL hm_get_int_array_2indexes('ids',ids,jclause,i,is_available,lsubmodel)
!
         subsm = set_usrtos(ids,isubsm,nsubs)
         IF(subsm == 0)THEN        
           ! Subset was not found. Issue a Warning & Skip.
           CALL ancmsg(msgid=1902,anmode=aninfo,
     .                             msgtype=msgwarning,
     .                             i1 = clause%SET_ID,
     .                             i2=ids,
     .                             c1=trim(clause%TITLE),
     .                             c2='SUBSET')
         ELSE
 
           subsm=isubsm(subsm,2)
 
           nindx=nindx+1    !   nb of CLAUSE subsets
           subs_read_tmp(nindx) = subsm
         ENDIF
 
      ENDDO ! DO K=1,IDS_MAX
 
 
      ! Sort the Readed SUBSETs and remove eventual duplicates
      ! ---------------------------------------------------- 
 
      iwork(:) = 0
      DO i=1,nindx
        indexs(i) = i
      ENDDO
      CALL my_orders(0,iwork,subs_read_tmp,indexs,nindx,1)
                
      DO i=1,nindx
         sorted_subs(i) = subs_read_tmp(indexs(i))
      ENDDO
 
      CALL remove_duplicates(sorted_subs,nindx,list_size)
 
 
      ! TAG Parts from Readed SUBSETs
      ! ---------------------------------------------------- 
 
      nindx = 0
      DO i=1,list_size
        iset = sorted_subs(i)
        DO ip=1,subset(iset)%NTPART
 
           partm = subset(iset)%TPART(ip)
 
           nindx=nindx+1    !   nb of Parts of CLAUSE subsets
           part_read_tmp(nindx) = partm
        ENDDO ! DO
      ENDDO
 
 
      ! Sort of TAG Parts from Readed SUBSETs and remove eventual duplicates
      ! ---------------------------------------------------- 
 
      iwork(:) = 0
      DO i=1,nindx
        indexp(i) = i
      ENDDO
      CALL my_orders(0,iwork,part_read_tmp,indexp,nindx,1)
                
      DO i=1,nindx
         sorted_parts(i) = part_read_tmp(indexp(i))
      ENDDO
 
      list_size = 0
      CALL remove_duplicates(sorted_parts,nindx,list_size)
 
 
      ! Copy in final SET
      ! ------------------
      clause%NB_PART = list_size  
      ALLOCATE( clause%PART( list_size ) )
 
      DO i=1,list_size
        clause%PART(i) = sorted_parts(i)
      ENDDO
!---
 
C-------------------------
       DEALLOCATE(subs_read_tmp)
       DEALLOCATE(sorted_subs)
       DEALLOCATE(indexs)
       DEALLOCATE(part_read_tmp)
       DEALLOCATE(sorted_parts)
       DEALLOCATE(indexp)
C-------------------------
      RETURN
      END
!||====================================================================
!||    create_subs_list_g          ../starter/source/model/sets/create_subs_clause.F
!||--- called by ------------------------------------------------------
!||    create_subs_clause          ../starter/source/model/sets/create_subs_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_subs_list_g(
     .               CLAUSE,  ISUBSM  ,JCLAUSE ,IS_AVAILABLE ,LSUBMODEL,
     .               SUBSET)
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     ISUBSM        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
      USE groupdef_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-----------------------------------------------
      INTEGER JCLAUSE
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSUBS,2) :: ISUBSM
!
      TYPE (SET_) ::  CLAUSE
      TYPE(SUBMODEL_DATA),INTENT(IN):: LSUBMODEL(*)
      TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,IDS,LIST_SIZE,IDS_MAX,PARTM,GENE_MAX,K,S,S1,
     . nindx,ip,iset
      INTEGER START_GENE,END_GENE,INCR_GENE,SSTART,SSTOP,STACK,STACK_ONE,NB_RESULT
!-
      INTEGER, ALLOCATABLE, DIMENSION(:) :: SUBS_READ_TMP,SUBS_READ_ONE,RESULT,
     .         PART_READ_TMP,SORTED_PARTS,INDEX
C
      INTEGER  SET_USRTOS_NEAREST
      EXTERNAL set_usrtos_nearest
      INTEGER IWORK(70000)
C=======================================================================
      CALL hm_get_int_array_index('genemax' ,gene_max ,jclause,is_available,lsubmodel)
 
      ALLOCATE(subs_read_tmp(nsubs))
      ALLOCATE(subs_read_one(nsubs))
 
      ALLOCATE(part_read_tmp(npart))
      ALLOCATE(sorted_parts(npart))
 
      ALLOCATE(index(2*npart))
      index = 0
 
      IF (gene_max > 1) THEN
          ALLOCATE(result(nsubs))
      ENDIF
 
      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
 
          sstart = set_usrtos_nearest(start_gene,isubsm,nsubs,1)
          sstop  = set_usrtos_nearest(end_gene,isubsm,nsubs,2)
     
          stack_one=0
 
          DO s=sstart, sstop
             s1 = isubsm(s,1)
             IF ( mod( s1-start_gene , incr_gene) == 0 ) THEN
                stack_one = stack_one+1
                subs_read_one(stack_one) = isubsm(s,2)
             ENDIF
          ENDDO
 
          IF (stack==0) THEN
             subs_read_tmp(1:stack_one) = subs_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( subs_read_tmp, stack ,
     *                                 subs_read_one, stack_one ,
     *                                 result,        nb_result )
 
            subs_read_tmp(1:nb_result) = result(1:nb_result)
            stack = nb_result
          ENDIF
      ENDDO
 
 
      ! TAG Parts from Readed SUBSETs
      ! ---------------------------------------------------- 
 
      nindx = 0
      DO i=1,stack
        iset = subs_read_tmp(i)
        DO ip=1,subset(iset)%NTPART
 
           partm = subset(iset)%TPART(ip)
 
           nindx=nindx+1    !   nb of Parts of CLAUSE subsets
           part_read_tmp(nindx) = partm
        ENDDO ! DO
      ENDDO
 
 
      ! Sort of TAG Parts from Readed SUBSETs 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
         sorted_parts(i) = part_read_tmp(index(i))
      ENDDO
 
      list_size = 0
      CALL remove_duplicates(sorted_parts,nindx,list_size)
 
 
 
!
      ! Copy in final SET
      ! ------------------
      clause%NB_PART = list_size
      ALLOCATE(clause%PART(list_size))
      clause%PART(1:list_size) = sorted_parts(1:list_size)
!---
      DEALLOCATE (part_read_tmp)
      DEALLOCATE (sorted_parts)
      IF (ALLOCATED(result)) DEALLOCATE (result)
      DEALLOCATE (subs_read_tmp)
      DEALLOCATE (subs_read_one)
!---
      END