From 2ffb0eade5a842da6d423db7431a7a287fc8e4f3 Mon Sep 17 00:00:00 2001 From: lorenzo-mechbau Date: Tue, 27 Mar 2018 17:24:32 +0200 Subject: [PATCH 1/9] comment 1 --- src/opencmiss_iron.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/opencmiss_iron.f90 b/src/opencmiss_iron.f90 index 944490b7..1a9bc9b8 100644 --- a/src/opencmiss_iron.f90 +++ b/src/opencmiss_iron.f90 @@ -27676,6 +27676,8 @@ SUBROUTINE cmfe_Field_CreateFinishObj(field,err) CALL TAU_STATIC_PHASE_STOP('field Create') #endif +! my comment + EXITS("cmfe_Field_CreateFinishObj") RETURN 999 ERRORSEXITS("cmfe_Field_CreateFinishObj",err,error) From c83a531c7a9805b4c4b8c7b51884e8744544039b Mon Sep 17 00:00:00 2001 From: lorenzo-mechbau Date: Tue, 27 Mar 2018 17:31:39 +0200 Subject: [PATCH 2/9] comment gone --- src/opencmiss_iron.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/opencmiss_iron.f90 b/src/opencmiss_iron.f90 index 1a9bc9b8..944490b7 100644 --- a/src/opencmiss_iron.f90 +++ b/src/opencmiss_iron.f90 @@ -27676,8 +27676,6 @@ SUBROUTINE cmfe_Field_CreateFinishObj(field,err) CALL TAU_STATIC_PHASE_STOP('field Create') #endif -! my comment - EXITS("cmfe_Field_CreateFinishObj") RETURN 999 ERRORSEXITS("cmfe_Field_CreateFinishObj",err,error) From f156df320c77a2b2c61781d4785c0014a4f8828d Mon Sep 17 00:00:00 2001 From: lorenzo-mechbau Date: Tue, 27 Mar 2018 17:32:46 +0200 Subject: [PATCH 3/9] Another comment... --- src/opencmiss_iron.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/opencmiss_iron.f90 b/src/opencmiss_iron.f90 index 944490b7..c167d89d 100644 --- a/src/opencmiss_iron.f90 +++ b/src/opencmiss_iron.f90 @@ -27676,6 +27676,8 @@ SUBROUTINE cmfe_Field_CreateFinishObj(field,err) CALL TAU_STATIC_PHASE_STOP('field Create') #endif +! another comment + EXITS("cmfe_Field_CreateFinishObj") RETURN 999 ERRORSEXITS("cmfe_Field_CreateFinishObj",err,error) From 6d7e4a02bf48aebfe12bdde8602b08c99511b979 Mon Sep 17 00:00:00 2001 From: lorenzo-mechbau Date: Wed, 13 Jun 2018 14:35:52 +1200 Subject: [PATCH 4/9] Hash table implementation. With tree output to delete!! --- src/linkedlist_routines.F90 | 4 ++-- src/mesh_routines.F90 | 13 +++++++++++++ src/trees.F90 | 10 +++++----- 3 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/linkedlist_routines.F90 b/src/linkedlist_routines.F90 index 4f531f76..921d1fb2 100644 --- a/src/linkedlist_routines.F90 +++ b/src/linkedlist_routines.F90 @@ -72,7 +72,7 @@ End SUBROUTINE LinkedList_Add_Data ! ------------------------------------------------------------------- - !> adds all data from one list to another + !> adds all data from one list (addlist) to another (list) Subroutine LinkedList_Add_List(list,addlist,ERR,ERROR,*) type(LinkedList),intent(inout) :: list type(LinkedList),intent(in) :: addlist @@ -157,7 +157,7 @@ Subroutine LinkedList_Remove_Last(list,data,ERR,ERROR,*) exit endif else - ! there must be only one item in the list? + ! there must be only one item in the list(?)! data = current%data deallocate(list%root) list%root => NULL() diff --git a/src/mesh_routines.F90 b/src/mesh_routines.F90 index e5d467f7..9001736e 100644 --- a/src/mesh_routines.F90 +++ b/src/mesh_routines.F90 @@ -855,6 +855,12 @@ SUBROUTINE DECOMPOSITION_ELEMENT_DOMAIN_GET(DECOMPOSITION,USER_ELEMENT_NUMBER,DO CALL TREE_NODE_VALUE_GET(MESH_ELEMENTS%ELEMENTS_TREE,TREE_NODE,GLOBAL_ELEMENT_NUMBER,ERR,ERROR,*999) IF(GLOBAL_ELEMENT_NUMBER>0.AND.GLOBAL_ELEMENT_NUMBER<=MESH_TOPOLOGY%ELEMENTS%NUMBER_OF_ELEMENTS) THEN DOMAIN_NUMBER=DECOMPOSITION%ELEMENT_DOMAIN(GLOBAL_ELEMENT_NUMBER) + + ! adding an output here!!! + IF (DOMAIN_NUMBER==0) THEN + CALL TREE_OUTPUT(1,MESH_ELEMENTS%ELEMENTS_TREE,ERR,ERROR,*999) + END IF + ELSE LOCAL_ERROR="Global element number found "//TRIM(NUMBER_TO_VSTRING(GLOBAL_ELEMENT_NUMBER,"*",ERR,ERROR))// & & " is invalid. The limits are 1 to "// & @@ -1657,6 +1663,13 @@ SUBROUTINE DecompositionTopology_ElementCheckExists(decompositionTopology,userEl CALL Tree_NodeValueGet(decompositionElements%ELEMENTS_TREE,treeNode,localElementNumber,err,error,*999) elementExists=.TRUE. ghostElement=localElementNumber>decompositionElements%NUMBER_OF_ELEMENTS + + ! how to call the topology tree?... + !IF (DOMAIN_NUMBER==0) THEN + ! PRINT *, "Topology tree " + ! CALL TREE_OUTPUT(1,decompositionElements%ELEMENTS_TREE,ERR,ERROR,*999) + !END IF + ENDIF EXITS("DecompositionTopology_ElementCheckExists") diff --git a/src/trees.F90 b/src/trees.F90 index 9e994023..165c6d7e 100644 --- a/src/trees.F90 +++ b/src/trees.F90 @@ -100,7 +100,7 @@ MODULE TREES INTEGER(INTG) :: INSERT_TYPE !Detaches the tree values and returns them as a pointer to the an array + !>Detaches the tree values and returns them as a pointer to an array SUBROUTINE TREE_DETACH(TREE,NUMBER_IN_TREE,TREE_VALUES,ERR,ERROR,*) !Argument Variables TYPE(TREE_TYPE), POINTER :: TREE !Detaches the tree values and returns them as a pointer to the an array and then destroys the tree + !>Detaches the tree values and returns them as a pointer to an array and then destroys the tree SUBROUTINE TREE_DETACH_AND_DESTROY(TREE,NUMBER_IN_TREE,TREE_VALUES,ERR,ERROR,*) !Argument Variables @@ -374,7 +374,7 @@ END SUBROUTINE TREE_DETACH_AND_DESTROY !================================================================================================================================ ! - !>Detaches the tree values in order from the specified tree node and adds them to the tree values array + !>Detaches the tree values in order from the specified tree node (eg root) and adds them to the tree values array RECURSIVE SUBROUTINE TREE_DETACH_IN_ORDER(TREE,X,COUNT,TREE_VALUES,ERR,ERROR,*) !Argument Variables From 77f9772768822aefb5e2855a07d65d06a842ff24 Mon Sep 17 00:00:00 2001 From: lorenzo-mechbau Date: Fri, 22 Jun 2018 16:01:49 +1200 Subject: [PATCH 5/9] Hash table implementation. To be finished. Comments also in BC. --- cmake/Sources.cmake | 1 + src/boundary_condition_routines.F90 | 33 +++++++++++++- src/distributed_matrix_vector.F90 | 71 +++++++++++++++++++++++++++-- src/linkedlist_routines.F90 | 6 +++ src/mesh_routines.F90 | 14 +++--- src/solver_mapping_routines.F90 | 22 ++++++--- src/solver_matrices_routines.F90 | 2 + src/types.F90 | 11 ++++- 8 files changed, 142 insertions(+), 18 deletions(-) diff --git a/cmake/Sources.cmake b/cmake/Sources.cmake index dea3d26a..e5ec00c4 100644 --- a/cmake/Sources.cmake +++ b/cmake/Sources.cmake @@ -80,6 +80,7 @@ set(IRON_Fortran_SRC generated_mesh_routines.F90 generated_mesh_access_routines.F90 Hamilton_Jacobi_equations_routines.F90 + hash_routines.F90 Helmholtz_equations_routines.F90 #Helmholtz_TEMPLATE_equations_routines.F90 history_routines.F90 diff --git a/src/boundary_condition_routines.F90 b/src/boundary_condition_routines.F90 index 2a9e9368..4c2562aa 100644 --- a/src/boundary_condition_routines.F90 +++ b/src/boundary_condition_routines.F90 @@ -325,8 +325,16 @@ SUBROUTINE BOUNDARY_CONDITIONS_CREATE_FINISH(BOUNDARY_CONDITIONS,ERR,ERROR,*) IF(ASSOCIATED(VARIABLE_DOMAIN_MAPPING)) THEN SEND_COUNT=VARIABLE_DOMAIN_MAPPING%NUMBER_OF_GLOBAL IF(computationalEnvironment%numberOfComputationalNodes>1) THEN - !\todo This operation is a little expensive as we are doing an unnecessary sum across all the ranks in order to combin + !\todo This operation is a little expensive as we are doing an unnecessary sum across all the ranks in order to combine !\todo the data from each rank into all ranks. We will see how this goes for now. + + ! Should be replaced with scatter(?)!! And local implementation of dof_types!!! + ! But solver mapping STILL requires dof types global + ! Can change this but would work only here. + ! ALLREDUCE must stay until solver_mapping is not changed. + + + ! Summing up all global vectors returns the number of fixed dofs in the row (?) CALL MPI_ALLREDUCE(MPI_IN_PLACE,BOUNDARY_CONDITION_VARIABLE%DOF_TYPES, & & SEND_COUNT,MPI_INTEGER,MPI_SUM,computationalEnvironment%mpiCommunicator,MPI_IERROR) CALL MPI_ERROR_CHECK("MPI_ALLREDUCE",MPI_IERROR,ERR,ERROR,*999) @@ -408,8 +416,12 @@ SUBROUTINE BOUNDARY_CONDITIONS_CREATE_FINISH(BOUNDARY_CONDITIONS,ERR,ERROR,*) BOUNDARY_CONDITIONS_DIRICHLET=>BOUNDARY_CONDITION_VARIABLE%DIRICHLET_BOUNDARY_CONDITIONS IF(ASSOCIATED(BOUNDARY_CONDITIONS_DIRICHLET)) THEN ! Find dirichlet conditions + + ! replace with (total) n. of local!!?? dirichlet_idx=1 DO dof_idx=1,FIELD_VARIABLE%NUMBER_OF_GLOBAL_DOFS + + ! BC_DOF_FIXED is 1 IF(BOUNDARY_CONDITION_VARIABLE%DOF_TYPES(dof_idx)==BOUNDARY_CONDITION_DOF_FIXED) THEN BOUNDARY_CONDITIONS_DIRICHLET%DIRICHLET_DOF_INDICES(dirichlet_idx)=dof_idx dirichlet_idx=dirichlet_idx+1 @@ -1705,6 +1717,7 @@ SUBROUTINE BoundaryConditions_SetConditionType(boundaryConditionsVariable,global END IF END IF !Update Dirichlet DOF count + ! should be local!!! previousDof=boundaryConditionsVariable%DOF_TYPES(globalDof) IF(dofType==BOUNDARY_CONDITION_DOF_FIXED.AND.previousDof/=BOUNDARY_CONDITION_DOF_FIXED) THEN boundaryConditionsVariable%NUMBER_OF_DIRICHLET_CONDITIONS= & @@ -1716,6 +1729,7 @@ SUBROUTINE BoundaryConditions_SetConditionType(boundaryConditionsVariable,global !Set the boundary condition type and DOF type boundaryConditionsVariable%CONDITION_TYPES(globalDof)=condition + ! should be local!!! boundaryConditionsVariable%DOF_TYPES(globalDof)=dofType IF(DIAGNOSTICS1) THEN CALL WriteString(DIAGNOSTIC_OUTPUT_TYPE,"Boundary Condition Being Set",err,error,*999) @@ -2325,6 +2339,7 @@ SUBROUTINE BoundaryConditions_NeumannMatricesInitialise(boundaryConditionsVariab CALL DOMAIN_MAPPINGS_LOCAL_FROM_GLOBAL_CALCULATE(pointDofMapping,err,error,*999) + ! here allocation of integrationMatrix!!!??? CALL DistributedMatrix_CreateStart(rowMapping,pointDofMapping,boundaryConditionsNeumann%integrationMatrix,err,error,*999) SELECT CASE(boundaryConditionsVariable%BOUNDARY_CONDITIONS%neumannMatrixSparsity) CASE(BOUNDARY_CONDITION_SPARSE_MATRICES) @@ -2500,6 +2515,8 @@ SUBROUTINE BoundaryConditions_NeumannMatricesInitialise(boundaryConditionsVariab CALL DistributedMatrix_StorageTypeSet(boundaryConditionsNeumann%integrationMatrix, & & DISTRIBUTED_MATRIX_COMPRESSED_ROW_STORAGE_TYPE,err,error,*999) + + ! replace with local quantities!!!??? CALL DistributedMatrix_NumberOfNonZerosSet(boundaryConditionsNeumann%integrationMatrix,numberNonZeros,err,error,*999) CALL DistributedMatrix_StorageLocationsSet(boundaryConditionsNeumann%integrationMatrix, & & rowIndices,columnIndices(1:numberNonZeros),err,error,*999) @@ -2724,6 +2741,7 @@ SUBROUTINE BoundaryConditions_NeumannIntegrate(rhsBoundaryConditions,err,error,* neumannNodeNumber=rhsVariable%DOF_TO_PARAM_MAP%NODE_DOF2PARAM_MAP(3,neumannDofNyy) SELECT CASE(rhsVariable%COMPONENTS(componentNumber)%DOMAIN%NUMBER_OF_DIMENSIONS) CASE(1) + ! replace with local???? CALL DistributedMatrix_ValuesSet(neumannConditions%integrationMatrix,neumannLocalDof,neumannDofIdx, & & 1.0_DP,err,error,*999) CASE(2) @@ -2816,6 +2834,7 @@ SUBROUTINE BoundaryConditions_NeumannIntegrate(rhsBoundaryConditions,err,error,* END IF ! Add integral term to N matrix + ! Already local, ok??? CALL DistributedMatrix_ValuesAdd(neumannConditions%integrationMatrix,localDof,neumannDofIdx, & & integratedValue,err,error,*999) END DO @@ -2911,6 +2930,7 @@ SUBROUTINE BoundaryConditions_NeumannIntegrate(rhsBoundaryConditions,err,error,* END IF ! Add integral term to N matrix + ! Already local, ok??? CALL DistributedMatrix_ValuesAdd(neumannConditions%integrationMatrix,localDof,neumannDofIdx, & & integratedValue,err,error,*999) END DO @@ -2944,6 +2964,8 @@ SUBROUTINE BoundaryConditions_NeumannIntegrate(rhsBoundaryConditions,err,error,* & integratedValues,err,error,*999) CALL DistributedVector_AllValuesSet(integratedValues,0.0_DP,err,error,*999) ! Perform matrix multiplication, f = N q, to calculate force vector from integration matrix and point values + + ! local??? Mapping on f??? CALL DistributedMatrix_MatrixByVectorAdd(DISTRIBUTED_MATRIX_VECTOR_NO_GHOSTS_TYPE,1.0_DP, & & neumannConditions%integrationMatrix,neumannConditions%pointValues,integratedValues, & & err,error,*999) @@ -3251,6 +3273,7 @@ SUBROUTINE BoundaryConditions_DofConstraintSet(boundaryConditions,fieldVariable, END DO !Check DOFs are free + ! Should be local! DO dofIdx=1,numberOfDofs IF(boundaryConditionsVariable%dof_types(dofs(dofIdx))/=BOUNDARY_CONDITION_DOF_FREE) THEN CALL FlagError("DOF number "//TRIM(NumberToVstring(dofs(dofIdx),"*",err,error))// & @@ -3375,6 +3398,8 @@ SUBROUTINE BoundaryConditions_DofConstraintsCreateFinish(boundaryConditionsVaria !Check that the constrained DOFs are still set to be constrained, as !subsequently setting a boundary condition would change the DOF type but !not update the DOF constraints structure. + + ! should be local!! IF(boundaryConditionsVariable%dof_types(globalDof)/=BOUNDARY_CONDITION_DOF_CONSTRAINED) THEN CALL FlagError("Global DOF number "//TRIM(NumberToVstring(globalDof,"*",err,error))// & & " is part of a linear constraint but the DOF type has been changed"// & @@ -3385,6 +3410,7 @@ SUBROUTINE BoundaryConditions_DofConstraintsCreateFinish(boundaryConditionsVaria globalDof2=dofConstraint%dofs(dofIdx) localDof2=variableDomainMapping%global_to_local_map(globalDof2)%local_number(1) !Check a Dirichlet conditions hasn't also been set on this DOF + ! should be local!! IF(boundaryConditionsVariable%dof_types(globalDof2)/=BOUNDARY_CONDITION_DOF_FREE) THEN CALL FlagError("A Dirichlet boundary condition has been set on DOF number "// & & TRIM(NumberToVstring(globalDof2,"*",err,error))// & @@ -3684,10 +3710,15 @@ SUBROUTINE BOUNDARY_CONDITIONS_VARIABLE_INITIALISE(BOUNDARY_CONDITIONS,FIELD_VAR BOUNDARY_CONDITIONS_VARIABLE%VARIABLE=>FIELD_VARIABLE ALLOCATE(BOUNDARY_CONDITIONS_VARIABLE%CONDITION_TYPES(VARIABLE_DOMAIN_MAPPING%NUMBER_OF_GLOBAL),STAT=ERR) IF(ERR/=0) CALL FlagError("Could not allocate global boundary condition types.",ERR,ERROR,*999) + + ! THIS ALLOCATION SHOULD BE LOCAL! ALLOCATE(BOUNDARY_CONDITIONS_VARIABLE%DOF_TYPES(VARIABLE_DOMAIN_MAPPING%NUMBER_OF_GLOBAL),STAT=ERR) IF(ERR/=0) CALL FlagError("Could not allocate global boundary condition dof types.",ERR,ERROR,*999) BOUNDARY_CONDITIONS_VARIABLE%CONDITION_TYPES=BOUNDARY_CONDITION_FREE + + ! All initialised to zero!!! BOUNDARY_CONDITIONS_VARIABLE%DOF_TYPES=BOUNDARY_CONDITION_DOF_FREE + ALLOCATE(BOUNDARY_CONDITIONS_VARIABLE%DOF_COUNTS(MAX_BOUNDARY_CONDITION_NUMBER),STAT=ERR) IF(ERR/=0) CALL FlagError("Could not allocate boundary condition DOF counts array.",ERR,ERROR,*999) BOUNDARY_CONDITIONS_VARIABLE%DOF_COUNTS=0 diff --git a/src/distributed_matrix_vector.F90 b/src/distributed_matrix_vector.F90 index 927e4a10..1e0c945b 100644 --- a/src/distributed_matrix_vector.F90 +++ b/src/distributed_matrix_vector.F90 @@ -974,7 +974,12 @@ SUBROUTINE DistributedMatrix_CMISSInitialise(distributedMatrix,err,error,*) INTEGER(INTG) :: dummyErr TYPE(DOMAIN_MAPPING_TYPE), POINTER :: rowDomainMapping,columnDomainMapping TYPE(VARYING_STRING) :: dummyError,localError - + + ! Hash variables + INTEGER(INTG), ALLOCATABLE :: S_key(:), S_val(:) + INTEGER(INTG) :: i,n, q, my_computational_node_number, index_found, value, tmp + LOGICAL :: is_found + ENTERS("DistributedMatrix_CMISSInitialise",err,error,*998) IF(.NOT.ASSOCIATED(distributedMatrix)) CALL FlagError("Distributed matrix is not associated.",err,error,*998) @@ -1009,7 +1014,66 @@ SUBROUTINE DistributedMatrix_CMISSInitialise(distributedMatrix,err,error,*) & TRIM(NumberToVString(distributedMatrix%ghostingType,"*",err,error))//" is invalid." CALL FlagError(localError,err,error,*999) END SELECT - + +! START my hash implementation + +! use columnDomainMapping ltg info to create hash: +! hash type in type of distributedMatrix%cmiss, move in future? petsc already handles. OK +! cf. trees!!! USE SAME STYLE AND STRUCTURE (cf. Website!!)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! cf. err,error,*; enters, exits +! hash_create_start using columnDomainMapping: set defaults +! override (change) parameters, e.g. duplicates for tree, can be done here +! create_finish finish_flag = true! +! THEN, insert values, query, delete etc. (i.e. fill with relevant info) + +my_computational_node_number = ComputationalEnvironment_NodeNumberGet(ERR,ERROR) +IF (my_computational_node_number==1) THEN + PRINT*, "Print out the map", columnDomainMapping%LOCAL_TO_GLOBAL_MAP +END IF + +! Create the table if not done already +SELECT CASE (ASSOCIATED (distributedMatrix%cmiss%columnHashTable)) + +CASE (.FALSE.) ! No table yet: create and fill the column table +CALL HashTable_CreateStart(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) +!CALL TREE_INSERT_TYPE_SET(decompositionData%dataPointsTree,TREE_NO_DUPLICATES_ALLOWED,ERR,ERROR,*999) +CALL HashTable_CreateFinish(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) + +n = size(columnDomainMapping%LOCAL_TO_GLOBAL_MAP) +ALLOCATE(S_val(n-1),STAT=err) +IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) +S_val = [ (i, i=1,n-1)] ! test 1-element insertion + +ALLOCATE(S_key(n-1),STAT=err) +IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) +S_key = columnDomainMapping%LOCAL_TO_GLOBAL_MAP(1:(n-1)) + +! FIX ERROR HANDLING, STYLE etc. in hash_routines!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Insert keys values until n-1 +CALL HashTable_Insert(distributedMatrix%cmiss%columnHashTable, S_key, S_val, ERR, ERROR, *999) +! Test 1-element insertion and query +CALL HashTable_Insert(distributedMatrix%cmiss%columnHashTable, columnDomainMapping%LOCAL_TO_GLOBAL_MAP(n), n, ERR,ERROR,*999) + +! Test query for q +IF (my_computational_node_number==1) THEN + DO q=1,100 + CALL HashTable_Get(distributedMatrix%cmiss%columnHashTable, q, index_found, is_found, ERR, ERROR, *999) + !PRINT *, "Index ", index_found + IF (is_found) THEN + CALL HashTable_GetValue(distributedMatrix%cmiss%columnHashTable, index_found, value, ERR, ERROR, *999) + PRINT *, q, "Found! With value ", value + ELSE + PRINT *, q, "Key does not exist!" + END IF + END DO +END IF + +CASE (.TRUE.) +! Do nothing, Table already computed! +END SELECT + +! end my hash_implementation + EXITS("DistributedMatrix_CMISSInitialise") RETURN 999 IF(ASSOCIATED(distributedMatrix%cmiss)) & @@ -2663,7 +2727,8 @@ SUBROUTINE DistributedMatrix_PETScInitialise(distributedMatrix,err,error,*) distributedMatrix%petsc%useOverrideMatrix=.FALSE. CALL Petsc_MatInitialise(distributedMatrix%petsc%matrix,err,error,*999) CALL Petsc_MatInitialise(distributedMatrix%petsc%overrideMatrix,err,error,*999) - + + EXITS("DistributedMatrix_PETScInitialise") RETURN 999 IF(ASSOCIATED(distributedMatrix%petsc)) & diff --git a/src/linkedlist_routines.F90 b/src/linkedlist_routines.F90 index 921d1fb2..c8c6d2bc 100644 --- a/src/linkedlist_routines.F90 +++ b/src/linkedlist_routines.F90 @@ -34,6 +34,9 @@ MODULE LinkedList_routines public :: LinkedList_Add,LinkedList_Destroy,LinkedList_Remove_First,LinkedList_Remove_Last public :: LinkedList_is_Empty,LinkedList_to_Array + + + contains ! ------------------------------------------------------------------- @@ -252,4 +255,7 @@ Subroutine LinkedList_to_Array(list,array,ERR,ERROR,*) End Subroutine LinkedList_to_Array + + + End Module LinkedList_routines diff --git a/src/mesh_routines.F90 b/src/mesh_routines.F90 index 9001736e..96ed5ef4 100644 --- a/src/mesh_routines.F90 +++ b/src/mesh_routines.F90 @@ -857,21 +857,23 @@ SUBROUTINE DECOMPOSITION_ELEMENT_DOMAIN_GET(DECOMPOSITION,USER_ELEMENT_NUMBER,DO DOMAIN_NUMBER=DECOMPOSITION%ELEMENT_DOMAIN(GLOBAL_ELEMENT_NUMBER) ! adding an output here!!! - IF (DOMAIN_NUMBER==0) THEN - CALL TREE_OUTPUT(1,MESH_ELEMENTS%ELEMENTS_TREE,ERR,ERROR,*999) - END IF + !IF (DOMAIN_NUMBER==0) THEN + ! CALL TREE_OUTPUT(1,MESH_ELEMENTS%ELEMENTS_TREE,ERR,ERROR,*999) + !END IF ELSE LOCAL_ERROR="Global element number found "//TRIM(NUMBER_TO_VSTRING(GLOBAL_ELEMENT_NUMBER,"*",ERR,ERROR))// & & " is invalid. The limits are 1 to "// & & TRIM(NUMBER_TO_VSTRING(MESH_TOPOLOGY%ELEMENTS%NUMBER_OF_ELEMENTS,"*",ERR,ERROR))//"." - CALL FlagError(LOCAL_ERROR,ERR,ERROR,*999) + !CALL FlagError(LOCAL_ERROR,ERR,ERROR,*999) ENDIF ELSE LOCAL_ERROR="Decomposition mesh element corresponding to user element number "// & & TRIM(NumberToVString(USER_ELEMENT_NUMBER,"*",err,error))//" is not found." - CALL FlagError(LOCAL_ERROR,ERR,ERROR,*999) - ENDIF + ! CALL FlagError(LOCAL_ERROR,ERR,ERROR,*999) + ! restore this flag!!!! + ERR = 1000 + ENDIF ELSE CALL FlagError("Decomposition mesh elements are not associated.",ERR,ERROR,*999) ENDIF diff --git a/src/solver_mapping_routines.F90 b/src/solver_mapping_routines.F90 index 4e680eae..6ccf87de 100644 --- a/src/solver_mapping_routines.F90 +++ b/src/solver_mapping_routines.F90 @@ -314,7 +314,7 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) ! !--- Row mappings --- ! - ! 2. Determine the number of rows in the solver matrix. Do this the by setting up a list of rows for each rank. + ! 2. Determine the number of rows in the solver matrix. Do this by setting up a list of rows for each rank. ! We can then later arrange the rows in rank order by looping over the ranks in the list and then the rows ! for each rank. ! @@ -395,9 +395,9 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) ENDIF ENDDO !interface_condition_idx ENDDO !rank - !Calculate the number of local and global rows. Do this by looking at the boundary conditions for field variables - !involved in the row. If all the variables are set as a fixed boundary condition then do not include the row. If - !any variable is not fixed then include the row. + !Calculate the NUMBER of local and global rows. Do this by looking at the boundary conditions for field variables + !involved in the row. ONLY If ALL the variables are set as a fixed boundary condition then do NOT include the row. If + !any variable is not fixed then INCLUDE the row. equations_idx=0 DO equations_set_idx=1,SOLVER_MAPPING%NUMBER_OF_EQUATIONS_SETS equations_idx=equations_idx+1 @@ -426,6 +426,7 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) IF(ROW_DOFS_MAPPING%GLOBAL_TO_LOCAL_MAP(global_row)%LOCAL_TYPE(rank_idx)/=DOMAIN_LOCAL_GHOST) THEN ROW_RANK=ROW_DOFS_MAPPING%GLOBAL_TO_LOCAL_MAP(global_row)%DOMAIN_NUMBER(rank_idx) local_row=ROW_DOFS_MAPPING%GLOBAL_TO_LOCAL_MAP(global_row)%LOCAL_NUMBER(rank_idx) + ! EXCLUDE rows that are only ghosts!!! EXIT ENDIF ENDDO !rank_idx @@ -440,7 +441,9 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) IF(ASSOCIATED(BOUNDARY_CONDITIONS_VARIABLE)) THEN !This is wrong as we only have the mappings for the local rank not the global ranks. !For now assume 1-1 mapping between rows and dofs. - global_dof=global_row + ! In progress: Consider eigentransformations for constrained equations. + global_dof=global_row ! assumption!!! + INCLUDE_ROW=INCLUDE_ROW.AND.(BOUNDARY_CONDITIONS_VARIABLE%DOF_TYPES(global_dof)== & & BOUNDARY_CONDITION_DOF_FREE) CONSTRAINED_DOF=CONSTRAINED_DOF.OR.(BOUNDARY_CONDITIONS_VARIABLE%DOF_TYPES(global_dof)== & @@ -562,7 +565,10 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) CALL FlagError("Equations set is not associated.",ERR,ERROR,*999) ENDIF ENDDO !equations set idx + + ! DO THE SAME FOR INTERFACE BLOCKS!!! !Now add in rows from any interface matrices + !WHICH are transpose, THEN look at the columns!!! DO interface_condition_idx=1,SOLVER_MAPPING%NUMBER_OF_INTERFACE_CONDITIONS equations_idx=equations_idx+1 INTERFACE_CONDITION=>SOLVER_MAPPING%INTERFACE_CONDITIONS(interface_condition_idx)%PTR @@ -745,7 +751,7 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) CALL SolverMapping_InterfToSolMatMapsIMInitialise(SOLVER_MAPPING%INTERFACE_CONDITION_TO_SOLVER_MAP( & & interface_condition_idx)%INTERFACE_TO_SOLVER_MATRIX_MAPS_IM(interface_matrix_idx),ERR,ERROR,*999) - !Allocate the interfafce row to solver row maps + !Allocate the interface row to solver row maps ALLOCATE(SOLVER_MAPPING%INTERFACE_CONDITION_TO_SOLVER_MAP(interface_condition_idx)% & & INTERFACE_TO_SOLVER_MATRIX_MAPS_IM(interface_matrix_idx)%INTERFACE_ROW_TO_SOLVER_ROWS_MAP( & & INTERFACE_MAPPING%INTERFACE_MATRIX_ROWS_TO_VAR_MAPS(interface_matrix_idx)%TOTAL_NUMBER_OF_ROWS),STAT=ERR) @@ -760,7 +766,7 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) ENDDO !interface_matrix_idx - !Allocate the interface column to solver row maps + !Allocate the interface column(!!!!transpose!!!!!!) to solver row maps ALLOCATE(SOLVER_MAPPING%INTERFACE_CONDITION_TO_SOLVER_MAP(interface_condition_idx)% & & INTERFACE_COLUMN_TO_SOLVER_ROWS_MAPS(INTERFACE_MAPPING%TOTAL_NUMBER_OF_COLUMNS),STAT=ERR) IF(ERR/=0) & @@ -841,6 +847,8 @@ SUBROUTINE SOLVER_MAPPING_CALCULATE(SOLVER_MAPPING,ERR,ERROR,*) !Set up the row domain mappings. !There are no ghosted rows for the solver matrices so there is only one domain for the global to local map. !Initialise + ! THESE global to local will have to be replaced with MPI communication (reduction)!!!!!!!! + ! Knowledge of each rank about the rows in other ranks! CALL DOMAIN_MAPPINGS_MAPPING_GLOBAL_INITIALISE(ROW_DOMAIN_MAPPING%GLOBAL_TO_LOCAL_MAP( & & NUMBER_OF_GLOBAL_SOLVER_ROWS),ERR,ERROR,*999) !Allocate the global to local map arrays diff --git a/src/solver_matrices_routines.F90 b/src/solver_matrices_routines.F90 index 78f31486..3d181436 100644 --- a/src/solver_matrices_routines.F90 +++ b/src/solver_matrices_routines.F90 @@ -184,6 +184,8 @@ SUBROUTINE SOLVER_MATRICES_CREATE_FINISH(SOLVER_MATRICES,ERR,ERROR,*) ENTERS("SOLVER_MATRICES_CREATE_FINISH",ERR,ERROR,*998) +PRINT *, "We are here!!!!!!!!!1" + IF(ASSOCIATED(SOLVER_MATRICES)) THEN IF(SOLVER_MATRICES%SOLVER_MATRICES_FINISHED) THEN CALL FlagError("Solver matrices have already been finished",ERR,ERROR,*998) diff --git a/src/types.F90 b/src/types.F90 index f40a2c50..cb1ab302 100644 --- a/src/types.F90 +++ b/src/types.F90 @@ -77,6 +77,7 @@ MODULE Types USE ISO_VARYING_STRING USE Trees use linkedlist_routines + USE hash_routines IMPLICIT NONE @@ -847,7 +848,10 @@ MODULE Types TYPE DistributedMatrixCMISSType TYPE(DistributedMatrixType), POINTER :: distributedMatrix !Contains information for a PETSc distributed matrix @@ -1998,8 +2002,11 @@ MODULE Types TYPE(BOUNDARY_CONDITIONS_TYPE), POINTER :: BOUNDARY_CONDITIONS !Contains information used to integrate Neumann boundary conditions TYPE BoundaryConditionsNeumannType INTEGER(INTG), ALLOCATABLE :: setDofs(:) ! Date: Fri, 22 Jun 2018 16:02:47 +1200 Subject: [PATCH 6/9] Adding also hash routines. --- src/hash_routines.F90 | 912 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 912 insertions(+) create mode 100644 src/hash_routines.F90 diff --git a/src/hash_routines.F90 b/src/hash_routines.F90 new file mode 100644 index 00000000..212d98e8 --- /dev/null +++ b/src/hash_routines.F90 @@ -0,0 +1,912 @@ +!> HLinked List for 2xinteger data TYPE +! + Hash functions + +MODULE hash_routines + + USE BaseRoutines + USE INPUT_OUTPUT + USE CONSTANTS + USE KINDS + USE ISO_VARYING_STRING + USE STRINGS + USE ComputationEnvironment + +#include "macros.h" + + IMPLICIT NONE + +! delete me! +! INTEGER, PARAMETER :: tbl_size = 500 ! a "big" default size for the table + + PRIVATE ! by default + + ! TYPEs + + ! Items for Linked Lists with 2 entries + TYPE HashLinkedListItemType + integer(INTG) :: key + integer(INTG) :: value + TYPE(HashLinkedListItemType),pointer :: next => NULL() + END TYPE + + ! Linked Lists + TYPE HashLinkedListType + TYPE(HashLinkedListItemType),pointer :: root => NULL() + TYPE(HashLinkedListItemType),pointer :: last => NULL() + END TYPE + + ! Array of Linked Lists + TYPE HashListArrayType + TYPE(HashLinkedListType), ALLOCATABLE :: vec(:) + INTEGER(INTG) :: vec_len + LOGICAL(INTG) :: is_finished + END TYPE HashListArrayType + + ! The Hash Table + TYPE HashTableType + PRIVATE + LOGICAL :: HashTable_Finished ! initialises or adds a piece of data to list + SUBROUTINE HashLinkedListType_Add_Data(list,key, value, is_duplicate_key, ERR)!,ERROR) + + TYPE(HashLinkedListType),INTENT(INOUT) :: list + INTEGER(INTG),INTENT(IN) :: key, value + INTEGER(INTG), INTENT(OUT) :: ERR + LOGICAL, INTENT (OUT) :: is_duplicate_key + ! CHARACTER(LEN=*), INTENT(OUT) :: ERROR + ! local variables + TYPE(HashLinkedListItemType),pointer :: current + + ! ENTERS("HashLinkedListType_Add_Data",ERR,ERROR,*999) + + is_duplicate_key = .FALSE. + + if (associated(list%root)) then + current => list%root + do + ! key is there already + IF (current%key==key) then + is_duplicate_key = .TRUE. + EXIT ! do nothing + END if + + ! tail is reached + IF (.NOT. associated(current%next)) THEN + allocate(current%next) + current%next%key = key + current%next%value = value + list%last => current%next + EXIT + END IF + + ! proceed + current => current%next + + END DO + + ELSE ! list is empty: create root + + allocate(list%root) + list%root%key = key + list%root%value = value + list%last => list%root + END IF + + !EXITS("HashLinkedListType_Add_Data") + RETURN +!999 ERRORSEXITS("HashLinkedListType_Add_Data",ERR,ERROR) +! RETURN 1 + + END SUBROUTINE HashLinkedListType_Add_Data + + + SUBROUTINE HashLinkedListType_Get_Data(list,key, value, ERR) +!,ERROR) + + TYPE(HashLinkedListType),INTENT(INOUT) :: list + INTEGER(INTG),INTENT(IN) :: key + INTEGER(INTG),INTENT(OUT) :: value + INTEGER(INTG), INTENT(OUT) :: ERR + + ! local variables + TYPE(HashLinkedListItemType),pointer :: current + + ERR = 1000 ! set to 0 if a value is found + + if (associated(list%root)) then + current => list%root + do + ! key is found + IF (current%key==key)THEN + value = current%value + + ERR = 0 + + END IF + + ! tail is reached + IF (.NOT. associated(current%next)) THEN + ! value not found!!! + EXIT + END IF + + ! otherwise proceed + current => current%next + + END DO + END IF + ! if list is empty: do nothing + + END SUBROUTINE HashLinkedListType_Get_Data +! ------------------------------------------------------------------- + + !> adds all data from one list (addlist) to another (list) + Subroutine HashLinkedListType_Add_List(list,addlist,ERR,ERROR) + TYPE(HashLinkedListType),intent(inout) :: list + TYPE(HashLinkedListType),intent(in) :: addlist + INTEGER(INTG), INTENT(OUT) :: ERR + CHARACTER(LEN=*), INTENT(OUT) :: ERROR + LOGICAL :: is_found + ! local variables + TYPE(HashLinkedListItemType),pointer :: current + + if (HashLinkedListType_is_Empty(addlist)) return + + current => addlist%root + do + call HashLinkedListType_Add_Data(list,current%key, current%value, is_found, ERR) + !,ERROR) + !,*999) + if (associated(current%next)) then + current => current%next + else + exit + ENDif + ENDdo + +! EXITS("HashLinkedListType_Add_List") + RETURN +!999 ERRORSEXITS("HashLinkedListType_Add_List",ERR,ERROR) +! RETURN 1 + + END Subroutine HashLinkedListType_Add_List + +! ------------------------------------------------------------------- + + !> removes the first item from list and returns its value in data + Subroutine HashLinkedListType_Remove_First(list,key,value,ERR,ERROR,*) + TYPE(HashLinkedListType),intent(inout) :: list + integer(INTG),intent(out) :: key, value + INTEGER(INTG), INTENT(OUT) :: ERR + CHARACTER(LEN=*), INTENT(OUT) :: ERROR + ! local variables + TYPE(HashLinkedListItemType),pointer :: next + + IF (associated(list%root)) THEN + key = list%root%key + value = list%root%value + next => list%root%next + deallocate(list%root) + list%root => next + IF (associated(list%root)) THEN + if (.not.associated(list%root%next)) list%last => list%root ! only one left + ELSE + list%last => NULL() + ENDIF + ELSE + write(*,*) ">>> warning: HLinked list is empty and cannot remove first item" + ENDIF + + END Subroutine HashLinkedListType_Remove_First + +! ------------------------------------------------------------------- + + !> removes the last item from list and returns its value in data + Subroutine HashLinkedListType_Remove_Last(list,key,value,ERR,ERROR,*) + TYPE(HashLinkedListType),intent(inout) :: list + integer(INTG),intent(out) :: key,value + INTEGER(INTG), INTENT(OUT) :: ERR + CHARACTER(LEN=*), INTENT(OUT) :: ERROR + ! local variables + TYPE(HashLinkedListItemType),pointer :: current + + if (.not.associated(list%root)) then + write(*,*) ">>> warning: HLinked list is empty and cannot remove last item" + return + ENDif + current => list%root + + do + if (associated(current%next)) then + if (associated(current%next%next)) then + current => current%next + else + ! next one is the last one + key = current%next%key + value = current%next%value + deallocate(current%next) + current%next => NULL() + list%last => current + exit + ENDif + else + ! there must be only one item in the list(?)! + key = current%key + value = current%value + deallocate(list%root) + list%root => NULL() + list%last => NULL() + exit + ENDif + ENDdo + + END Subroutine HashLinkedListType_Remove_Last + +! ------------------------------------------------------------------- + + !> will delete and deallocate all items + Subroutine HashLinkedListType_Destroy(list,ERR) +!,ERROR) + + TYPE(HashLinkedListType), INTENT(inout) :: list + INTEGER(INTG), INTENT(OUT) :: ERR + ! CHARACTER(LEN=*), INTENT(OUT) :: ERROR + ! local variables + TYPE(HashLinkedListItemType), POINTER :: current,next + + if (.not.associated(list%root)) return + + current => list%root + do + if (associated(current%next)) then + next => current%next + deallocate(current) + current => next + else + deallocate(current) + exit + ENDif + ENDdo + + list%root => NULL() + list%last => NULL() + + END SUBROUTINE HashLinkedListType_Destroy + +! ------------------------------------------------------------------- + + !> returns true if the list is empty + Function HashLinkedListType_is_Empty(list) + TYPE(HashLinkedListType),intent(in) :: list + logical :: HashLinkedListType_is_Empty + + HashLinkedListType_is_Empty = .true. + if (associated(list%root)) HashLinkedListType_is_Empty = .false. + + END Function HashLinkedListType_is_Empty + +! ------------------------------------------------------------------- + + !> Returns length of list + SUBROUTINE HashLinkedListType_Size(list,n,ERR) + TYPE(HashLinkedListType),INTENT(IN) :: list + INTEGER(INTG), INTENT(OUT) :: n,ERR + + ! local variables + integer(INTG) :: i + TYPE(HashLinkedListItemType),pointer :: current + + ! return zero-size array if list is empty + IF (HashLinkedListType_is_Empty(list)) THEN + n=0 + RETURN + END IF + + ! Traversing to find size + current => list%root + n=1 + do + if (associated(current%next)) then + n=n+1 + current => current%next + else + exit + END IF + END DO + + END SUBROUTINE HashLinkedListType_Size + + !> copies out the data to an allocatable array of size 2xn + Subroutine HashLinkedListType_to_Array(list,array,ERR,ERROR,*) + TYPE(HashLinkedListType),intent(in) :: list + integer(INTG),allocatable,intent(out) :: array(:,:) + INTEGER(INTG), INTENT(OUT) :: ERR + CHARACTER(LEN=*), INTENT(OUT) :: ERROR + ! local variables + integer(INTG) :: i,n + TYPE(HashLinkedListItemType),pointer :: current + + ! return zero-size array if list is empty + if (HashLinkedListType_is_Empty(list)) then + allocate(array(0,0)) + return + ENDif + + ! first traversing to find size + current => list%root + n=1 + do + if (associated(current%next)) then + n=n+1 + current => current%next + else + exit + ENDif + ENDdo + + ! copy to array + if (allocated(array)) deallocate(array) + allocate(array(2,n),stat=err) + !IF (ERR/=0) CALL ... + current => list%root + do i=1,n + array(1,i)=current%key + array(2,i)=current%value + + current => current%next + ENDdo + + END Subroutine HashLinkedListType_to_Array + + !>Initialises a list and all its components + SUBROUTINE HashListArrayType_Initialise(tbl,ERR,ERROR,*) + + TYPE (HashListArrayType), POINTER :: tbl + INTEGER(INTG), INTENT(OUT) :: ERR !Starts the creation of a list and returns a pointer to the created list + SUBROUTINE HashListArrayType_CreateStart(tbl,ERR,ERROR,*) + + TYPE (HashListArrayType), POINTER :: tbl + INTEGER(INTG), INTENT(OUT) :: ERR !Finishes the creation of a table created with HashTable_CreateStart + SUBROUTINE HashTable_CreateFinish(Table,ERR,ERROR,*) + + !Argument Variables + TYPE(HashTableType), POINTER :: Table !Starts the creation of a hash table and returns a pointer to the created table. + SUBROUTINE HashTable_CreateStart(Table,ERR,ERROR,*) + + !Argument Variables + TYPE(HashTableType), POINTER :: Table !Initialises a tree + SUBROUTINE HashTable_Initialise(Table,ERR,ERROR,*) + + !Argument Variables + TYPE(HashTableType), POINTER :: Table !Table%p) CALL FlagError("Suitable k could not be found!",ERR,ERROR,*999) + END IF + + END DO + + ! Allocate T: T(0)=k, T(1),...,T(n) access indices, T(*) |W_j| T(**) k' T(***) = W_j + dim_T = 1+Table%n+2*count_fill+check_sum_sq + ALLOCATE (Table%T_key(0:(dim_T-1)),STAT=ERR) + IF(ERR/=0) CALL FlagError("Could not allocate T_key in table.",ERR,ERROR,*999) + ALLOCATE (Table%T_val(0:(dim_T-1)),STAT=ERR) + IF(ERR/=0) CALL FlagError("Could not allocate T_val in table.",ERR,ERROR,*999) + Table%T_key = 0 + Table%T_val = 0 + Table%T_key(0) = k + IF (dim_T<=Table%n+1) CALL FlagError("No keys to be assigned!",ERR,ERROR,*999) + + prev_ind = Table%n + + DO i=1,Table%n + + ! Cardinality of block W_i + CALL HashLinkedListType_Size(W_tbl%vec(i-1), card_w_store, ERR) + + IF (card_w_store == 0) THEN + Table%T_key(i) = 0 ! Block is empty + ELSE + + IF (prev_ind == Table%n) THEN + Table%T_key(i) = Table%n+1 ! First non-zero entry is just index that follows n + ELSE + ! Compute card of + ! CALL HashLinkedListType_Size(W_tbl%vec(prev_ind-1), card_w, ERR) + ! replaced with card_w = card_w_store below!!!! + Table%T_key(i) = Table%T_key(prev_ind)+2+card_w**2 + END IF + + Table%T_key(Table%T_key(i)) = card_w_store ! First element of each block: card of W + Table%T_key(Table%T_key(i)+1) = 1 ! Second element of each block: k' (set to 1) + + ALLOCATE (ind_in_T(card_w_store), STAT=ERR) ! ind_in_T contains the indices where keys will be stored in T for each block + IF(ERR/=0) CALL FlagError("Could not allocate ind_in_T in table.",ERR,ERROR,*999) + W_list_item = W_tbl%vec(i-1)%root ! take the first item in the block + j = 1 ! init j for do loop + + DO + ! function given by corollary 2 + ! gives LOCAL index + ! +2 translation + ind_in_T(j) = my_alg_module(my_alg_module(Table%T_key(Table%T_key(i)+1)*W_list_item%key,Table%p),card_w_store**2)+2 + IF ((j==1).OR. any(ind_in_T(1:(j-1))/=ind_in_T(j))) THEN ! insert items until conflict + + Table%T_key(ind_in_T(j)+Table%T_key(i)-1) = W_list_item%key + Table%T_val(ind_in_T(j)+Table%T_key(i)-1) = W_list_item%value + + IF (associated(W_list_item%next)) W_list_item = W_list_item%next + + IF (j==card_w_store) EXIT ! everything filled correctly + j = j+1 ! next key + + ELSE ! conflict: increase k' and start over + Table%T_key(Table%T_key(i)+1) =Table%T_key(Table%T_key(i)+1)+1 + Table%T_key(ind_in_T + Table%T_key(i)-1) = 0 ! reset to zero what already filled (keys) + Table%T_val(ind_in_T + Table%T_key(i)-1) = 0 ! reset to zero what already filled (values) + ind_in_T = 0 ! reset to zero indices + j = 1 ! reset j + W_list_item = W_tbl%vec(i-1)%root ! go back to list start + END IF + + END DO + + !PRINT *, "IND IN T", ind_in_T + DEALLOCATE(ind_in_T) + + prev_ind = i + card_w = card_w_store + END IF + + END DO + + + IF (ComputationalEnvironment_NodeNumberGet(ERR,ERROR)==0) THEN + print *, "T vector n ", Table%T_key (1:Table%n) + print *, "T vector rest ", Table%T_key (Table%n+1:) + print *, "T value vector rest ", Table%T_val (Table%n+1:) + print *, "of size ", size(Table%T_key) + END IF + + ! insert data in the list corresponding to hash index + ! CALL HashLinkedListType_Add_Data(tbl%vec(hash),key,val, ERR) + EXITS("HashTable_PutAll") + RETURN +999 CALL HashTable_Finalise(Table,dummyERR,dummyERROR,*998) +998 ERRORSEXITS("HashTable_PutAll",ERR,ERROR) + RETURN 1 + + END SUBROUTINE HashTable_PutAll + + SUBROUTINE HashTable_PutOne(Table, S_key_one, S_val_one, ERR,ERROR,*) + + TYPE (HashTableType), POINTER :: Table + INTEGER(INTG) :: length + INTEGER(INTG), ALLOCATABLE :: tmp_key(:), tmp_val(:) + + + INTEGER(INTG), INTENT(OUT) :: ERR !Finalises a hash table and deallocates all memory. + SUBROUTINE HashTable_Finalise(Table,ERR,ERROR,*) + + !Argument Variables + TYPE (HashTableType), POINTER :: Table ! Date: Thu, 12 Jul 2018 17:55:05 +0200 Subject: [PATCH 7/9] Hash implementation completed and tested in distributed_mv --- src/distributed_matrix_vector.F90 | 236 +++- src/hash_routines.F90 | 1936 +++++++++++++++++++++-------- src/lists.F90 | 113 +- src/solver_matrices_routines.F90 | 2 - src/types.F90 | 30 +- 5 files changed, 1712 insertions(+), 605 deletions(-) diff --git a/src/distributed_matrix_vector.F90 b/src/distributed_matrix_vector.F90 index 1e0c945b..53e2c2e9 100644 --- a/src/distributed_matrix_vector.F90 +++ b/src/distributed_matrix_vector.F90 @@ -60,6 +60,7 @@ MODULE DistributedMatrixVector #endif USE Strings USE Types + USE HashRoutines USE LINKEDLIST_ROUTINES #include "macros.h" @@ -976,9 +977,19 @@ SUBROUTINE DistributedMatrix_CMISSInitialise(distributedMatrix,err,error,*) TYPE(VARYING_STRING) :: dummyError,localError ! Hash variables - INTEGER(INTG), ALLOCATABLE :: S_key(:), S_val(:) - INTEGER(INTG) :: i,n, q, my_computational_node_number, index_found, value, tmp - LOGICAL :: is_found + INTEGER(INTG), ALLOCATABLE :: SKey(:) + INTEGER(INTG), ALLOCATABLE :: SIntVal(:,:) + REAL(SP), ALLOCATABLE :: SRealVal(:,:) + + INTEGER(INTG) :: i, n, q, myComputationalNodeNumber, indexFound, dataType, dataSize, newDataSize + LOGICAL :: isFound + + INTEGER(INTG), ALLOCATABLE :: valueInt(:) ! Allow for different returned value INT sizes + REAL(SP), ALLOCATABLE :: valueSp(:) ! Allow for different returned value SP sizes + + INTEGER(INTG), ALLOCATABLE :: valueIntMult(:,:) ! Same in case of multiple lists + REAL(SP), ALLOCATABLE :: valueSpMult (:,:) ! Same in case of multiple lists + INTEGER(INTG), ALLOCATABLE :: listNum(:) ! Array of list num for getting values from many lists ENTERS("DistributedMatrix_CMISSInitialise",err,error,*998) @@ -1015,62 +1026,169 @@ SUBROUTINE DistributedMatrix_CMISSInitialise(distributedMatrix,err,error,*) CALL FlagError(localError,err,error,*999) END SELECT -! START my hash implementation - -! use columnDomainMapping ltg info to create hash: -! hash type in type of distributedMatrix%cmiss, move in future? petsc already handles. OK -! cf. trees!!! USE SAME STYLE AND STRUCTURE (cf. Website!!)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! cf. err,error,*; enters, exits -! hash_create_start using columnDomainMapping: set defaults -! override (change) parameters, e.g. duplicates for tree, can be done here -! create_finish finish_flag = true! -! THEN, insert values, query, delete etc. (i.e. fill with relevant info) - -my_computational_node_number = ComputationalEnvironment_NodeNumberGet(ERR,ERROR) -IF (my_computational_node_number==1) THEN - PRINT*, "Print out the map", columnDomainMapping%LOCAL_TO_GLOBAL_MAP -END IF - -! Create the table if not done already -SELECT CASE (ASSOCIATED (distributedMatrix%cmiss%columnHashTable)) - -CASE (.FALSE.) ! No table yet: create and fill the column table -CALL HashTable_CreateStart(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) -!CALL TREE_INSERT_TYPE_SET(decompositionData%dataPointsTree,TREE_NO_DUPLICATES_ALLOWED,ERR,ERROR,*999) -CALL HashTable_CreateFinish(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) - -n = size(columnDomainMapping%LOCAL_TO_GLOBAL_MAP) -ALLOCATE(S_val(n-1),STAT=err) -IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) -S_val = [ (i, i=1,n-1)] ! test 1-element insertion - -ALLOCATE(S_key(n-1),STAT=err) -IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) -S_key = columnDomainMapping%LOCAL_TO_GLOBAL_MAP(1:(n-1)) - -! FIX ERROR HANDLING, STYLE etc. in hash_routines!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Insert keys values until n-1 -CALL HashTable_Insert(distributedMatrix%cmiss%columnHashTable, S_key, S_val, ERR, ERROR, *999) -! Test 1-element insertion and query -CALL HashTable_Insert(distributedMatrix%cmiss%columnHashTable, columnDomainMapping%LOCAL_TO_GLOBAL_MAP(n), n, ERR,ERROR,*999) - -! Test query for q -IF (my_computational_node_number==1) THEN - DO q=1,100 - CALL HashTable_Get(distributedMatrix%cmiss%columnHashTable, q, index_found, is_found, ERR, ERROR, *999) - !PRINT *, "Index ", index_found - IF (is_found) THEN - CALL HashTable_GetValue(distributedMatrix%cmiss%columnHashTable, index_found, value, ERR, ERROR, *999) - PRINT *, q, "Found! With value ", value - ELSE - PRINT *, q, "Key does not exist!" - END IF - END DO -END IF - -CASE (.TRUE.) -! Do nothing, Table already computed! -END SELECT + ! START my hash implementation + + ! use columnDomainMapping ltg info to create hash: + ! hash type in type of distributedMatrix%cmiss, move in future? petsc already handles. OK + + ! Decide data type of values to add to the table + dataType = LIST_SP_TYPE + ! dataType = LIST_INTG_TYPE + ! Decide data size of values + dataSize = 3 + + myComputationalNodeNumber = ComputationalEnvironment_NodeNumberGet(ERR,ERROR) + + IF (diagnostics1) THEN + CALL WriteStringVector(DIAGNOSTIC_OUTPUT_TYPE, 1,1, size(columnDomainMapping%LOCAL_TO_GLOBAL_MAP,1), & + & 4,4, columnDomainMapping%LOCAL_TO_GLOBAL_MAP, & + & '("Printing out the map :", 4(x,I8))','(23x,4(x,I8))', ERR, ERROR, *999) + END IF + + n = size(columnDomainMapping%LOCAL_TO_GLOBAL_MAP) + + ! Create a new table + ! If a table already exists, content is zeroed at CreateStart. + NULLIFY(distributedMatrix%cmiss%columnHashTable) + + CALL HashTable_CreateStart(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) + ! define some parameters here if needed + CALL HashTable_CreateFinish(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) + + + ! Create array of keys + ALLOCATE(SKey(n),STAT=err) + IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) + SKey = columnDomainMapping%LOCAL_TO_GLOBAL_MAP(1:n) + + + ! Create initial arrays of values + ALLOCATE(SIntVal(dataSize,n),STAT=err) + IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) + DO i=1,dataSize ! Just repeat the same (nonsense) info (= local numbering) + SIntVal(i,1:n)=[ (i, i=1,n)] +100 + END DO + + ALLOCATE(SRealVal(dataSize,n),STAT=err) + IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) + DO i=1,dataSize ! Just repeat the same (nonsense) info (= local numbering + real part) + SRealVal(i,1:n) = [ (i, i=1,n)] +100.15_SP + END DO + + SELECT CASE (dataType) + + CASE(LIST_INTG_TYPE) + + ! Create the list of values and compute the table based on the key array + ! Create a new table + ! .FALSE. = new table (no addition) + CALL HashTable_ValuesSetAndInsert(distributedMatrix%cmiss%columnHashTable, SKey(1:n-3), & + & SIntVal(1:dataSize,1:n-3), .FALSE., ERR, ERROR, *999) + + ! Test insertion to already created table + ! Recompute the table adding new keys and expand the list of values + ! .TRUE. = add new elements + CALL HashTable_ValuesSetAndInsert(distributedMatrix%cmiss%columnHashTable, SKey(n-2:n), & + & SIntVal(1:dataSize,n-2:n), .TRUE., ERR, ERROR, *999) + + CASE(LIST_SP_TYPE) + + ! Create the list of values and compute the table based on the key array + ! Create a new table + ! .FALSE. = new table (no addition) + CALL HashTable_ValuesSetAndInsert(distributedMatrix%cmiss%columnHashTable, SKey(1:n-3), & + & SRealVal(1:dataSize,1:n-3), .FALSE., ERR, ERROR, *999) + + ! Test insertion to already created table + ! Recompute the table adding new keys and expand the list of values + ! .TRUE. = add new elements + CALL HashTable_ValuesSetAndInsert(distributedMatrix%cmiss%columnHashTable, SKey(n-2:n), & + & SRealVal(1:dataSize,n-2:n), .TRUE., ERR, ERROR, *999) + + CASE DEFAULT + CALL FlagError("Invalid data type!!!",err,error,*999) + END SELECT + + + + ! Test query for q + IF (diagnostics1) THEN + DO q=1,50 + ! Get the INDEX in the input vector (Skey, SIntVal) where q is found in the table (+ flag isFound) + CALL HashTable_GetKey(distributedMatrix%cmiss%columnHashTable, q, indexFound, isFound, ERR, ERROR, *999) + IF (isFound) THEN + SELECT CASE (dataType) + CASE(LIST_INTG_TYPE) + CALL HashTable_GetValue(distributedMatrix%cmiss%columnHashTable, indexFound, valueInt, ERR, ERROR, *999) + ! PRINT *, q, "Found! With value ", valueInt + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "Key found: ", q, err, error, *999) + CALL WriteStringVector(DIAGNOSTIC_OUTPUT_TYPE, 1,1, size(valueInt,1), & + & 4,4, valueInt, & + & '("with value :", 4(x,I8))','(5x,4(x,I8))', ERR, ERROR, *999) + CASE(LIST_SP_TYPE) + CALL HashTable_GetValue(distributedMatrix%cmiss%columnHashTable, indexFound, valueSp, ERR, ERROR, *999) +! PRINT *, q, "Found! With value ", valueSp + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "Key found: ", q, err, error, *999) + CALL WriteStringVector(DIAGNOSTIC_OUTPUT_TYPE, 1,1, size(valueSp,1), & + & 4,4, valueSp, & + & '("with value :", 4(x,F8.4))','(5x,4(x,F8.4))', ERR, ERROR, *999) + CASE DEFAULT + CALL FlagError("Invalid data type!!!",err,error,*999) + END SELECT + ELSE + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "Key does not exist! ", q, err, error, *999) + END IF + END DO + END IF + + ! Add additional values to the existing ones in table%ListSVal as + ! table%arrayOfListSVal(i)%ptr + ! Can be called AFTER the table has been created (table%ListSVal should already exist) + ! Add INTEGER or REAL values of different dimension + newDataSize = 2 + ! List 2 + CALL HashTable_AdditionalValuesSet (distributedMatrix%cmiss%columnHashTable, & + & SRealVal(1:newDataSize+1,1:n), LIST_SP_TYPE, err,error,*999) + ! List 3 + CALL HashTable_AdditionalValuesSet (distributedMatrix%cmiss%columnHashTable, & + & SIntVal(1:newDataSize,1:n), LIST_INTG_TYPE, err,error,*999) + ! List 4 + CALL HashTable_AdditionalValuesSet (distributedMatrix%cmiss%columnHashTable, & + & SRealVal(1:newDataSize,1:n), LIST_SP_TYPE, err,error,*999) + + +! Test query in multiple values case for 1 key +! The obtained value (real or intg) is sized as #lists X max dimension of the data in all lists +! Then, there will be zeros if the value has smaller dimension. (Fix??) + IF (diagnostics1) THEN + q = 25 + CALL HashTable_GetKey(distributedMatrix%cmiss%columnHashTable, q, indexFound, isFound, ERR, ERROR, *999) + IF (isFound) THEN + CALL HashTable_GetValue(distributedMatrix%cmiss%columnHashTable, indexFound, valueSpMult, listNum, ERR, ERROR, *999) + DO i=1,size(listNum,1) + !PRINT *, q, "Found Real! With value ", valueSpMult(i,:), "in list number", listNum(i) + + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "Found in list number ", listNum(i), err, error, *999) + CALL WriteStringVector(DIAGNOSTIC_OUTPUT_TYPE, 1,1, size(valueSpMult(i,:),1), & + & 4,4, valueSpMult(i,:), & + & '("REAL SP value :", 4(x,F8.4))','(5x,4(x,F8.4))', ERR, ERROR, *999) + + END DO + CALL HashTable_GetValue(distributedMatrix%cmiss%columnHashTable, indexFound, valueIntMult, listNum, ERR, ERROR, *999) + DO i=1,size(listNum,1) + !PRINT *, q, "Found Integer! With value ", valueIntMult(i,:), "in list number", listNum(i) + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "Found in list number: ", listNum(i), err, error, *999) + CALL WriteStringVector(DIAGNOSTIC_OUTPUT_TYPE, 1,1, size(valueIntMult(i,:),1), & + & 4,4, valueIntMult(i,:), & + & '("INTEGER value :", 4(x,I8))','(5x,4(x,I8))', ERR, ERROR, *999) + END DO + + ELSE + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "Key does not exist! ", q, err, error, *999) + END IF + END IF + + STOP ! end my hash_implementation diff --git a/src/hash_routines.F90 b/src/hash_routines.F90 index 212d98e8..2e0e390f 100644 --- a/src/hash_routines.F90 +++ b/src/hash_routines.F90 @@ -1,7 +1,8 @@ -!> HLinked List for 2xinteger data TYPE -! + Hash functions +! Implements hash tables for static sets (i.e. do not change) as described in +! Fredman, Komlos and Szemeredi 1984 +! using (arrays of) Lists that allow for INTG or REAL (implemented SP) of different sizes as data content (values) -MODULE hash_routines +MODULE HashRoutines USE BaseRoutines USE INPUT_OUTPUT @@ -10,101 +11,128 @@ MODULE hash_routines USE ISO_VARYING_STRING USE STRINGS USE ComputationEnvironment + USE Types + USE Lists #include "macros.h" IMPLICIT NONE -! delete me! -! INTEGER, PARAMETER :: tbl_size = 500 ! a "big" default size for the table - PRIVATE ! by default + !Module parameters + INTEGER(INTG), PARAMETER :: HASH_INITIAL_ADDITIONAL_VALUES_SIZE=5 ! NULL() + PRIVATE + INTEGER(INTG) :: key + INTEGER(INTG) :: value + TYPE(HashLinkedListItemType),POINTER :: next => NULL() END TYPE ! Linked Lists TYPE HashLinkedListType - TYPE(HashLinkedListItemType),pointer :: root => NULL() - TYPE(HashLinkedListItemType),pointer :: last => NULL() + PRIVATE + TYPE(HashLinkedListItemType),POINTER :: root => NULL() + TYPE(HashLinkedListItemType),POINTER :: last => NULL() END TYPE + TYPE HashLinkedListPtrType + PRIVATE + TYPE(HashLinkedListType), POINTER :: ptr + END TYPE HashLinkedListPtrType + ! Array of Linked Lists TYPE HashListArrayType - TYPE(HashLinkedListType), ALLOCATABLE :: vec(:) - INTEGER(INTG) :: vec_len - LOGICAL(INTG) :: is_finished + PRIVATE + TYPE(HashLinkedListPtrType), ALLOCATABLE :: vec(:) + INTEGER(INTG) :: vecLen + LOGICAL(INTG) :: isFinished END TYPE HashListArrayType ! The Hash Table - TYPE HashTableType - PRIVATE - LOGICAL :: HashTable_Finished ! initialises or adds a piece of data to list - SUBROUTINE HashLinkedListType_Add_Data(list,key, value, is_duplicate_key, ERR)!,ERROR) + SUBROUTINE HashLinkedList_AddData(list,key, value, isDuplicateKey, err,error,*) + + !Argument Variables + TYPE(HashLinkedListType), POINTER :: list - TYPE(HashLinkedListType),INTENT(INOUT) :: list INTEGER(INTG),INTENT(IN) :: key, value - INTEGER(INTG), INTENT(OUT) :: ERR - LOGICAL, INTENT (OUT) :: is_duplicate_key - ! CHARACTER(LEN=*), INTENT(OUT) :: ERROR - ! local variables - TYPE(HashLinkedListItemType),pointer :: current - ! ENTERS("HashLinkedListType_Add_Data",ERR,ERROR,*999) + INTEGER(INTG), INTENT(OUT) :: err ! NULL() + + ENTERS("HashLinkedList_AddData",err,error,*999) - is_duplicate_key = .FALSE. + isDuplicateKey = .FALSE. - if (associated(list%root)) then + ! Allocate the list if not done already + IF(.NOT. ASSOCIATED(list)) THEN + ALLOCATE(list, STAT=err) + IF(err/=0) CALL FlagError("Could not allocate list",err,error,*999) + END IF + + IF(ASSOCIATED(list%root)) THEN current => list%root - do + DO ! key is there already - IF (current%key==key) then - is_duplicate_key = .TRUE. + IF(current%key==key) THEN + isDuplicateKey = .TRUE. EXIT ! do nothing - END if + END IF ! tail is reached - IF (.NOT. associated(current%next)) THEN - allocate(current%next) + IF(.NOT. ASSOCIATED(current%next)) THEN + ALLOCATE(current%next) current%next%key = key current%next%value = value list%last => current%next @@ -118,795 +146,1625 @@ SUBROUTINE HashLinkedListType_Add_Data(list,key, value, is_duplicate_key, ERR)!, ELSE ! list is empty: create root - allocate(list%root) + ALLOCATE(list%root) list%root%key = key list%root%value = value list%last => list%root END IF - !EXITS("HashLinkedListType_Add_Data") + EXITS("HashLinkedList_AddData") RETURN -!999 ERRORSEXITS("HashLinkedListType_Add_Data",ERR,ERROR) -! RETURN 1 +999 ERRORSEXITS("HashLinkedList_AddData",err,error) + RETURN 1 - END SUBROUTINE HashLinkedListType_Add_Data + END SUBROUTINE HashLinkedList_AddData +!================================================== - SUBROUTINE HashLinkedListType_Get_Data(list,key, value, ERR) -!,ERROR) + !> Returns length of list + SUBROUTINE HashLinkedList_Size(list,n,err,error,*) - TYPE(HashLinkedListType),INTENT(INOUT) :: list + ! argument variables + TYPE(HashLinkedListType), POINTER :: list + INTEGER(INTG), INTENT(OUT) :: n + INTEGER(INTG), INTENT(OUT) :: err ! NULL() + LOGICAL :: isEmpty + + ENTERS("HashLinkedList_Size", err, error, *999) + + ! Check if list is allocated + ! Return zero-size array also if list is empty + CALL HashLinkedList_IsEmpty(list, isEmpty, err, error, *999) + IF((.NOT. ASSOCIATED(list)).OR. isEmpty) THEN + n = 0 + ELSE + + ! Traversing to find size + current => list%root + n=1 + DO + IF(ASSOCIATED(current%next)) THEN + n=n+1 + current => current%next + ELSE + EXIT + END IF + END DO + + END IF + + + EXITS("HashLinkedList_Size") + RETURN +999 ERRORSEXITS("HashLinkedList_Size",err,error) + RETURN 1 + + END SUBROUTINE HashLinkedList_Size + +!================================================== + + SUBROUTINE HashLinkedList_GetData(list,key, value, isFound, err, error, *) + + ! argument variables + TYPE(HashLinkedListType), POINTER :: list INTEGER(INTG),INTENT(IN) :: key INTEGER(INTG),INTENT(OUT) :: value - INTEGER(INTG), INTENT(OUT) :: ERR + INTEGER(INTG), INTENT(OUT) :: err ! NULL() + LOGICAL :: isFound - ERR = 1000 ! set to 0 if a value is found + ENTERS("HashLinkedList_GetData", err, error, *999) + + isFound = .FALSE. + + IF(ASSOCIATED(list%root)) THEN - if (associated(list%root)) then - current => list%root - do + current => list%root + DO ! key is found - IF (current%key==key)THEN + IF(current%key==key)THEN value = current%value - ERR = 0 + isFound = .TRUE. END IF ! tail is reached - IF (.NOT. associated(current%next)) THEN - ! value not found!!! - EXIT - END IF + IF(.NOT. ASSOCIATED(current%next)) EXIT ! otherwise proceed current => current%next - - END DO + END DO + END IF - ! if list is empty: do nothing - END SUBROUTINE HashLinkedListType_Get_Data -! ------------------------------------------------------------------- - - !> adds all data from one list (addlist) to another (list) - Subroutine HashLinkedListType_Add_List(list,addlist,ERR,ERROR) - TYPE(HashLinkedListType),intent(inout) :: list - TYPE(HashLinkedListType),intent(in) :: addlist - INTEGER(INTG), INTENT(OUT) :: ERR - CHARACTER(LEN=*), INTENT(OUT) :: ERROR - LOGICAL :: is_found + EXITS("HashLinkedList_GetData") + RETURN +999 ERRORSEXITS("HashLinkedList_GetData",err,error) + RETURN 1 + + + END SUBROUTINE HashLinkedList_GetData + +!================================================== + + !> adds all data from one list (addList) to another (list) + SUBROUTINE HashLinkedList_AddList(list,addList,err,error, *) + + ! argument variables + TYPE(HashLinkedListType), POINTER :: list + TYPE(HashLinkedListType), POINTER :: addList + INTEGER(INTG), INTENT(OUT) :: err ! NULL() + + ENTERS("HashLinkedList_AddList", err, error, *999) - if (HashLinkedListType_is_Empty(addlist)) return + CALL HashLinkedList_IsEmpty(addList, isEmpty, err, error, *999) + IF(.NOT. isEmpty) THEN - current => addlist%root - do - call HashLinkedListType_Add_Data(list,current%key, current%value, is_found, ERR) - !,ERROR) - !,*999) - if (associated(current%next)) then + current => addList%root + DO + CALL HashLinkedList_AddData(list,current%key, current%value, isFound, err,error,*999) + IF(ASSOCIATED(current%next)) THEN current => current%next - else - exit - ENDif - ENDdo + ELSE + EXIT + END IF + END DO -! EXITS("HashLinkedListType_Add_List") + END IF + + EXITS("HashLinkedList_AddList") RETURN -!999 ERRORSEXITS("HashLinkedListType_Add_List",ERR,ERROR) -! RETURN 1 +999 ERRORSEXITS("HashLinkedList_AddList",err,error) + RETURN 1 - END Subroutine HashLinkedListType_Add_List + END SUBROUTINE HashLinkedList_AddList -! ------------------------------------------------------------------- +!================================================== !> removes the first item from list and returns its value in data - Subroutine HashLinkedListType_Remove_First(list,key,value,ERR,ERROR,*) - TYPE(HashLinkedListType),intent(inout) :: list - integer(INTG),intent(out) :: key, value - INTEGER(INTG), INTENT(OUT) :: ERR - CHARACTER(LEN=*), INTENT(OUT) :: ERROR - ! local variables - TYPE(HashLinkedListItemType),pointer :: next + SUBROUTINE HashLinkedList_RemoveFirst(list,key,value,err,error,*) + + ! Argument Variables + TYPE(HashLinkedListType), POINTER:: list + INTEGER(INTG),INTENT(OUT) :: key, value + INTEGER(INTG), INTENT(OUT) :: err ! list%root%next - deallocate(list%root) + DEALLOCATE(list%root) list%root => next - IF (associated(list%root)) THEN - if (.not.associated(list%root%next)) list%last => list%root ! only one left + IF(ASSOCIATED(list%root)) THEN + IF(.NOT.ASSOCIATED(list%root%next)) list%last => list%root ! only one left ELSE list%last => NULL() - ENDIF + END IF ELSE - write(*,*) ">>> warning: HLinked list is empty and cannot remove first item" - ENDIF + IF(diagnostics1) THEN + CALL WriteString(DIAGNOSTIC_OUTPUT_TYPE, & + & ">>> warning: Linked list is empty and first item cannot be removed.",err,error,*999) + ! write(*,*) ">>> warning: Linked list is empty and first item cannot be removed." + END IF + END IF - END Subroutine HashLinkedListType_Remove_First -! ------------------------------------------------------------------- + EXITS("HashLinkedList_RemoveFirst") + RETURN +999 ERRORSEXITS("HashLinkedList_RemoveFirst",err,error) + RETURN + + END SUBROUTINE HashLinkedList_RemoveFirst + +!================================================== !> removes the last item from list and returns its value in data - Subroutine HashLinkedListType_Remove_Last(list,key,value,ERR,ERROR,*) - TYPE(HashLinkedListType),intent(inout) :: list - integer(INTG),intent(out) :: key,value - INTEGER(INTG), INTENT(OUT) :: ERR - CHARACTER(LEN=*), INTENT(OUT) :: ERROR + SUBROUTINE HashLinkedList_RemoveLast(list,key,value,err,error,*) + + ! argument variables + TYPE(HashLinkedListType), POINTER :: list + INTEGER(INTG),INTENT(OUT) :: key,value + INTEGER(INTG), INTENT(OUT) :: err ! NULL() + + ENTERS("HashLinkedList_RemoveLast", err, error, *999) - if (.not.associated(list%root)) then - write(*,*) ">>> warning: HLinked list is empty and cannot remove last item" - return - ENDif + IF(.NOT.ASSOCIATED(list%root)) THEN + IF(diagnostics1) THEN + CALL WriteString(DIAGNOSTIC_OUTPUT_TYPE, & + & ">>> warning: Linked list is empty and last item cannot be removed.",err,error,*999) + END IF + !write(*,*) ">>> warning: Linked list is empty and last item cannot be removed." + GOTO 987 + END IF current => list%root - do - if (associated(current%next)) then - if (associated(current%next%next)) then + DO + IF(ASSOCIATED(current%next)) THEN + IF(ASSOCIATED(current%next%next)) THEN current => current%next - else + ELSE ! next one is the last one key = current%next%key value = current%next%value - deallocate(current%next) + DEALLOCATE(current%next) current%next => NULL() list%last => current - exit - ENDif - else + EXIT + END IF + ELSE ! there must be only one item in the list(?)! key = current%key value = current%value - deallocate(list%root) + DEALLOCATE(list%root) list%root => NULL() list%last => NULL() - exit - ENDif - ENDdo + EXIT + END IF + END DO + +987 EXITS("HashLinkedList_RemoveLast") + RETURN +999 ERRORSEXITS("HashLinkedList_RemoveLast",err,error) + RETURN - END Subroutine HashLinkedListType_Remove_Last + END SUBROUTINE HashLinkedList_RemoveLast -! ------------------------------------------------------------------- +!================================================== !> will delete and deallocate all items - Subroutine HashLinkedListType_Destroy(list,ERR) -!,ERROR) + SUBROUTINE HashLinkedList_Destroy(list,err,error, *) - TYPE(HashLinkedListType), INTENT(inout) :: list - INTEGER(INTG), INTENT(OUT) :: ERR - ! CHARACTER(LEN=*), INTENT(OUT) :: ERROR + ! argument variables + TYPE(HashLinkedListType), POINTER :: list + INTEGER(INTG), INTENT(OUT) :: err !NULL() + TYPE(HashLinkedListItemType), POINTER :: next=>NULL() - if (.not.associated(list%root)) return + ENTERS("HashLinkedList_Destroy", err, error, *999) + + IF(.NOT.ASSOCIATED(list%root)) GOTO 987 current => list%root - do - if (associated(current%next)) then + DO + IF(ASSOCIATED(current%next)) THEN next => current%next - deallocate(current) + DEALLOCATE(current) current => next - else - deallocate(current) - exit - ENDif - ENDdo + ELSE + DEALLOCATE(current) + EXIT + END IF + END DO list%root => NULL() list%last => NULL() + + ! deallocate memory + DEALLOCATE(list) - END SUBROUTINE HashLinkedListType_Destroy +987 EXITS("HashLinkedList_Destroy") + RETURN +999 ERRORSEXITS("HashLinkedList_Destroy",err,error) + RETURN -! ------------------------------------------------------------------- + END SUBROUTINE HashLinkedList_Destroy + +!================================================== !> returns true if the list is empty - Function HashLinkedListType_is_Empty(list) - TYPE(HashLinkedListType),intent(in) :: list - logical :: HashLinkedListType_is_Empty + SUBROUTINE HashLinkedList_IsEmpty(list, isEmpty, err, error, *) - HashLinkedListType_is_Empty = .true. - if (associated(list%root)) HashLinkedListType_is_Empty = .false. - - END Function HashLinkedListType_is_Empty + ! Argument Variables + TYPE(HashLinkedListType), POINTER :: list + LOGICAL, INTENT(OUT) :: isEmpty + INTEGER(INTG), INTENT(OUT) :: err ! Returns length of list - SUBROUTINE HashLinkedListType_Size(list,n,ERR) - TYPE(HashLinkedListType),INTENT(IN) :: list - INTEGER(INTG), INTENT(OUT) :: n,ERR - - ! local variables - integer(INTG) :: i - TYPE(HashLinkedListItemType),pointer :: current + isEmpty = .TRUE. - ! return zero-size array if list is empty - IF (HashLinkedListType_is_Empty(list)) THEN - n=0 - RETURN + IF(ASSOCIATED(list)) THEN + IF(ASSOCIATED(list%root)) isEmpty = .FALSE. END IF - ! Traversing to find size - current => list%root - n=1 - do - if (associated(current%next)) then - n=n+1 - current => current%next - else - exit - END IF - END DO + EXITS("HashLinkedList_IsEmpty") + RETURN +999 ERRORSEXITS("HashLinkedList_IsEmpty",err,error) + RETURN - END SUBROUTINE HashLinkedListType_Size + END SUBROUTINE HashLinkedList_IsEmpty + +!================================================== !> copies out the data to an allocatable array of size 2xn - Subroutine HashLinkedListType_to_Array(list,array,ERR,ERROR,*) - TYPE(HashLinkedListType),intent(in) :: list - integer(INTG),allocatable,intent(out) :: array(:,:) - INTEGER(INTG), INTENT(OUT) :: ERR - CHARACTER(LEN=*), INTENT(OUT) :: ERROR + SUBROUTINE HashLinkedList_ListToArray(list,array,err,error,*) + + ! argument variables + TYPE(HashLinkedListType),POINTER:: list + + INTEGER(INTG),ALLOCATABLE,INTENT(OUT) :: array(:,:) + INTEGER(INTG), INTENT(OUT) :: err ! NULL() + + ENTERS("HashLinkedList_ListToArray", err, error, *999) ! return zero-size array if list is empty - if (HashLinkedListType_is_Empty(list)) then - allocate(array(0,0)) - return - ENDif + CALL HashLinkedList_IsEmpty(list, isEmpty, err, error, *999) + IF(isEmpty) THEN + ALLOCATE(array(0,0), STAT=err) + IF(err/=0) CALL FlagError("Could not allocate list array",err,error,*999) + GOTO 987 + END IF ! first traversing to find size current => list%root n=1 - do - if (associated(current%next)) then + DO + IF(ASSOCIATED(current%next)) THEN n=n+1 current => current%next - else - exit - ENDif - ENDdo + ELSE + EXIT + END IF + END DO ! copy to array - if (allocated(array)) deallocate(array) - allocate(array(2,n),stat=err) - !IF (ERR/=0) CALL ... + IF(ALLOCATEd(array)) DEALLOCATE(array) + ALLOCATE(array(2,n),stat=err) + IF(err/=0) CALL FlagError("Could not allocate list array",err,error,*999) current => list%root - do i=1,n + DO i=1,n array(1,i)=current%key array(2,i)=current%value current => current%next - ENDdo + END DO - END Subroutine HashLinkedListType_to_Array +987 EXITS("HashLinkedList_ListToArray") + RETURN +999 ERRORSEXITS("HashLinkedList_ListToArray",err,error) + RETURN - !>Initialises a list and all its components - SUBROUTINE HashListArrayType_Initialise(tbl,ERR,ERROR,*) - - TYPE (HashListArrayType), POINTER :: tbl - INTEGER(INTG), INTENT(OUT) :: ERR !Starts the creation of a list array and returns a pointer to the created list + SUBROUTINE HashListArray_CreateStart(listArray,err,error,*) + + !Argument Variables + TYPE (HashListArrayType), POINTER :: listArray !Starts the creation of a list and returns a pointer to the created list - SUBROUTINE HashListArrayType_CreateStart(tbl,ERR,ERROR,*) - - TYPE (HashListArrayType), POINTER :: tbl - INTEGER(INTG), INTENT(OUT) :: ERR !Finishes the creation of a List Array created with HashListArray_CreateStart + SUBROUTINE HashListArray_CreateFinish(listArray,err,error,*) + + !Argument Variables + TYPE (HashListArrayType), POINTER :: listArray !Finalises a list array and deallocates all memory. + SUBROUTINE HashListArray_Finalise(listArray,err,error,*) - EXITS("HashListArrayType_CreateStart") + !Argument Variables + TYPE (HashListArrayType), POINTER :: listArray !Finishes the creation of a table created with HashTable_CreateStart - SUBROUTINE HashTable_CreateFinish(Table,ERR,ERROR,*) + SUBROUTINE HashTable_CreateFinish(table,err,error,*) !Argument Variables - TYPE(HashTableType), POINTER :: Table !Starts the creation of a hash table and returns a pointer to the created table. - SUBROUTINE HashTable_CreateStart(Table,ERR,ERROR,*) + SUBROUTINE HashTable_CreateStart(table,err,error,*) !Argument Variables - TYPE(HashTableType), POINTER :: Table !Initialises a tree - SUBROUTINE HashTable_Initialise(Table,ERR,ERROR,*) +!================================================== + + !>Initialises a hash table + SUBROUTINE HashTable_Initialise(table,err,error,*) !Argument Variables - TYPE(HashTableType), POINTER :: Table !NULL() + IF(ALLOCATED(table%vecTKey)) DEALLOCATE(table%vecTKey) + IF(ALLOCATED(table%vecTVal)) DEALLOCATE(table%vecTVal) + IF(ALLOCATED(table%vecSKey)) DEALLOCATE(table%vecSKey) + IF(ALLOCATED(table%arrayOfListSVal)) DEALLOCATE(table%arrayOfListSVal) ELSE - CALL FlagError("Table is not associated",ERR,ERROR,*999) - ENDIF + CALL FlagError("Table is not associated",err,error,*999) + END IF EXITS("HashTable_Initialise") RETURN -999 ERRORSEXITS("HashTable_Initialise",ERR,ERROR) +999 ERRORSEXITS("HashTable_Initialise",err,error) RETURN 1 END SUBROUTINE HashTable_Initialise - ! - !================================================================================================================================ - ! +!================================================== -! queries for a value q and returns index - SUBROUTINE HashTable_Get(Table, q, index_found, found, ERR, ERROR, *) +! Queries for a value q and returns index + SUBROUTINE HashTable_GetKey(table, q, indexFound, isFound, err, error, *) - TYPE(HashTableType), POINTER :: Table -! INTEGER(INTG), DIMENSION(:), ALLOCATABLE, INTENT(IN) :: T_key ! the vector of keys -! INTEGER(INTG), INTENT(IN) :: q, n, p ! queried value, size, and prime number - INTEGER(INTG), INTENT(IN) :: q ! queried value - INTEGER(INTG), INTENT(OUT) :: index_found - LOGICAL, INTENT(OUT) :: found ! if object has been found + !Argument variables + TYPE(HashTableType), POINTER :: table + INTEGER(INTG), INTENT(IN) :: q ! queried value + LOGICAL, INTENT(OUT) :: isFound ! if object has been found + INTEGER(INTG), INTENT(OUT) :: indexFound ! and corresponding index - TYPE(VARYING_STRING), INTENT(OUT) :: ERROR ! 1D List + + ENTERS("HashTable_ListIntValuesSet",err,error,*999) + + ! The size of the input: the values correspond to the rows of the input array + ! Dimension of data + listSizeY = size(vecSVal,1) + ! Number of entries (must correspond to number of keys, will be checked on insert) + listSizeX = size(vecSVal,2) + + CALL HashTable_ListInitialise (table, LIST_INTG_TYPE, listsizeX, listSizeY, addElements, err,error,*999) + + ! One-row case + IF (listSizeY==1) vecS1DVal = vecSVal(1,:) + + ! Add items (might be adding to an already filled list) + ! Resize before adding NEW items (otherwise ItemAdd would add unnecessary space) + IF (addElements) CALL List_Resize(table%listSVal, listSizeX, err, error, *999) + DO i = 1,listSizeX + IF (listSizeY==1) THEN + CALL List_ItemAdd(table%listSVal,vecS1DVal(i), err, error, *999) + ELSE + CALL List_ItemAdd(table%listSVal,vecSVal(:,i), err, error, *999) + END IF + END DO + + EXITS("HashTable_ListIntValuesSet") + RETURN +999 ERRORSEXITS("HashTable_ListIntValuesSet",err,error) + RETURN 1 + +END SUBROUTINE + +!================================================== + + + ! Build the list of SP values according to input + SUBROUTINE HashTable_ListRealSpValuesSet (table, vecSVal, addElements, err,error,*) + + ! Argument variables + TYPE(HashTableType), POINTER :: table + + REAL(SP), INTENT(IN) :: vecSVal(:,:) ! array of values + + LOGICAL, INTENT (IN) :: addElements + + TYPE(VARYING_STRING), INTENT(OUT) :: error ! 1D List + + ENTERS("HashTable_ListRealSpValuesSet",err,error,*999) + + ! The size of the input: the values correspond to the rows of the input array + ! Dimension of data + listSizeY = size(vecSVal,1) + ! Number of entries (must correspond to number of keys, will be checked on insert) + listSizeX = size(vecSVal,2) + + CALL HashTable_ListInitialise (table, LIST_SP_TYPE, listsizeX, listSizeY, addElements, err,error,*999) + + ! One-row case + IF (listSizeY==1) vecS1DVal = vecSVal(1,:) + + ! Add items (can be adding to an already filled list) + ! Resize before adding NEW items (otherwise ItemAdd would add unnecessary space) + IF (addElements) CALL List_Resize(table%listSVal, listSizeX, err, error, *999) + DO i = 1,listSizeX + IF (listSizeY==1) THEN + CALL List_ItemAdd(table%listSVal,vecS1DVal(i), err, error, *999) + ELSE + CALL List_ItemAdd(table%listSVal,vecSVal(:,i), err, error, *999) + END IF + END DO + + EXITS("HashTable_ListRealSpValuesSet") + RETURN +999 ERRORSEXITS("HashTable_ListRealSpValuesSet",err,error) + RETURN 1 + +END SUBROUTINE + +!================================================== + + ! Initialise the list of values independent of data type + SUBROUTINE HashTable_ListInitialise (table, dataType, listsizeX, listSizeY, addElements, err,error,*) + + ! Argument variables + TYPE(HashTableType), POINTER :: table + INTEGER(INTG), INTENT(IN) :: dataType, listsizeX, listSizeY + LOGICAL, INTENT(IN) :: addElements + + TYPE(VARYING_STRING), INTENT(OUT) :: error ! 1D List + + ENTERS("HashTable_AdditionalIntValuesSet",err,error,*999) + + ! The size of the input: the values correspond to the rows of the input array + ! Dimension of data + listSizeY = size(vecSVal,1) + ! Number of entries (must correspond to number of keys, will be checked on insert) + listSizeX = size(vecSVal,2) + + ! Init new list and return number in the list array + CALL HashTable_AdditionalValuesInit (table, dataType, listSizeX, listSizeY, listNum, err,error,*999) + + IF (listSizeY==1) vecS1DVal = vecSVal(1,:) + + ! Add items + DO j = 1,listSizeX + IF (listSizeY==1) THEN + CALL List_ItemAdd(table%arrayOfListSVal(listNum)%ptr,vecS1DVal(j), err, error, *999) + ELSE + CALL List_ItemAdd(table%arrayOfListSVal(listNum)%ptr,vecSVal(:,j), err, error, *999) + END IF + END DO + + EXITS("HashTable_AdditionalIntValuesSet") + RETURN +999 ERRORSEXITS("HashTable_AdditionalIntValuesSet",err,error) + RETURN 1 + +END SUBROUTINE + +!================================================== + + ! Build the list of additional REAL SP values according to input + SUBROUTINE HashTable_AdditionalRealSpValuesSet (table, vecSVal, dataType, err,error,*) + ! Argument variables + TYPE(HashTableType), POINTER :: table - ! Store S_key and S_val for future additions -! IF (PRESENT(S_key).AND.PRESENT(S_val)) THEN - Table%n = size(S_key,1) - IF (Table%n /= size(S_val,1)) CALL FlagError("Keys and values have different size!",ERR,ERROR,*999) - ALLOCATE(Table%S_key(Table%n), STAT=ERR) - IF(ERR/=0) CALL FlagError("Could not allocate S_key in table",ERR,ERROR,*999) - ALLOCATE(Table%S_val(Table%n), STAT=ERR) - IF(ERR/=0) CALL FlagError("Could not allocate S_val in table",ERR,ERROR,*999) - Table%S_key = S_key - Table%S_val = S_val - ! ELSE ! Make sure they are already there! - ! IF (.NOT. ALLOCATED(Table%S_key)) CALL FlagError("Keys are not present!",ERR,ERROR,*999) - ! IF (.NOT. ALLOCATED(Table%S_val)) CALL FlagError("Values are not present!",ERR,ERROR,*999) - ! Table%n = size(Table%S_key,1) - ! END IF + REAL(SP), INTENT(IN) :: vecSVal(:,:) ! array of values + INTEGER(INTG) :: dataType ! data type + + TYPE(VARYING_STRING), INTENT(OUT) :: error ! 1D List + + ENTERS("HashTable_AdditionalRealSpValuesSet",err,error,*999) + + ! The size of the input: the values correspond to the rows of the input array + ! Dimension of data + listSizeY = size(vecSVal,1) + ! Number of entries (must correspond to number of keys, will be checked on insert) + listSizeX = size(vecSVal,2) + + ! Init new list and return number in the list array + CALL HashTable_AdditionalValuesInit (table, dataType, listSizeX, listSizeY, listNum, err,error,*999) + + IF (listSizeY==1) vecS1DVal = vecSVal(1,:) + + ! Add items + DO j = 1,listSizeX + IF (listSizeY==1) THEN + CALL List_ItemAdd(table%arrayOfListSVal(listNum)%ptr,vecS1DVal(j), err, error, *999) + ELSE + CALL List_ItemAdd(table%arrayOfListSVal(listNum)%ptr,vecSVal(:,j), err, error, *999) + END IF + END DO + + EXITS("HashTable_AdditionalRealSpValuesSet") + RETURN +999 ERRORSEXITS("HashTable_AdditionalRealSpValuesSet",err,error) + RETURN 1 + +END SUBROUTINE + +!================================================== + + ! Initialise additional list of values (returns newly allocated list) + SUBROUTINE HashTable_AdditionalValuesInit (table, dataType, listSizeX, listSizeY, listNum, err,error,*) + + ! Argument variables + TYPE(HashTableType), POINTER :: table + + INTEGER(INTG), INTENT(IN) :: dataType, listSizeX, listSizeY + INTEGER(INTG), INTENT(OUT) :: listNum + + TYPE(VARYING_STRING), INTENT(OUT) :: error !NULL() ! Define the ptr to list as not associated + END DO + + CALL List_NumberOfItemsGet(table%listSVal, sizeInit, err, error, *999) + + IF (sizeInit /= listSizeX) THEN + DEALLOCATE(table%arrayOfListSVal) + CALL FlagError("Adding values of different size than keys in table!!", err, error,*999) + END IF + + ! First list in array is the one already provided in listSval (at table creation) + ! No need to initialise / finish new pointer. Just allocate. + ALLOCATE(table%arrayOfListSVal(1)%ptr,STAT=err) + IF(err/=0) CALL FlagError("Could not allocate array list 1.", err, error,*999) + table%arrayOfListSVal(1)%ptr = table%listSval + + END IF + + ! Allocate an additional list (look for the first free spot) + listNum = 2 + DO + IF (size(table%arrayOfListSVal)>=listNum) THEN + IF (.NOT. ASSOCIATED(table%arrayOfListSVal(listNum)%ptr)) THEN + CALL List_CreateStart(table%arrayOfListSVal(listNum)%ptr, err, error, *999) +! Defaults in initialise: +! LIST%LIST_FINISHED=.FALSE. +! LIST%MUTABLE=.FALSE. +! LIST%NUMBER_IN_LIST=0 +! LIST%DATA_DIMENSION=1 +! LIST%INITIAL_SIZE=10 +! LIST%SIZE=0 +! LIST%DATA_TYPE=LIST_INTG_TYPE +! LIST%KEY_DIMENSION=1 +! LIST%SORT_ORDER=LIST_SORT_ASCENDING_TYPE +! LIST%SORT_METHOD=LIST_HEAP_SORT_METHOD + + ! Let us create a list of intg of dim listSizeY + CALL List_DataDimensionSet(table%arrayOfListSVal(listNum)%ptr, listSizeY, err, error, *999) + CALL List_DataTypeSet (table%arrayOfListSVal(listNum)%ptr, dataType, err, error, *999) + ! Initial size listSizeX + CALL List_InitialSizeSet (table%arrayOfListSVal(listNum)%ptr, listSizeX, err, error, *999) + CALL List_CreateFinish (table%arrayOfListSVal(listNum)%ptr, err, error, *999) + EXIT + END IF + listNum = listNum+1 + ELSE + CALL FlagError("Number of additional lists exceeds initial allocation!",err,error,*999) + END IF + END DO + + EXITS("HashTable_AdditionalValuesInit") + RETURN +999 ERRORSEXITS("HashTable_AdditionalValuesInit",err,error) + RETURN 1 + +END SUBROUTINE + +!================================================== + + ! Create the list of values and call the hash table create routine + SUBROUTINE HashTable_IntValuesSetAndInsert(table, vecSKey, vecSVal, addElements, err,error,*) + ! Argument variables + TYPE(HashTableType), POINTER :: table + + INTEGER(INTG), INTENT(IN) :: vecSKey(:) ! array of keys + INTEGER(INTG), INTENT(IN) :: vecSVal(:,:) ! array of values + + LOGICAL, INTENT(IN) :: addElements ! adding to existing or new table + + TYPE(VARYING_STRING), INTENT(OUT) :: error !NULL() ! W as a pointer to an array of lists + TYPE(HashLinkedListItemType) :: subsetWListItem + INTEGER(INTG) :: cardSubsetW, storeCardSubsetW, checkSumW, checkSquaredSumW, countFilledSubsetW, indexSubsetW + ! related to array T + INTEGER(INTG) :: indexTLoop, sizeOfT, prevIndexT + INTEGER(INTG), ALLOCATABLE :: indexTArray (:), tmpKey(:) + ! related to Lists + INTEGER(INTG) :: listSize + + TYPE(VARYING_STRING) :: dummyError !Table%p) CALL FlagError("Suitable k could not be found!",ERR,ERROR,*999) + IF(k>table%p) CALL FlagError("Suitable k could not be found!",err,error,*999) END IF END DO ! Allocate T: T(0)=k, T(1),...,T(n) access indices, T(*) |W_j| T(**) k' T(***) = W_j - dim_T = 1+Table%n+2*count_fill+check_sum_sq - ALLOCATE (Table%T_key(0:(dim_T-1)),STAT=ERR) - IF(ERR/=0) CALL FlagError("Could not allocate T_key in table.",ERR,ERROR,*999) - ALLOCATE (Table%T_val(0:(dim_T-1)),STAT=ERR) - IF(ERR/=0) CALL FlagError("Could not allocate T_val in table.",ERR,ERROR,*999) - Table%T_key = 0 - Table%T_val = 0 - Table%T_key(0) = k - IF (dim_T<=Table%n+1) CALL FlagError("No keys to be assigned!",ERR,ERROR,*999) + sizeOfT = 1+table%n+2*countFilledSubsetW+checkSquaredSumW + ALLOCATE (table%vecTKey(0:(sizeOfT-1)),STAT=err) + IF(err/=0) CALL FlagError("Could not allocate vecTKey in table.",err,error,*999) + ALLOCATE (table%vecTVal(0:(sizeOfT-1)),STAT=err) + IF(err/=0) CALL FlagError("Could not allocate vecTVal in table.",err,error,*999) + table%vecTKey = 0 + table%vecTVal = 0 + table%vecTKey(0) = k + IF(sizeOfT<=table%n+1) CALL FlagError("No keys to be assigned!",err,error,*999) - prev_ind = Table%n + prevIndexT = table%n - DO i=1,Table%n + DO i=1,table%n ! Cardinality of block W_i - CALL HashLinkedListType_Size(W_tbl%vec(i-1), card_w_store, ERR) + CALL HashLinkedList_Size(subsetW%vec(i-1)%ptr, storeCardSubsetW, err,error,*999) - IF (card_w_store == 0) THEN - Table%T_key(i) = 0 ! Block is empty + IF(storeCardSubsetW == 0) THEN + table%vecTKey(i) = 0 ! Block is empty ELSE - IF (prev_ind == Table%n) THEN - Table%T_key(i) = Table%n+1 ! First non-zero entry is just index that follows n + IF(prevIndexT == table%n) THEN + table%vecTKey(i) = table%n+1 ! First non-zero entry is just index that follows n ELSE ! Compute card of - ! CALL HashLinkedListType_Size(W_tbl%vec(prev_ind-1), card_w, ERR) - ! replaced with card_w = card_w_store below!!!! - Table%T_key(i) = Table%T_key(prev_ind)+2+card_w**2 + ! CALL HashLinkedList_Size(subsetW%vec(prevIndexT-1), cardSubsetW, err) + ! replaced with cardSubsetW = storeCardSubsetW below!!!! + table%vecTKey(i) = table%vecTKey(prevIndexT)+2+cardSubsetW**2 END IF - Table%T_key(Table%T_key(i)) = card_w_store ! First element of each block: card of W - Table%T_key(Table%T_key(i)+1) = 1 ! Second element of each block: k' (set to 1) + table%vecTKey(table%vecTKey(i)) = storeCardSubsetW ! First element of each block: card of W + table%vecTKey(table%vecTKey(i)+1) = 1 ! Second element of each block: k' (set to 1) - ALLOCATE (ind_in_T(card_w_store), STAT=ERR) ! ind_in_T contains the indices where keys will be stored in T for each block - IF(ERR/=0) CALL FlagError("Could not allocate ind_in_T in table.",ERR,ERROR,*999) - W_list_item = W_tbl%vec(i-1)%root ! take the first item in the block + ALLOCATE (indexTArray(storeCardSubsetW), STAT=err) ! indexTArray contains the indices where keys will be stored in T for each block + IF(err/=0) CALL FlagError("Could not allocate indexTArray in table.",err,error,*999) + subsetWListItem = subsetW%vec(i-1)%ptr%root ! take the first item in the block j = 1 ! init j for do loop DO ! function given by corollary 2 ! gives LOCAL index ! +2 translation - ind_in_T(j) = my_alg_module(my_alg_module(Table%T_key(Table%T_key(i)+1)*W_list_item%key,Table%p),card_w_store**2)+2 - IF ((j==1).OR. any(ind_in_T(1:(j-1))/=ind_in_T(j))) THEN ! insert items until conflict + indexTArray(j) = MyAlgModule(MyAlgModule(table%vecTKey(table%vecTKey(i)+1)*subsetWListItem%key,table%p) & + & ,storeCardSubsetW**2)+2 + IF((j==1).OR. any(indexTArray(1:(j-1))/=indexTArray(j))) THEN ! insert items until conflict - Table%T_key(ind_in_T(j)+Table%T_key(i)-1) = W_list_item%key - Table%T_val(ind_in_T(j)+Table%T_key(i)-1) = W_list_item%value + table%vecTKey(indexTArray(j)+table%vecTKey(i)-1) = subsetWListItem%key + table%vecTVal(indexTArray(j)+table%vecTKey(i)-1) = subsetWListItem%value - IF (associated(W_list_item%next)) W_list_item = W_list_item%next + IF(ASSOCIATED(subsetWListItem%next)) subsetWListItem = subsetWListItem%next - IF (j==card_w_store) EXIT ! everything filled correctly + IF(j==storeCardSubsetW) EXIT ! everything filled correctly j = j+1 ! next key ELSE ! conflict: increase k' and start over - Table%T_key(Table%T_key(i)+1) =Table%T_key(Table%T_key(i)+1)+1 - Table%T_key(ind_in_T + Table%T_key(i)-1) = 0 ! reset to zero what already filled (keys) - Table%T_val(ind_in_T + Table%T_key(i)-1) = 0 ! reset to zero what already filled (values) - ind_in_T = 0 ! reset to zero indices + table%vecTKey(table%vecTKey(i)+1) =table%vecTKey(table%vecTKey(i)+1)+1 + + DO indexTLoop =1,size(indexTArray,1) + table%vecTKey(indexTArray(indexTLoop) + table%vecTKey(i)-1) = 0 ! reset to zero what already filled (keys) + table%vecTVal(indexTArray(indexTLoop) + table%vecTKey(i)-1) = 0 ! reset to zero what already filled (values) + END DO + + indexTArray = 0 ! reset to zero indices j = 1 ! reset j - W_list_item = W_tbl%vec(i-1)%root ! go back to list start + subsetWListItem = subsetW%vec(i-1)%ptr%root ! go back to list start END IF END DO - !PRINT *, "IND IN T", ind_in_T - DEALLOCATE(ind_in_T) + !PRINT *, "IND IN T", indexTArray + DEALLOCATE(indexTArray) - prev_ind = i - card_w = card_w_store + prevIndexT = i + cardSubsetW = storeCardSubsetW END IF END DO + ! Destroy the list array of Ws + CALL HashListArray_Finalise(subsetW, dummyErr,dummyError,*998) - IF (ComputationalEnvironment_NodeNumberGet(ERR,ERROR)==0) THEN - print *, "T vector n ", Table%T_key (1:Table%n) - print *, "T vector rest ", Table%T_key (Table%n+1:) - print *, "T value vector rest ", Table%T_val (Table%n+1:) - print *, "of size ", size(Table%T_key) - END IF + ! DEALLOCATE local memory + IF(ALLOCATED(indexTArray)) DEALLOCATE(indexTArray) - ! insert data in the list corresponding to hash index - ! CALL HashLinkedListType_Add_Data(tbl%vec(hash),key,val, ERR) - EXITS("HashTable_PutAll") - RETURN -999 CALL HashTable_Finalise(Table,dummyERR,dummyERROR,*998) -998 ERRORSEXITS("HashTable_PutAll",ERR,ERROR) - RETURN 1 + ! Diagnostics instead of print + IF(diagnostics1) THEN - END SUBROUTINE HashTable_PutAll + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "The number of keys n: ", table%n, err, error, *999) - SUBROUTINE HashTable_PutOne(Table, S_key_one, S_val_one, ERR,ERROR,*) + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "The size of the array T: ", size(table%vecTKey,1), err, error, *999) - TYPE (HashTableType), POINTER :: Table - INTEGER(INTG) :: length - INTEGER(INTG), ALLOCATABLE :: tmp_key(:), tmp_val(:) + CALL WriteStringValue(DIAGNOSTIC_OUTPUT_TYPE, "The value of k = T(0): ", table%vecTkey(0), err, error, *999) + CALL WriteStringVector(DIAGNOSTIC_OUTPUT_TYPE, 2,1, table%n+1, 4,4, table%vecTKey, & + & '("T(1) to T(n) (indices to T blocks):", 4(x,I8))','(35x,4(x,I8))', err, error, *999) - INTEGER(INTG), INTENT(OUT) :: ERR !Writes the given INTEGER VECTOR to the given output stream specified by ID. The FIRST_FORMAT is the format initially used, followed by the REPEAT_FORMAT which is repeated as many times as necessary. NUMBER_FIRST is the number of data items in the FIRST_FORMAT and NUMBER_REPEAT is the number of data items in the REPEAT_FORMAT. FIRST_IDX and LAST_IDX are the extents of the data and DELTA is the NUMBER of indices to skip for each index. +! CALL WRITE_STRING_VECTOR(DIAGNOSTIC_OUTPUT_TYPE,1,1,DOMAIN_LINE%BASIS%NUMBER_OF_NODES,4,4,DOMAIN_LINE%NODES_IN_LINE, & +! & '(" Nodes in line :",4(X,I8))','(30X,4(X,I8))',err,error,*999) - ALLOCATE(tmp_key(length+1), STAT=ERR) - IF(ERR/=0) CALL FlagError("Could not allocate tmp in table.",ERR,ERROR,*999) +! SUBROUTINE WRITE_STRING_VECTOR_DP(ID,FIRST_IDX,DELTA,LAST_IDX, NUMBER_FIRST,NUMBER_REPEAT,VECTOR,FIRST_FORMAT,REPEAT_FORMAT, & +! & err,error,*) - tmp_key(1:length) = Table%S_key - tmp_key(length+1) = S_key_one -! CALL MOVE_ALLOC(tmp, Table%S_key) + !print *, "n ", table%n + !print *, "T vector n ", table%vecTKey (1:table%n) + !print *, "T vector rest ", table%vecTKey (table%n+1:) + !print *, "T value vector rest ", table%vecTVal (table%n+1:) + !print *, "of size ", size(table%vecTKey) + END IF - ALLOCATE(tmp_val(length+1), STAT=ERR) - IF(ERR/=0) CALL FlagError("Could not allocate tmp in table.",ERR,ERROR,*999) - - tmp_val(1:length) = Table%S_val - tmp_val(length+1) = S_val_one -! CALL MOVE_ALLOC(tmp, Table%S_val) - - ! Recompute the table. - CALL HashTable_PutAll(Table, tmp_key, tmp_val, ERR,ERROR,*999) - - EXITS("HashTable_PutOne") + EXITS("HashTable_Insert") RETURN -999 CALL HashTable_Finalise(Table,DUMMY_ERR,DUMMY_ERROR,*998) -998 ERRORSEXITS("HashTable_PutOne",ERR,ERROR) +999 CALL HashTable_Finalise(Table,dummyErr,dummyError,*998) +998 ERRORSEXITS("HashTable_Insert",err,error) RETURN 1 - END SUBROUTINE HashTable_PutOne + END SUBROUTINE HashTable_Insert + +!================================================== !>Finalises a hash table and deallocates all memory. - SUBROUTINE HashTable_Finalise(Table,ERR,ERROR,*) + SUBROUTINE HashTable_Finalise(table,err,error,*) !Argument Variables - TYPE (HashTableType), POINTER :: Table !Detaches the list values from a list and returns them as a pointer to a array of base type before destroying the list \see Lists. + !>Detaches the list values from a list and returns them as a pointer to an array of base type before destroying the list \see Lists. INTERFACE LIST_DETACH_AND_DESTROY MODULE PROCEDURE LIST_DETACH_AND_DESTROY_INTG1 MODULE PROCEDURE LIST_DETACH_AND_DESTROY_INTG2 @@ -122,7 +122,7 @@ MODULE LISTS MODULE PROCEDURE LIST_DETACH_AND_DESTROY_DP2 END INTERFACE LIST_DETACH_AND_DESTROY - !>Detaches the list values from a list and returns them as a pointer to a array of base type before destroying the list \see Lists. + !>Detaches the list values from a list and returns them as a pointer to an array of base type before destroying the list \see Lists. INTERFACE List_DetachAndDestroy MODULE PROCEDURE LIST_DETACH_AND_DESTROY_INTG1 MODULE PROCEDURE LIST_DETACH_AND_DESTROY_INTG2 @@ -412,6 +412,8 @@ MODULE LISTS PUBLIC LIST_SUBSET_OF PUBLIC List_SubsetOf + + PUBLIC List_Resize CONTAINS @@ -548,7 +550,7 @@ END SUBROUTINE LIST_DATA_DIMENSION_SET !================================================================================================================================ ! - !>Sets/changes the data dimension for a list. + !>Sets/changes the mutability for a list. SUBROUTINE LIST_MUTABLE_SET(LIST,MUTABLE,ERR,ERROR,*) !Argument Variables @@ -898,6 +900,110 @@ SUBROUTINE LIST_INITIAL_SIZE_SET(LIST,INITIAL_SIZE,ERR,ERROR,*) RETURN 1 END SUBROUTINE LIST_INITIAL_SIZE_SET + ! + !================================================================================================================================ + ! + + !>Resizes the list with a given size + ! Should be called BEFORE item_add to avoid doubling size + SUBROUTINE List_Resize(list,newAddSize,err,error,*) + !Argument Variables + TYPE(LIST_TYPE), POINTER, INTENT(INOUT) :: LIST ! 1) for integer lists. END TYPE LIST_TYPE + + + ! + !================================================================================================================================ + ! + ! Hash Table type + ! + TYPE HashTableType + !PRIVATE ! derived-type definition can be accessed outside (public), but not the components (below) + + LOGICAL :: hashTableFinished ! Date: Mon, 6 Aug 2018 13:37:41 +0200 Subject: [PATCH 8/9] Simplex fix --- src/basis_routines.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/basis_routines.F90 b/src/basis_routines.F90 index 98f14871..b26d709e 100644 --- a/src/basis_routines.F90 +++ b/src/basis_routines.F90 @@ -6936,7 +6936,7 @@ SUBROUTINE Gauss_Simplex(order,numberOfVertices,n,x,w,err,error,*) CALL FlagError(localError,err,error,*999) ENDIF !Gauss point 1 - x(1,1)=1.0_DP/2.0 + x(1,1)=1.0_DP/2.0_DP x(2,1)=1.0_DP/2.0_DP w(1)=1.0_DP CASE(2) @@ -6993,7 +6993,7 @@ SUBROUTINE Gauss_Simplex(order,numberOfVertices,n,x,w,err,error,*) ENDIF !Gauss point 1 x(1,1)=(1.0_DP-SQRT(0.6_DP))/2.0_DP - x(2,1)=1-x(1,1) + x(2,1)=1.0_DP-x(1,1) w(1)=5.0_DP/18.0_DP !Gauss point 2 x(1,2)=1.0_DP/2.0_DP @@ -7017,7 +7017,7 @@ SUBROUTINE Gauss_Simplex(order,numberOfVertices,n,x,w,err,error,*) ENDIF !Gauss point 1 x(1,1)=(1.0_DP-SQRT(0.6_DP))/2.0_DP - x(2,1)=1-x(1,1) + x(2,1)=1.0_DP-x(1,1) w(1)=5.0_DP/18.0_DP !Gauss point 2 x(1,2)=1.0_DP/2.0_DP @@ -7099,8 +7099,8 @@ SUBROUTINE Gauss_Simplex(order,numberOfVertices,n,x,w,err,error,*) CALL FlagError(localError,err,error,*999) ENDIF lC=1.0_DP/3.0_DP - wC=-9.0_DP/16.0 - alpha1=25.0_DP + wC=-3.0_DP/4.0_DP + alpha1=2.0_DP/5.0_DP wAlpha1=25.0_DP/48.0_DP l1Alpha1=(1.0_DP+2.0_DP*alpha1)/3.0_DP l2Alpha1=(1.0_DP-alpha1)/3.0_DP From f43a3f81284b482a11f3c9888cac02a2ebc13dcd Mon Sep 17 00:00:00 2001 From: lorenzo-mechbau Date: Tue, 25 Sep 2018 12:28:01 +0200 Subject: [PATCH 9/9] Style adjustments --- src/distributed_matrix_vector.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/distributed_matrix_vector.F90 b/src/distributed_matrix_vector.F90 index 53e2c2e9..7dcf4ee2 100644 --- a/src/distributed_matrix_vector.F90 +++ b/src/distributed_matrix_vector.F90 @@ -1032,7 +1032,7 @@ SUBROUTINE DistributedMatrix_CMISSInitialise(distributedMatrix,err,error,*) ! hash type in type of distributedMatrix%cmiss, move in future? petsc already handles. OK ! Decide data type of values to add to the table - dataType = LIST_SP_TYPE + dataType = LIST_SP_TYPE ! dataType = LIST_INTG_TYPE ! Decide data size of values dataSize = 3 @@ -1055,13 +1055,11 @@ SUBROUTINE DistributedMatrix_CMISSInitialise(distributedMatrix,err,error,*) ! define some parameters here if needed CALL HashTable_CreateFinish(distributedMatrix%cmiss%columnHashTable,ERR,ERROR,*999) - ! Create array of keys ALLOCATE(SKey(n),STAT=err) IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999) SKey = columnDomainMapping%LOCAL_TO_GLOBAL_MAP(1:n) - ! Create initial arrays of values ALLOCATE(SIntVal(dataSize,n),STAT=err) IF(ERR/=0) CALL FlagError("Could not allocate array",ERR,ERROR,*999)