create_set_clause.F File Reference

#include "implicit_f.inc"
#include "param_c.inc"
#include "sphcom.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	create_set_array (set_array, array_size, isetm, nset_general, jclause, opt_g, is_available, lsubmodel, clause, flag)
subroutine	create_set_list (array, array_size, isetm, nset_general, jclause, is_available, lsubmodel, clause, flag)
subroutine	create_set_list_g (array, array_size, isetm, nset_general, jclause, is_available, lsubmodel)
subroutine	create_set_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)

Function/Subroutine Documentation

create_set_array()

subroutine create_set_array	(	integer, dimension(*)	set_array,
		integer	array_size,
		integer, dimension(nsets,2), intent(in)	isetm,
		integer	nset_general,
		integer	jclause,
		integer	opt_g,
		logical	is_available,
		type(submodel_data), dimension(*), intent(in)	lsubmodel,
		type (set_)	clause,
		integer	flag )

Definition at line 36 of file create_set_clause.F.

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-----------------------------------------------
      INTEGER JCLAUSE,OPT_G,ARRAY_SIZE,NSET_GENERAL,FLAG
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSETS,2) :: ISETM
C-----------------------------------------------
      TYPE (SET_) ::  CLAUSE
      INTEGER SET_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_set_list_g(set_array, array_size ,isetm ,nset_general ,jclause ,is_available ,lsubmodel)
        ELSE
             CALL create_set_list  (set_array, array_size ,isetm ,nset_general ,jclause ,is_available ,lsubmodel,
     .                              clause   ,flag)
        ENDIF
C-----------------------------------------------

create_set_clause()

subroutine create_set_clause	(	type (set_), dimension(nsets), intent(in)	set,
		integer, dimension(nsets), intent(in)	setl,
		integer	setl_size,
		type (set_)	clause,
		integer, dimension(nixs,*)	ixs,
		integer, dimension(6,*)	ixs10,
		integer, dimension(nixq,*)	ixq,
		integer, dimension(nixc,*)	ixc,
		integer, dimension(nixtg,*)	ixtg,
		integer, dimension(nixt,*)	ixt,
		integer, dimension(nixp,*)	ixp,
		integer, dimension(nixr,*)	ixr,
		integer, dimension(*)	sh4tree,
		integer, dimension(*)	sh3tree,
		integer, dimension(*)	knod2els,
		integer, dimension(*)	nod2els,
		integer, dimension(*)	knod2elc,
		integer, dimension(*)	nod2elc,
		integer, dimension(*)	knod2eltg,
		integer, dimension(*)	nod2eltg,
		integer, dimension(*)	ipartc,
		integer, dimension(*)	ipartg,
		integer, dimension(*)	iparts,
		integer, dimension(lipart1,*)	ipart,
		integer	opt_a,
		integer	opt_o,
		integer, dimension(*)	knod2elq,
		integer, dimension(*)	nod2elq,
			x,
		character(len=ncharfield)	keyset,
		integer	opt_e,
		type (set_scratch)	delbuf )

Definition at line 346 of file create_set_clause.F.

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     IXS - KXSP, IGEO : not need in this case, but kept for compatibility.
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  OPT_A,OPT_O,OPT_E
      INTEGER, DIMENSION(NSETS),    INTENT(IN) :: SETL
      TYPE (SET_),DIMENSION(NSETS), INTENT(IN) :: SET
      TYPE (SET_) :: CLAUSE
      TYPE (SET_SCRATCH) ::  DELBUF
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-----------------------------------------------

create_set_list()

subroutine create_set_list	(	integer, dimension(*)	array,
		integer	array_size,
		integer, dimension(nsets,2), intent(in)	isetm,
		integer	nset_general,
		integer	jclause,
		logical	is_available,
		type(submodel_data), dimension(*), intent(in)	lsubmodel,
		type (set_)	clause,
		integer	flag )

Definition at line 106 of file create_set_clause.F.

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-----------------------------------------------
      INTEGER JCLAUSE, ARRAY_SIZE,NSET_GENERAL,FLAG
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSETS,2) :: ISETM
      INTEGER ARRAY(*)
      TYPE (SET_) ::  CLAUSE
      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,IDS,NINDX,LIST_SIZE,IDS_MAX,SETM
      INTEGER IWORK(70000)
!
      INTEGER, ALLOCATABLE, DIMENSION(:) :: SET_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(set_read_tmp(ids_max))
      set_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)
!
         setm = set_usrtos(ids,isetm,nset_general)
 
         IF(setm > 0)THEN                 ! 0 if SET was not found
           setm=isetm(setm,2)
           nindx=nindx+1                   !   nb of CLAUSE sets
           set_read_tmp(nindx) = setm
         ELSEIF (flag == 1) THEN
           ! SET 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='SET')
         ENDIF
      ENDDO ! DO K=1,IDS_MAX
 
      ! Sort the Readed SETs and remove eventual duplicates
      ! ---------------------------------------------------- 
 
      DO i=1,nindx
        index(i) = i
      ENDDO
      CALL my_orders(0,iwork,set_read_tmp,index,nindx,1)
 
      DO i=1,nindx
        array(i)=set_read_tmp(index(i))
      ENDDO
 
      CALL remove_duplicates( array,nindx,list_size)
 
      ! Copy in final SET
      ! ------------------
      array_size = list_size  
      
!---
 
C-------------------------
       DEALLOCATE(set_read_tmp)
       DEALLOCATE(index)
C-------------------------
      RETURN

create_set_list_g()

subroutine create_set_list_g	(	integer, dimension(array_size)	array,
		integer	array_size,
		integer, dimension(nsets,2), intent(in)	isetm,
		integer	nset_general,
		integer	jclause,
		logical	is_available,
		type(submodel_data), dimension(*), intent(in)	lsubmodel )

Definition at line 232 of file create_set_clause.F.

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-----------------------------------------------
      INTEGER JCLAUSE,ARRAY_SIZE, NSET_GENERAL
      INTEGER ARRAY(ARRAY_SIZE)
      LOGICAL :: IS_AVAILABLE
      INTEGER, INTENT(IN), DIMENSION(NSETS,2) :: ISETM
!
      
      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,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, ALLOCATABLE, DIMENSION(:) :: SET_READ_TMP,SET_READ_ONE,IDEX,RESULT
C
      INTEGER  SET_USRTOS_NEAREST
      EXTERNAL set_usrtos_nearest
C=======================================================================
      CALL hm_get_int_array_index('genemax' ,gene_max ,jclause,is_available,lsubmodel)
 
      ALLOCATE(set_read_tmp(nsets))
      ALLOCATE(set_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, isetm, nset_general,1)
          pstop  = set_usrtos_nearest(end_gene,   isetm, nset_general,2)
     
          stack_one=0               ! assemble in SET_READ_ONE Stack_one
          DO p=pstart, pstop
             p1 = isetm(p,1)
             IF ( mod( p1-start_gene , incr_gene) == 0)THEN
                  stack_one = stack_one+1
                  set_read_one(stack_one) = isetm(p,2)
             ENDIF
          ENDDO
 
          IF(stack==0) THEN
 
             set_read_tmp(1:stack_one) = set_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( set_read_tmp, stack ,
     *                                 set_read_one, stack_one ,
     *                                 result,        nb_result   )
          set_read_tmp(1:nb_result)=result(1:nb_result)
          stack = nb_result
 
          ENDIF
 
 
      ENDDO
 
      array_size = stack
      array(1:stack) = set_read_tmp(1:stack)
 
      DEALLOCATE (set_read_one)
      DEALLOCATE (set_read_tmp)
      DEALLOCATE (result)