OpenCMISS-Iron Internal API Documentation
mesh_routines.f90
Go to the documentation of this file.
1 
43 
45 MODULE mesh_routines
46 
47  USE base_routines
48  USE basis_routines
49  USE cmiss_mpi
50  USE cmiss_parmetis
51  USE comp_environment
52  USE coordinate_routines
53  USE domain_mappings
54  USE kinds
55  USE input_output
56  USE iso_varying_string
57  USE lists
58 #ifndef NOMPIMOD
59  USE mpi
60 #endif
61  USE node_routines
62  USE strings
63  USE trees
64  USE types
65 
66 #include "macros.h"
67 
68  IMPLICIT NONE
69 
70 #ifdef NOMPIMOD
71 #include "mpif.h"
72 #endif
73 
74  PRIVATE
75 
76  !Module parameters
77 
82  INTEGER(INTG), PARAMETER :: decomposition_all_type=1
83  INTEGER(INTG), PARAMETER :: decomposition_calculated_type=2
84  INTEGER(INTG), PARAMETER :: decomposition_user_defined_type=3
86 
87  !Module types
88 
89  !Module variables
90 
91  !Interfaces
92 
94  INTERFACE mesh_create_start
95  MODULE PROCEDURE mesh_create_start_interface
96  MODULE PROCEDURE mesh_create_start_region
97  END INTERFACE !MESH_CREATE_START
98 
100  INTERFACE meshes_initialise
101  MODULE PROCEDURE meshes_initialise_interface
102  MODULE PROCEDURE meshes_initialise_region
103  END INTERFACE !MESHES_INITIALISE
104 
105  INTERFACE mesh_user_number_find
106  MODULE PROCEDURE mesh_user_number_find_interface
107  MODULE PROCEDURE mesh_user_number_find_region
108  END INTERFACE !MESH_USER_NUMBER_FIND
109 
110  INTERFACE meshtopologynodecheckexists
111  MODULE PROCEDURE meshtopologynodecheckexistsmesh
112  MODULE PROCEDURE meshtopologynodecheckexistsmeshnodes
113  END INTERFACE meshtopologynodecheckexists
114 
115  INTERFACE meshtopologyelementcheckexists
116  MODULE PROCEDURE meshtopologyelementcheckexistsmesh
117  MODULE PROCEDURE meshtopologyelementcheckexistsmeshelements
118  END INTERFACE meshtopologyelementcheckexists
119 
120  PUBLIC decomposition_all_type,decomposition_calculated_type,decomposition_user_defined_type
121 
122  PUBLIC decompositions_initialise,decompositions_finalise
123 
124  PUBLIC decomposition_create_start,decomposition_create_finish
125 
126  PUBLIC decomposition_destroy
127 
128  PUBLIC decomposition_element_domain_calculate
129 
130  PUBLIC decomposition_element_domain_get,decomposition_element_domain_set
131 
132  PUBLIC decomposition_mesh_component_number_get,decomposition_mesh_component_number_set
133 
134  PUBLIC decomposition_number_of_domains_get,decomposition_number_of_domains_set
135 
136  PUBLIC decomposition_topology_element_check_exists,decompositiontopology_datapointcheckexists
137 
138  PUBLIC decompositiontopology_dataprojectioncalculate
139 
140  PUBLIC decompositiontopology_elementdatapointlocalnumberget
141 
142  PUBLIC decompositiontopology_elementdatapointusernumberget
143 
144  PUBLIC decompositiontopology_numberofelementdatapointsget
145 
146  PUBLIC decomposition_type_get,decomposition_type_set
147 
148  PUBLIC decomposition_user_number_find, decomposition_user_number_to_decomposition
149 
150  PUBLIC decomposition_node_domain_get
151 
152  PUBLIC decomposition_calculate_lines_set,decomposition_calculate_faces_set
153 
154  PUBLIC domain_topology_node_check_exists
155 
156  PUBLIC domaintopology_elementbasisget
157 
158  PUBLIC meshtopologyelementcheckexists,meshtopologynodecheckexists
159 
160  PUBLIC mesh_create_start,mesh_create_finish
161 
162  PUBLIC mesh_destroy
163 
164  PUBLIC mesh_number_of_components_get,mesh_number_of_components_set
165 
166  PUBLIC mesh_number_of_elements_get,mesh_number_of_elements_set
167 
168  PUBLIC mesh_topology_elements_create_start,mesh_topology_elements_create_finish
169 
170  PUBLIC mesh_topology_elements_destroy
171 
172  PUBLIC mesh_topology_elements_element_basis_get,mesh_topology_elements_element_basis_set
173 
174  PUBLIC mesh_topology_elements_adjacent_element_get
175 
176  PUBLIC mesh_topology_elements_element_nodes_get
177 
178  PUBLIC mesh_topology_elements_element_nodes_set,meshelements_elementnodeversionset
179 
180  PUBLIC mesh_topology_elements_get
181 
182  PUBLIC meshelements_elementusernumberget,meshelements_elementusernumberset
183 
184  PUBLIC meshtopologyelementsusernumbersallset
185 
186  PUBLIC meshtopologydatapointscalculateprojection
187 
188  PUBLIC meshtopologynodederivativesget
189 
190  PUBLIC meshtopologynodenumberofderivativesget
191 
192  PUBLIC meshtopologynodenumberofversionsget
193 
194  PUBLIC meshtopologynodesnumberofnodesget
195 
196  PUBLIC meshtopologynodesdestroy
197 
198  PUBLIC meshtopologynodesget
199 
200  PUBLIC mesh_user_number_find, mesh_user_number_to_mesh
201 
202  PUBLIC mesh_surrounding_elements_calculate_set
203 
204  PUBLIC mesh_embedding_create,mesh_embedding_set_child_node_position
205 
206  PUBLIC mesh_embedding_set_gauss_point_data
207 
208  PUBLIC meshes_initialise,meshes_finalise
209 
210 CONTAINS
211 
212  !
213  !================================================================================================================================
214  !
215 
217  SUBROUTINE decomposition_adjacent_element_finalise(DECOMPOSITION_ADJACENT_ELEMENT,ERR,ERROR,*)
218 
219  !Argument variables
220  TYPE(decomposition_adjacent_element_type) :: decomposition_adjacent_element
221  INTEGER(INTG), INTENT(OUT) :: err
222  TYPE(varying_string), INTENT(OUT) :: error
223  !Local Variables
224 
225  enters("DECOMPOSITION_ADJACENT_ELEMENT_FINALISE",err,error,*999)
226 
227  decomposition_adjacent_element%NUMBER_OF_ADJACENT_ELEMENTS=0
228  IF(ALLOCATED(decomposition_adjacent_element%ADJACENT_ELEMENTS)) DEALLOCATE(decomposition_adjacent_element%ADJACENT_ELEMENTS)
229 
230  exits("DECOMPOSITION_ADJACENT_ELEMENT_FINALISE")
231  RETURN
232 999 errorsexits("DECOMPOSITION_ADJACENT_ELEMENT_FINALISE",err,error)
233  RETURN 1
234 
235  END SUBROUTINE decomposition_adjacent_element_finalise
236 
237  !
238  !================================================================================================================================
239  !
241  SUBROUTINE decomposition_adjacent_element_initialise(DECOMPOSITION_ADJACENT_ELEMENT,ERR,ERROR,*)
242 
243  !Argument variables
244  TYPE(decomposition_adjacent_element_type) :: decomposition_adjacent_element
245  INTEGER(INTG), INTENT(OUT) :: err
246  TYPE(varying_string), INTENT(OUT) :: error
247  !Local Variables
248 
249  enters("DECOMPOSITION_ADJACENT_ELEMENT_INITIALISE",err,error,*999)
250 
251  decomposition_adjacent_element%NUMBER_OF_ADJACENT_ELEMENTS=0
252 
253  exits("DECOMPOSITION_ADJACENT_ELEMENT_INITIALISE")
254  RETURN
255 999 errorsexits("DECOMPOSITION_ADJACENT_ELEMENT_INITIALISE",err,error)
256  RETURN 1
257 
258  END SUBROUTINE decomposition_adjacent_element_initialise
259 
260  !
261  !================================================================================================================================
262  !
263 
265  SUBROUTINE decomposition_create_finish(DECOMPOSITION,ERR,ERROR,*)
266 
267  !Argument variables
268  TYPE(decomposition_type), POINTER :: decomposition
269  INTEGER(INTG), INTENT(OUT) :: err
270  TYPE(varying_string), INTENT(OUT) :: error
271  !Local Variables
272  INTEGER(INTG) :: decomposition_no
273  TYPE(mesh_type), POINTER :: mesh
274 
275  enters("DECOMPOSITION_CREATE_FINISH",err,error,*999)
276 
277  IF(ASSOCIATED(decomposition)) THEN
278  !Calculate which elements belong to which domain
279  CALL decomposition_element_domain_calculate(decomposition,err,error,*999)
280  !Initialise the topology information for this decomposition
281  CALL decomposition_topology_initialise(decomposition,err,error,*999)
282  !Initialise the domain for this computational node
283  CALL domain_initialise(decomposition,err,error,*999)
284  !Calculate the decomposition topology
285  CALL decomposition_topology_calculate(decomposition,err,error,*999)
286  decomposition%DECOMPOSITION_FINISHED=.true.
287  !
288  ELSE
289  CALL flagerror("Decomposition is not associated.",err,error,*999)
290  ENDIF
291 
292  IF(diagnostics1) THEN
293  mesh=>decomposition%MESH
294  IF(ASSOCIATED(mesh)) THEN
295  CALL write_string_value(diagnostic_output_type,"Mesh = ",mesh%USER_NUMBER,err,error,*999)
296  CALL write_string_value(diagnostic_output_type," Number of decompositions = ", &
297  & mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS,err,error,*999)
298  DO decomposition_no=1,mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS
299  CALL write_string_value(diagnostic_output_type," Decomposition number = ",decomposition_no,err,error,*999)
300  CALL write_string_value(diagnostic_output_type," Global number = ", &
301  & mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_no)%PTR%GLOBAL_NUMBER,err,error,*999)
302  CALL write_string_value(diagnostic_output_type," User number = ", &
303  & mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_no)%PTR%USER_NUMBER,err,error,*999)
304  ENDDO !decomposition_no
305  ELSE
306  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
307  ENDIF
308  ENDIF
309 
310  exits("DECOMPOSITION_CREATE_FINISH")
311  RETURN
312 999 errorsexits("DECOMPOSITION_CREATE_FINISH",err,error)
313  RETURN 1
314  END SUBROUTINE decomposition_create_finish
315 
316  !
317  !================================================================================================================================
318  !
319 
321  SUBROUTINE decomposition_create_start(USER_NUMBER,MESH,DECOMPOSITION,ERR,ERROR,*)
322 
323  !Argument variables
324  INTEGER(INTG), INTENT(IN) :: user_number
325  TYPE(mesh_type), POINTER :: mesh
326  TYPE(decomposition_type), POINTER :: decomposition
327  INTEGER(INTG), INTENT(OUT) :: err
328  TYPE(varying_string), INTENT(OUT) :: error
329  !Local Variables
330  INTEGER(INTG) :: decomposition_no
331  TYPE(varying_string) :: local_error
332  TYPE(decomposition_type), POINTER :: new_decomposition
333  TYPE(decomposition_ptr_type), POINTER :: new_decompositions(:)
334 
335  NULLIFY(new_decomposition)
336  NULLIFY(new_decompositions)
337 
338  enters("DECOMPOSITION_CREATE_START",err,error,*999)
339 
340  NULLIFY(decomposition)
341 
342  IF(ASSOCIATED(mesh)) THEN
343  IF(mesh%MESH_FINISHED) THEN
344  IF(ASSOCIATED(mesh%TOPOLOGY)) THEN
345  IF(ASSOCIATED(mesh%DECOMPOSITIONS)) THEN
346  CALL decomposition_user_number_find(user_number,mesh,decomposition,err,error,*999)
347  IF(ASSOCIATED(decomposition)) THEN
348  local_error="Decomposition number "//trim(number_to_vstring(user_number,"*",err,error))// &
349  & " has already been created on mesh number "//trim(number_to_vstring(mesh%USER_NUMBER,"*",err,error))//"."
350  CALL flagerror(local_error,err,error,*999)
351  ELSE
352  !\todo Split this into an initialise and create start.
353  ALLOCATE(new_decomposition,stat=err)
354  IF(err/=0) CALL flagerror("Could not allocate new decomposition.",err,error,*999)
355  !Set default decomposition properties
356  new_decomposition%GLOBAL_NUMBER=mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS+1
357  new_decomposition%USER_NUMBER=user_number
358  new_decomposition%DECOMPOSITION_FINISHED=.false.
359  new_decomposition%CALCULATE_LINES=.true. !Default
360  new_decomposition%CALCULATE_FACES=.false. !Default
361  new_decomposition%DECOMPOSITIONS=>mesh%DECOMPOSITIONS
362  new_decomposition%MESH=>mesh
363  !By default, the process of decompostion was done on the first mesh components. But the decomposition is the same for all mesh components, since the decomposition is element-based.
364  new_decomposition%MESH_COMPONENT_NUMBER=1
365  !Default decomposition is all the mesh with one domain.
366  new_decomposition%DECOMPOSITION_TYPE=decomposition_all_type
367  new_decomposition%NUMBER_OF_DOMAINS=1
368  ALLOCATE(new_decomposition%ELEMENT_DOMAIN(mesh%NUMBER_OF_ELEMENTS),stat=err)
369  IF(err/=0) CALL flagerror("Could not allocate new decomposition element domain.",err,error,*999)
370  new_decomposition%ELEMENT_DOMAIN=0
371  !Nullify the domain
372  NULLIFY(new_decomposition%DOMAIN)
373  !Nullify the topology
374  NULLIFY(new_decomposition%TOPOLOGY)
375  !\todo change this to use move alloc.
376  !Add new decomposition into list of decompositions on the mesh
377  ALLOCATE(new_decompositions(mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS+1),stat=err)
378  IF(err/=0) CALL flagerror("Could not allocate new decompositions.",err,error,*999)
379  DO decomposition_no=1,mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS
380  new_decompositions(decomposition_no)%PTR=>mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_no)%PTR
381  ENDDO !decomposition_no
382  new_decompositions(mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS+1)%PTR=>new_decomposition
383  IF(ASSOCIATED(mesh%DECOMPOSITIONS%DECOMPOSITIONS)) DEALLOCATE(mesh%DECOMPOSITIONS%DECOMPOSITIONS)
384  mesh%DECOMPOSITIONS%DECOMPOSITIONS=>new_decompositions
385  mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS=mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS+1
386  decomposition=>new_decomposition
387  ENDIF
388  ELSE
389  local_error="The decompositions on mesh number "//trim(number_to_vstring(mesh%USER_NUMBER,"*",err,error))// &
390  & " are not associated."
391  CALL flagerror(local_error,err,error,*999)
392  ENDIF
393  ELSE
394  CALL flagerror("Mesh topology is not associated",err,error,*999)
395  ENDIF
396  ELSE
397  CALL flagerror("Mesh has not been finished.",err,error,*999)
398  ENDIF
399  ELSE
400  CALL flagerror("Mesh is not associated",err,error,*999)
401  ENDIF
402 
403  exits("DECOMPOSITION_CREATE_START")
404  RETURN
405 999 IF(ASSOCIATED(new_decomposition)) THEN
406  IF(ALLOCATED(new_decomposition%ELEMENT_DOMAIN)) DEALLOCATE(new_decomposition%ELEMENT_DOMAIN)
407  DEALLOCATE(new_decomposition)
408  ENDIF
409  IF(ASSOCIATED(new_decompositions)) DEALLOCATE(new_decompositions)
410  NULLIFY(decomposition)
411  errorsexits("DECOMPOSITION_CREATE_START",err,error)
412  RETURN 1
413  END SUBROUTINE decomposition_create_start
414 
415  !
416  !================================================================================================================================
417  !
418 
420  SUBROUTINE decomposition_destroy_number(USER_NUMBER,MESH,ERR,ERROR,*)
421 
422  !Argument variables
423  INTEGER(INTG), INTENT(IN) :: user_number
424  TYPE(mesh_type), POINTER :: mesh
425  INTEGER(INTG), INTENT(OUT) :: err
426  TYPE(varying_string), INTENT(OUT) :: error
427  !Local Variables
428  INTEGER(INTG) :: decomposition_idx,decomposition_position
429  LOGICAL :: found
430  TYPE(varying_string) :: local_error
431  TYPE(decomposition_type), POINTER :: decomposition
432  TYPE(decomposition_ptr_type), POINTER :: new_decompositions(:)
433 
434  NULLIFY(new_decompositions)
435 
436  enters("DECOMPOSITION_DESTROY_NUMBER",err,error,*999)
437 
438  IF(ASSOCIATED(mesh)) THEN
439  IF(ASSOCIATED(mesh%DECOMPOSITIONS)) THEN
440 
441  !Find the decomposition identified by the user number
442  found=.false.
443  decomposition_position=0
444  DO WHILE(decomposition_position<mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS.AND..NOT.found)
445  decomposition_position=decomposition_position+1
446  IF(mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_position)%PTR%USER_NUMBER==user_number) found=.true.
447  ENDDO
448 
449  IF(found) THEN
450 
451  decomposition=>mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_position)%PTR
452 
453  !Destroy all the decomposition components
454  IF(ALLOCATED(decomposition%ELEMENT_DOMAIN)) DEALLOCATE(decomposition%ELEMENT_DOMAIN)
455  CALL decomposition_topology_finalise(decomposition,err,error,*999)
456  CALL domain_finalise(decomposition,err,error,*999)
457 
458  DEALLOCATE(decomposition)
459 
460  !Remove the decomposition from the list of decompositions
461  IF(mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS>1) THEN
462  ALLOCATE(new_decompositions(mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS-1),stat=err)
463  IF(err/=0) CALL flagerror("Could not allocate new decompositions.",err,error,*999)
464  DO decomposition_idx=1,mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS
465  IF(decomposition_idx<decomposition_position) THEN
466  new_decompositions(decomposition_idx)%PTR=>mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_idx)%PTR
467  ELSE IF(decomposition_idx>decomposition_position) THEN
468  mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_idx)%PTR%GLOBAL_NUMBER= &
469  & mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_idx)%PTR%GLOBAL_NUMBER-1
470  new_decompositions(decomposition_idx-1)%PTR=>mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_idx)%PTR
471  ENDIF
472  ENDDO !decomposition_idx
473  DEALLOCATE(mesh%DECOMPOSITIONS%DECOMPOSITIONS)
474  mesh%DECOMPOSITIONS%DECOMPOSITIONS=>new_decompositions
475  mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS=mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS-1
476  ELSE
477  DEALLOCATE(mesh%DECOMPOSITIONS%DECOMPOSITIONS)
478  mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS=0
479  ENDIF
480 
481  ELSE
482  local_error="Decomposition number "//trim(number_to_vstring(user_number,"*",err,error))// &
483  & " has not been created on mesh number "//trim(number_to_vstring(mesh%USER_NUMBER,"*",err,error))//"."
484  CALL flagerror(local_error,err,error,*999)
485  ENDIF
486  ELSE
487  local_error="The decompositions on mesh number "//trim(number_to_vstring(mesh%USER_NUMBER,"*",err,error))// &
488  & " are not associated."
489  CALL flagerror(local_error,err,error,*999)
490  ENDIF
491  ELSE
492  CALL flagerror("Mesh is not associated.",err,error,*999)
493  ENDIF
494 
495  exits("DECOMPOSITION_DESTROY_NUMBER")
496  RETURN
497 999 IF(ASSOCIATED(new_decompositions)) DEALLOCATE(new_decompositions)
498  errorsexits("DECOMPOSITION_DESTROY_NUMBER",err,error)
499  RETURN 1
500  END SUBROUTINE decomposition_destroy_number
501 
502  !
503  !================================================================================================================================
504  !
505 
507  SUBROUTINE decomposition_destroy(DECOMPOSITION,ERR,ERROR,*)
508 
509  !Argument variables
510  TYPE(decomposition_type), POINTER :: decomposition
511  INTEGER(INTG), INTENT(OUT) :: err
512  TYPE(varying_string), INTENT(OUT) :: error
513  !Local Variables
514  INTEGER(INTG) :: decomposition_idx,decomposition_position
515  TYPE(decompositions_type), POINTER :: decompositions
516  TYPE(decomposition_ptr_type), POINTER :: new_decompositions(:)
517 
518  NULLIFY(new_decompositions)
519 
520  enters("DECOMPOSITION_DESTROY",err,error,*999)
521 
522  IF(ASSOCIATED(decomposition)) THEN
523  decompositions=>decomposition%DECOMPOSITIONS
524  IF(ASSOCIATED(decompositions)) THEN
525  decomposition_position=decomposition%GLOBAL_NUMBER
526 
527  !Destroy all the decomposition components
528  IF(ALLOCATED(decomposition%ELEMENT_DOMAIN)) DEALLOCATE(decomposition%ELEMENT_DOMAIN)
529  CALL decomposition_topology_finalise(decomposition,err,error,*999)
530  CALL domain_finalise(decomposition,err,error,*999)
531 
532  DEALLOCATE(decomposition)
533 
534  !Remove the decomposition from the list of decompositions
535  IF(decompositions%NUMBER_OF_DECOMPOSITIONS>1) THEN
536  ALLOCATE(new_decompositions(decompositions%NUMBER_OF_DECOMPOSITIONS-1),stat=err)
537  IF(err/=0) CALL flagerror("Could not allocate new decompositions.",err,error,*999)
538  DO decomposition_idx=1,decompositions%NUMBER_OF_DECOMPOSITIONS
539  IF(decomposition_idx<decomposition_position) THEN
540  new_decompositions(decomposition_idx)%PTR=>decompositions%DECOMPOSITIONS(decomposition_idx)%PTR
541  ELSE IF(decomposition_idx>decomposition_position) THEN
542  decompositions%DECOMPOSITIONS(decomposition_idx)%PTR%GLOBAL_NUMBER= &
543  & decompositions%DECOMPOSITIONS(decomposition_idx)%PTR%GLOBAL_NUMBER-1
544  new_decompositions(decomposition_idx-1)%PTR=>decompositions%DECOMPOSITIONS(decomposition_idx)%PTR
545  ENDIF
546  ENDDO !decomposition_idx
547  DEALLOCATE(decompositions%DECOMPOSITIONS)
548  decompositions%DECOMPOSITIONS=>new_decompositions
549  decompositions%NUMBER_OF_DECOMPOSITIONS=decompositions%NUMBER_OF_DECOMPOSITIONS-1
550  ELSE
551  DEALLOCATE(decompositions%DECOMPOSITIONS)
552  decompositions%NUMBER_OF_DECOMPOSITIONS=0
553  ENDIF
554  ELSE
555  CALL flagerror("Decomposition decompositions is not associated.",err,error,*999)
556  ENDIF
557  ELSE
558  CALL flagerror("Decompositions is not associated.",err,error,*999)
559  ENDIF
560 
561  exits("DECOMPOSITION_DESTROY")
562  RETURN
563 999 IF(ASSOCIATED(new_decompositions)) DEALLOCATE(new_decompositions)
564  errorsexits("DECOMPOSITION_DESTROY",err,error)
565  RETURN 1
566  END SUBROUTINE decomposition_destroy
567 
568  !
569  !================================================================================================================================
570  !
571 
573  SUBROUTINE decomposition_element_domain_calculate(DECOMPOSITION,ERR,ERROR,*)
574 
575  !Argument variables
576  TYPE(decomposition_type), POINTER :: decomposition
577  INTEGER(INTG), INTENT(OUT) :: err
578  TYPE(varying_string), INTENT(OUT) :: error
579  !Local Variables
580  INTEGER(INTG) :: number_elem_indicies,elem_index,elem_count,ne,nn,my_computational_node_number,number_computational_nodes, &
581  & no_computational_node,ELEMENT_START,ELEMENT_STOP,MY_ELEMENT_START,MY_ELEMENT_STOP,NUMBER_OF_ELEMENTS, &
582  & MY_NUMBER_OF_ELEMENTS,MPI_IERROR,MAX_NUMBER_ELEMENTS_PER_NODE,component_idx,minNumberXi
583  INTEGER(INTG), ALLOCATABLE :: element_count(:),element_ptr(:),element_indicies(:),element_distance(:),displacements(:), &
584  & RECEIVE_COUNTS(:)
585  INTEGER(INTG) :: element_weight(1),weight_flag,number_flag,number_of_constraints, &
586  & NUMBER_OF_COMMON_NODES,PARMETIS_OPTIONS(0:2)
587  !ParMETIS now has double for these
588  !REAL(SP) :: UBVEC(1)
589  !REAL(SP), ALLOCATABLE :: TPWGTS(:)
590  REAL(DP) :: ubvec(1)
591  REAL(DP), ALLOCATABLE :: tpwgts(:)
592  REAL(DP) :: number_elements_per_node
593  TYPE(basis_type), POINTER :: basis
594  TYPE(mesh_type), POINTER :: mesh
595  TYPE(varying_string) :: local_error
596 
597  enters("DECOMPOSITION_ELEMENT_DOMAIN_CALCULATE",err,error,*999)
598 
599  IF(ASSOCIATED(decomposition)) THEN
600  IF(ASSOCIATED(decomposition%MESH)) THEN
601  mesh=>decomposition%MESH
602  IF(ASSOCIATED(mesh%TOPOLOGY)) THEN
603 
604  component_idx=decomposition%MESH_COMPONENT_NUMBER
605 
606  number_computational_nodes=computational_nodes_number_get(err,error)
607  IF(err/=0) GOTO 999
608  my_computational_node_number=computational_node_number_get(err,error)
609  IF(err/=0) GOTO 999
610 
611  SELECT CASE(decomposition%DECOMPOSITION_TYPE)
612  CASE(decomposition_all_type)
613  !Do nothing. Decomposition checked below.
614  CASE(decomposition_calculated_type)
615  !Calculate the general decomposition
616 
617  IF(decomposition%NUMBER_OF_DOMAINS==1) THEN
618  decomposition%ELEMENT_DOMAIN=0
619  ELSE
620  number_computational_nodes=computational_nodes_number_get(err,error)
621  IF(err/=0) GOTO 999
622 
623  number_elements_per_node=REAL(mesh%number_of_elements,dp)/REAL(number_computational_nodes,dp)
624  element_start=1
625  element_stop=0
626  max_number_elements_per_node=-1
627  ALLOCATE(receive_counts(0:number_computational_nodes-1),stat=err)
628  IF(err/=0) CALL flagerror("Could not allocate recieve counts.",err,error,*999)
629  ALLOCATE(displacements(0:number_computational_nodes-1),stat=err)
630  IF(err/=0) CALL flagerror("Could not allocate displacements.",err,error,*999)
631  ALLOCATE(element_distance(0:number_computational_nodes),stat=err)
632  IF(err/=0) CALL flagerror("Could not allocate element distance.",err,error,*999)
633  element_distance(0)=0
634  DO no_computational_node=0,number_computational_nodes-1
635  element_start=element_stop+1
636  IF(no_computational_node==number_computational_nodes-1) THEN
637  element_stop=mesh%NUMBER_OF_ELEMENTS
638  ELSE
639  element_stop=element_start+nint(number_elements_per_node,intg)-1
640  ENDIF
641  IF((number_computational_nodes-1-no_computational_node)>(mesh%NUMBER_OF_ELEMENTS-element_stop)) &
642  & element_stop=mesh%NUMBER_OF_ELEMENTS-(number_computational_nodes-1-no_computational_node)
643  IF(element_start>mesh%NUMBER_OF_ELEMENTS) element_start=mesh%NUMBER_OF_ELEMENTS
644  IF(element_stop>mesh%NUMBER_OF_ELEMENTS) element_stop=mesh%NUMBER_OF_ELEMENTS
645  displacements(no_computational_node)=element_start-1
646  element_distance(no_computational_node+1)=element_stop !C numbering
647  number_of_elements=element_stop-element_start+1
648  receive_counts(no_computational_node)=number_of_elements
649  IF(number_of_elements>max_number_elements_per_node) max_number_elements_per_node=number_of_elements
650  IF(no_computational_node==my_computational_node_number) THEN
651  my_element_start=element_start
652  my_element_stop=element_stop
653  my_number_of_elements=element_stop-element_start+1
654  number_elem_indicies=0
655  DO ne=my_element_start,my_element_stop
656  basis=>mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%ELEMENTS(ne)%BASIS
657  number_elem_indicies=number_elem_indicies+basis%NUMBER_OF_NODES
658  ENDDO !ne
659  ENDIF
660  ENDDO !no_computational_node
661 
662  ALLOCATE(element_ptr(0:my_number_of_elements),stat=err)
663  IF(err/=0) CALL flagerror("Could not allocate element pointer list.",err,error,*999)
664  ALLOCATE(element_indicies(0:number_elem_indicies-1),stat=err)
665  IF(err/=0) CALL flagerror("Could not allocate element indicies list.",err,error,*999)
666  ALLOCATE(tpwgts(1:decomposition%NUMBER_OF_DOMAINS),stat=err)
667  IF(err/=0) CALL flagerror("Could not allocate tpwgts.",err,error,*999)
668  elem_index=0
669  elem_count=0
670  element_ptr(0)=0
671  minnumberxi=99999
672  DO ne=my_element_start,my_element_stop
673  elem_count=elem_count+1
674  basis=>mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%ELEMENTS(ne)%BASIS
675  IF(basis%NUMBER_OF_XI<minnumberxi) minnumberxi=basis%NUMBER_OF_XI
676  DO nn=1,basis%NUMBER_OF_NODES
677  element_indicies(elem_index)=mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%ELEMENTS(ne)% &
678  & mesh_element_nodes(nn)-1 !C numbering
679  elem_index=elem_index+1
680  ENDDO !nn
681  element_ptr(elem_count)=elem_index !C numbering
682  ENDDO !ne
683 
684  !Set up ParMETIS variables
685  weight_flag=0 !No weights
686  element_weight(1)=1 !Isn't used due to weight flag
687  number_flag=0 !C Numbering as there is a bug with Fortran numbering
688  number_of_constraints=1
689  IF(minnumberxi==1) THEN
690  number_of_common_nodes=1
691  ELSE
692  number_of_common_nodes=2
693  ENDIF
694  !ParMETIS now has doule precision for these
695  !TPWGTS=1.0_SP/REAL(DECOMPOSITION%NUMBER_OF_DOMAINS,SP)
696  !UBVEC=1.05_SP
697  tpwgts=1.0_dp/REAL(decomposition%number_of_domains,dp)
698  ubvec=1.05_dp
699  parmetis_options(0)=1 !If zero, defaults are used, otherwise next two values are used
700  parmetis_options(1)=7 !Level of information to output
701  parmetis_options(2)=cmiss_random_seeds(1) !Seed for random number generator
702 
703  !Call ParMETIS to calculate the partitioning of the mesh graph.
704  CALL parmetis_partmeshkway(element_distance,element_ptr,element_indicies,element_weight,weight_flag,number_flag, &
705  & number_of_constraints,number_of_common_nodes,decomposition%NUMBER_OF_DOMAINS,tpwgts,ubvec,parmetis_options, &
706  & decomposition%NUMBER_OF_EDGES_CUT,decomposition%ELEMENT_DOMAIN(displacements(my_computational_node_number)+1:), &
707  & computational_environment%MPI_COMM,err,error,*999)
708 
709  !Transfer all the element domain information to the other computational nodes so that each rank has all the info
710  IF(number_computational_nodes>1) THEN
711  !This should work on a single processor but doesn't for mpich2 under windows. Maybe a bug? Avoid for now.
712  CALL mpi_allgatherv(mpi_in_place,max_number_elements_per_node,mpi_integer,decomposition%ELEMENT_DOMAIN, &
713  & receive_counts,displacements,mpi_integer,computational_environment%MPI_COMM,mpi_ierror)
714  CALL mpi_error_check("MPI_ALLGATHERV",mpi_ierror,err,error,*999)
715  ENDIF
716 
717  DEALLOCATE(displacements)
718  DEALLOCATE(receive_counts)
719  DEALLOCATE(element_distance)
720  DEALLOCATE(element_ptr)
721  DEALLOCATE(element_indicies)
722  DEALLOCATE(tpwgts)
723 
724  ENDIF
725 
726  CASE(decomposition_user_defined_type)
727  !Do nothing. Decomposition checked below.
728  CASE DEFAULT
729  CALL flagerror("Invalid domain decomposition type.",err,error,*999)
730  END SELECT
731 
732  !Check decomposition and check that each domain has an element in it.
733  ALLOCATE(element_count(0:number_computational_nodes-1),stat=err)
734  IF(err/=0) CALL flagerror("Could not allocate element count.",err,error,*999)
735  element_count=0
736  DO elem_index=1,mesh%NUMBER_OF_ELEMENTS
737  no_computational_node=decomposition%ELEMENT_DOMAIN(elem_index)
738  IF(no_computational_node>=0.AND.no_computational_node<number_computational_nodes) THEN
739  element_count(no_computational_node)=element_count(no_computational_node)+1
740  ELSE
741  local_error="The computational node number of "//trim(number_to_vstring(no_computational_node,"*",err,error))// &
742  & " for element number "//trim(number_to_vstring(elem_index,"*",err,error))// &
743  & " is invalid. The computational node number must be between 0 and "// &
744  & trim(number_to_vstring(number_computational_nodes-1,"*",err,error))//"."
745  CALL flagerror(local_error,err,error,*999)
746  ENDIF
747  ENDDO !elem_index
748  DO no_computational_node=0,number_computational_nodes-1
749  IF(element_count(no_computational_node)==0) THEN
750  local_error="Invalid decomposition. There are no elements in computational node "// &
751  & trim(number_to_vstring(no_computational_node,"*",err,error))//"."
752  CALL flagerror(local_error,err,error,*999)
753  ENDIF
754  ENDDO !no_computational_node
755  DEALLOCATE(element_count)
756 
757  ELSE
758  CALL flagerror("Decomposition mesh topology is not associated.",err,error,*999)
759  ENDIF
760  ELSE
761  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
762  ENDIF
763  ELSE
764  CALL flagerror("Decomposition is not associated.",err,error,*999)
765  ENDIF
766 
767  IF(diagnostics1) THEN
768  CALL write_string_value(diagnostic_output_type,"Decomposition for mesh number ",decomposition%MESH%USER_NUMBER, &
769  & err,error,*999)
770  CALL write_string_value(diagnostic_output_type," Number of domains = ", decomposition%NUMBER_OF_DOMAINS, &
771  & err,error,*999)
772  CALL write_string(diagnostic_output_type," Element domains:",err,error,*999)
773  CALL write_string_value(diagnostic_output_type," Decomposition type = ", decomposition%DECOMPOSITION_TYPE, &
774  & err,error,*999)
775  IF(decomposition%DECOMPOSITION_TYPE==decomposition_calculated_type) THEN
776  CALL write_string_value(diagnostic_output_type," Number of edges cut = ",decomposition%NUMBER_OF_EDGES_CUT, &
777  & err,error,*999)
778  ENDIF
779  CALL write_string_value(diagnostic_output_type," Number of elements = ",decomposition%MESH%NUMBER_OF_ELEMENTS, &
780  & err,error,*999)
781  DO ne=1,decomposition%MESH%NUMBER_OF_ELEMENTS
782  CALL write_string_value(diagnostic_output_type," Element = ",ne,err,error,*999)
783  CALL write_string_value(diagnostic_output_type," Domain = ",decomposition%ELEMENT_DOMAIN(ne), &
784  & err,error,*999)
785  ENDDO !ne
786  ENDIF
787 
788  exits("DECOMPOSITION_ELEMENT_DOMAIN_CALCULATE")
789  RETURN
790 999 IF(ALLOCATED(receive_counts)) DEALLOCATE(receive_counts)
791  IF(ALLOCATED(displacements)) DEALLOCATE(displacements)
792  IF(ALLOCATED(element_distance)) DEALLOCATE(element_distance)
793  IF(ALLOCATED(element_ptr)) DEALLOCATE(element_ptr)
794  IF(ALLOCATED(element_indicies)) DEALLOCATE(element_indicies)
795  IF(ALLOCATED(tpwgts)) DEALLOCATE(tpwgts)
796  errorsexits("DECOMPOSITION_ELEMENT_DOMAIN_CALCULATE",err,error)
797  RETURN 1
798  END SUBROUTINE decomposition_element_domain_calculate
799 
800  !
801  !================================================================================================================================
802  !
803 
805  SUBROUTINE decomposition_element_domain_get(DECOMPOSITION,USER_ELEMENT_NUMBER,DOMAIN_NUMBER,ERR,ERROR,*)
806 
807  !Argument variables
808  TYPE(decomposition_type), POINTER :: decomposition
809  INTEGER(INTG), INTENT(IN) :: user_element_number
810  INTEGER(INTG), INTENT(OUT) :: domain_number
811  INTEGER(INTG), INTENT(OUT) :: err
812  TYPE(varying_string), INTENT(OUT) :: error
813  !Local Variables`
814  TYPE(mesh_type), POINTER :: mesh
815  TYPE(meshcomponenttopologytype), POINTER :: mesh_topology
816  TYPE(varying_string) :: local_error
817  INTEGER(INTG) :: global_element_number
818  TYPE(tree_node_type), POINTER :: tree_node
819  TYPE(meshelementstype), POINTER :: mesh_elements
820 
821 
822  enters("DECOMPOSITION_ELEMENT_DOMAIN_GET",err,error,*999)
823 
824  global_element_number=0
825  IF(ASSOCIATED(decomposition)) THEN
826  IF(decomposition%DECOMPOSITION_FINISHED) THEN
827  mesh=>decomposition%MESH
828  IF(ASSOCIATED(mesh)) THEN
829  mesh_topology=>mesh%TOPOLOGY(decomposition%MESH_COMPONENT_NUMBER)%PTR
830  IF(ASSOCIATED(mesh_topology)) THEN
831  mesh_elements=>mesh_topology%ELEMENTS
832  IF(ASSOCIATED(mesh_elements)) THEN
833  NULLIFY(tree_node)
834  CALL tree_search(mesh_elements%ELEMENTS_TREE,user_element_number,tree_node,err,error,*999)
835  IF(ASSOCIATED(tree_node)) THEN
836  CALL tree_node_value_get(mesh_elements%ELEMENTS_TREE,tree_node,global_element_number,err,error,*999)
837  IF(global_element_number>0.AND.global_element_number<=mesh_topology%ELEMENTS%NUMBER_OF_ELEMENTS) THEN
838  domain_number=decomposition%ELEMENT_DOMAIN(global_element_number)
839  ELSE
840  local_error="Global element number found "//trim(number_to_vstring(global_element_number,"*",err,error))// &
841  & " is invalid. The limits are 1 to "// &
842  & trim(number_to_vstring(mesh_topology%ELEMENTS%NUMBER_OF_ELEMENTS,"*",err,error))//"."
843  CALL flagerror(local_error,err,error,*999)
844  ENDIF
845  ELSE
846  CALL flagerror("Decomposition mesh element corresponding to user number not found.",err,error,*999)
847  ENDIF
848  ELSE
849  CALL flagerror("Decomposition mesh elements are not associated.",err,error,*999)
850  ENDIF
851  ELSE
852  CALL flagerror("Decomposition mesh topology is not associated.",err,error,*999)
853  ENDIF
854  ELSE
855  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
856  ENDIF
857  ELSE
858  CALL flagerror("Decomposition has not been finished.",err,error,*999)
859  ENDIF
860  ELSE
861  CALL flagerror("Decomposition is not associated.",err,error,*999)
862  ENDIF
863 
864  exits("DECOMPOSITION_ELEMENT_DOMAIN_GET")
865  RETURN
866 999 errorsexits("DECOMPOSITION_ELEMENT_DOMAIN_GET",err,error)
867  RETURN 1
868  END SUBROUTINE decomposition_element_domain_get
869 
870  !
871  !================================================================================================================================
872  !
873 
875  SUBROUTINE decomposition_element_domain_set(DECOMPOSITION,GLOBAL_ELEMENT_NUMBER,DOMAIN_NUMBER,ERR,ERROR,*)
876 
877  !Argument variables
878  TYPE(decomposition_type), POINTER :: decomposition
879  INTEGER(INTG), INTENT(IN) :: global_element_number
880  INTEGER(INTG), INTENT(IN) :: domain_number
881  INTEGER(INTG), INTENT(OUT) :: err
882  TYPE(varying_string), INTENT(OUT) :: error
883  !Local Variables
884  INTEGER(INTG) :: number_computational_nodes
885  TYPE(mesh_type), POINTER :: mesh
886  TYPE(meshcomponenttopologytype), POINTER :: mesh_topology
887  TYPE(varying_string) :: local_error
888 
889  enters("DECOMPOSITION_ELEMENT_DOMAIN_SET",err,error,*999)
890 
891 !!TODO: interface should specify user element number ???
892 
893  IF(ASSOCIATED(decomposition)) THEN
894  IF(decomposition%DECOMPOSITION_FINISHED) THEN
895  CALL flagerror("Decomposition has been finished.",err,error,*999)
896  ELSE
897  mesh=>decomposition%MESH
898  IF(ASSOCIATED(mesh)) THEN
899  mesh_topology=>mesh%TOPOLOGY(decomposition%MESH_COMPONENT_NUMBER)%PTR
900  IF(ASSOCIATED(mesh_topology)) THEN
901  IF(global_element_number>0.AND.global_element_number<=mesh_topology%ELEMENTS%NUMBER_OF_ELEMENTS) THEN
902  number_computational_nodes=computational_nodes_number_get(err,error)
903  IF(err/=0) GOTO 999
904  IF(domain_number>=0.AND.domain_number<number_computational_nodes) THEN
905  decomposition%ELEMENT_DOMAIN(global_element_number)=domain_number
906  ELSE
907  local_error="Domain number "//trim(number_to_vstring(domain_number,"*",err,error))// &
908  & " is invalid. The limits are 0 to "//trim(number_to_vstring(number_computational_nodes,"*",err,error))//"."
909  CALL flagerror(local_error,err,error,*999)
910  ENDIF
911  ELSE
912  local_error="Global element number "//trim(number_to_vstring(global_element_number,"*",err,error))// &
913  & " is invalid. The limits are 1 to "// &
914  & trim(number_to_vstring(mesh_topology%ELEMENTS%NUMBER_OF_ELEMENTS,"*",err,error))//"."
915  CALL flagerror(local_error,err,error,*999)
916  ENDIF
917  ELSE
918  CALL flagerror("Decomposition mesh topology is not associated.",err,error,*999)
919  ENDIF
920  ELSE
921  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
922  ENDIF
923  ENDIF
924  ELSE
925  CALL flagerror("Decomposition is not associated.",err,error,*999)
926  ENDIF
927 
928  exits("DECOMPOSITION_ELEMENT_DOMAIN_SET")
929  RETURN
930 999 errorsexits("DECOMPOSITION_ELEMENT_DOMAIN_SET",err,error)
931  RETURN 1
932  END SUBROUTINE decomposition_element_domain_set
933 
934  !
935  !================================================================================================================================
936  !
937 
938  !!MERGE: ditto
939 
941  SUBROUTINE decomposition_mesh_component_number_get(DECOMPOSITION,MESH_COMPONENT_NUMBER,ERR,ERROR,*)
942 
943  !Argument variables
944  TYPE(decomposition_type), POINTER :: decomposition
945  INTEGER(INTG), INTENT(OUT) :: mesh_component_number
946  INTEGER(INTG), INTENT(OUT) :: err
947  TYPE(varying_string), INTENT(OUT) :: error
948  !Local Variables
949 
950  enters("DECOMPOSITION_MESH_COMPONENT_NUMBER_GET",err,error,*999)
951 
952  IF(ASSOCIATED(decomposition)) THEN
953  IF(decomposition%DECOMPOSITION_FINISHED) THEN
954  IF(ASSOCIATED(decomposition%MESH)) THEN
955  mesh_component_number=decomposition%MESH_COMPONENT_NUMBER
956  ELSE
957  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
958  ENDIF
959  ELSE
960  CALL flagerror("Decomposition has been finished.",err,error,*999)
961  ENDIF
962  ELSE
963  CALL flagerror("Decomposition is not associated.",err,error,*999)
964  ENDIF
965 
966  exits("DECOMPOSITION_MESH_COMPONENT_NUMBER_GET")
967  RETURN
968 999 errorsexits("DECOMPOSITION_MESH_COMPONENT_NUMBER_GET",err,error)
969  RETURN 1
970  END SUBROUTINE decomposition_mesh_component_number_get
971 
972 
973  !
974  !================================================================================================================================
975  !
976 
978  SUBROUTINE decomposition_mesh_component_number_set(DECOMPOSITION,MESH_COMPONENT_NUMBER,ERR,ERROR,*)
979 
980  !Argument variables
981  TYPE(decomposition_type), POINTER :: decomposition
982  INTEGER(INTG), INTENT(IN) :: mesh_component_number
983  INTEGER(INTG), INTENT(OUT) :: err
984  TYPE(varying_string), INTENT(OUT) :: error
985  !Local Variables
986  TYPE(varying_string) :: local_error
987 
988  enters("DECOMPOSITION_MESH_COMPONENT_NUMBER_SET",err,error,*999)
989 
990  IF(ASSOCIATED(decomposition)) THEN
991  IF(decomposition%DECOMPOSITION_FINISHED) THEN
992  CALL flagerror("Decomposition has been finished.",err,error,*999)
993  ELSE
994  IF(ASSOCIATED(decomposition%MESH)) THEN
995  IF(mesh_component_number>0.AND.mesh_component_number<=decomposition%MESH%NUMBER_OF_COMPONENTS) THEN
996  decomposition%MESH_COMPONENT_NUMBER=mesh_component_number
997  ELSE
998  local_error="The specified mesh component number of "//trim(number_to_vstring(mesh_component_number,"*",err,error))// &
999  & "is invalid. The component number must be between 1 and "// &
1000  & trim(number_to_vstring(decomposition%MESH%NUMBER_OF_COMPONENTS,"*",err,error))//"."
1001  CALL flagerror(local_error,err,error,*999)
1002  ENDIF
1003  ELSE
1004  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
1005  ENDIF
1006  ENDIF
1007  ELSE
1008  CALL flagerror("Decomposition is not associated.",err,error,*999)
1009  ENDIF
1010 
1011  exits("DECOMPOSITION_MESH_COMPONENT_NUMBER_SET")
1012  RETURN
1013 999 errorsexits("DECOMPOSITION_MESH_COMPONENT_NUMBER_SET",err,error)
1014  RETURN 1
1015  END SUBROUTINE decomposition_mesh_component_number_set
1016 
1017  !
1018  !================================================================================================================================
1019  !
1020 
1021  !!MERGE: ditto
1022 
1024  SUBROUTINE decomposition_number_of_domains_get(DECOMPOSITION,NUMBER_OF_DOMAINS,ERR,ERROR,*)
1025 
1026  !Argument variables
1027  TYPE(decomposition_type), POINTER :: decomposition
1028  INTEGER(INTG), INTENT(OUT) :: number_of_domains
1029  INTEGER(INTG), INTENT(OUT) :: err
1030  TYPE(varying_string), INTENT(OUT) :: error
1031  !Local Variables
1032 
1033  enters("DECOMPOSITION_NUMBER_OF_DOMAINS_GET",err,error,*999)
1034 
1035  IF(ASSOCIATED(decomposition)) THEN
1036  IF(decomposition%DECOMPOSITION_FINISHED) THEN
1037  CALL flagerror("Decomposition has been finished.",err,error,*999)
1038  ELSE
1039  number_of_domains=decomposition%NUMBER_OF_DOMAINS
1040  ENDIF
1041  ELSE
1042  CALL flagerror("Decomposition is not associated.",err,error,*999)
1043  ENDIF
1044 
1045  exits("DECOMPOSITION_NUMBER_OF_DOMAINS_GET")
1046  RETURN
1047 999 errorsexits("DECOMPOSITION_NUMBER_OF_DOMAINS_GET",err,error)
1048  RETURN 1
1049  END SUBROUTINE decomposition_number_of_domains_get
1050 
1051 
1052  !
1053  !================================================================================================================================
1054  !
1055 
1057  SUBROUTINE decomposition_number_of_domains_set(DECOMPOSITION,NUMBER_OF_DOMAINS,ERR,ERROR,*)
1058 
1059  !Argument variables
1060  TYPE(decomposition_type), POINTER :: decomposition
1061  INTEGER(INTG), INTENT(IN) :: number_of_domains
1062  INTEGER(INTG), INTENT(OUT) :: err
1063  TYPE(varying_string), INTENT(OUT) :: error
1064  !Local Variables
1065  INTEGER(INTG) :: number_computational_nodes
1066  TYPE(varying_string) :: local_error
1067 
1068  enters("DECOMPOSITION_NUMBER_OF_DOMAINS_SET",err,error,*999)
1069 
1070  IF(ASSOCIATED(decomposition)) THEN
1071  IF(decomposition%DECOMPOSITION_FINISHED) THEN
1072  CALL flagerror("Decomposition has been finished.",err,error,*999)
1073  ELSE
1074  SELECT CASE(decomposition%DECOMPOSITION_TYPE)
1075  CASE(decomposition_all_type)
1076  IF(number_of_domains==1) THEN
1077  decomposition%NUMBER_OF_DOMAINS=1
1078  ELSE
1079  CALL flagerror("Can only have one domain for all decomposition type.",err,error,*999)
1080  ENDIF
1081  CASE(decomposition_calculated_type,decomposition_user_defined_type)
1082  IF(number_of_domains>=1) THEN
1083  !wolfye???<=?
1084  IF(number_of_domains<=decomposition%MESH%NUMBER_OF_ELEMENTS) THEN
1085  !Get the number of computational nodes
1086  number_computational_nodes=computational_nodes_number_get(err,error)
1087  IF(err/=0) GOTO 999
1088  !!TODO: relax this later
1089  !IF(NUMBER_OF_DOMAINS==NUMBER_COMPUTATIONAL_NODES) THEN
1090  decomposition%NUMBER_OF_DOMAINS=number_of_domains
1091  !ELSE
1092  ! LOCAL_ERROR="The number of domains ("//TRIM(NUMBER_TO_VSTRING(NUMBER_OF_DOMAINSS,"*",ERR,ERROR))// &
1093  ! & ") is not equal to the number of computational nodes ("// &
1094  ! & TRIM(NUMBER_TO_VSTRING(NUMBER_COMPUTATIONAL_NODES,"*",ERR,ERROR))//")"
1095  ! CALL FlagError(LOCAL_ERROR,ERR,ERROR,*999)
1096  !ENDIF
1097  ELSE
1098  local_error="The number of domains ("//trim(number_to_vstring(number_of_domains,"*",err,error))// &
1099  & ") must be <= the number of global elements ("// &
1100  & trim(number_to_vstring(decomposition%MESH%NUMBER_OF_ELEMENTS,"*",err,error))//") in the mesh."
1101  CALL flagerror(local_error,err,error,*999)
1102  ENDIF
1103  ELSE
1104  CALL flagerror("Number of domains must be >= 1.",err,error,*999)
1105  ENDIF
1106  CASE DEFAULT
1107  local_error="Decomposition type "//trim(number_to_vstring(decomposition%DECOMPOSITION_TYPE,"*",err,error))// &
1108  & " is not valid."
1109  CALL flagerror(local_error,err,error,*999)
1110  END SELECT
1111  ENDIF
1112  ELSE
1113  CALL flagerror("Decomposition is not associated.",err,error,*999)
1114  ENDIF
1115 
1116  exits("DECOMPOSITION_NUMBER_OF_DOMAINS_SET")
1117  RETURN
1118 999 errorsexits("DECOMPOSITION_NUMBER_OF_DOMAINS_SET",err,error)
1119  RETURN 1
1120  END SUBROUTINE decomposition_number_of_domains_set
1121 
1122  !
1123  !================================================================================================================================
1124  !
1125 
1127  SUBROUTINE decomposition_topology_calculate(DECOMPOSITION,ERR,ERROR,*)
1128 
1129  !Argument variables
1130  TYPE(decomposition_type), POINTER :: decomposition
1131  INTEGER(INTG), INTENT(OUT) :: err
1132  TYPE(varying_string), INTENT(OUT) :: error
1133  !Local Variables
1134  INTEGER(INTG) :: meshcomponentnumber
1135 
1136  enters("DECOMPOSITION_TOPOLOGY_CALCULATE",err,error,*999)
1137 
1138  IF(ASSOCIATED(decomposition%TOPOLOGY)) THEN
1139  !Calculate the elements topology
1140  CALL decomposition_topology_elements_calculate(decomposition%TOPOLOGY,err,error,*999)
1141  !Calculate the line topology
1142  IF(decomposition%CALCULATE_LINES)THEN
1143  CALL decomposition_topology_lines_calculate(decomposition%TOPOLOGY,err,error,*999)
1144  ENDIF
1145  !Calculate the face topology
1146  IF(decomposition%CALCULATE_FACES) THEN
1147  CALL decomposition_topology_faces_calculate(decomposition%TOPOLOGY,err,error,*999)
1148  ENDIF
1149  meshcomponentnumber=decomposition%MESH_COMPONENT_NUMBER
1150  IF(ALLOCATED(decomposition%MESH%TOPOLOGY(meshcomponentnumber)%PTR%dataPoints%dataPoints)) THEN
1151  CALL decompositiontopology_datapointscalculate(decomposition%TOPOLOGY,err,error,*999)
1152  ENDIF
1153  ELSE
1154  CALL flagerror("Topology is not associated.",err,error,*999)
1155  ENDIF
1156 
1157  exits("DECOMPOSITION_TOPOLOGY_CALCULATE")
1158  RETURN
1159 999 errorsexits("DECOMPOSITION_TOPOLOGY_CALCULATE",err,error)
1160  RETURN 1
1161  END SUBROUTINE decomposition_topology_calculate
1162 
1163  !
1164  !================================================================================================================================
1165  !
1166 
1168  SUBROUTINE decompositiontopology_datapointscalculate(TOPOLOGY,ERR,ERROR,*)
1169 
1170  !Argument variables
1171  TYPE(decomposition_topology_type), POINTER :: topology
1172  INTEGER(INTG), INTENT(OUT) :: err
1173  TYPE(varying_string), INTENT(OUT) :: error
1174  !Local Variables
1175  INTEGER(INTG) :: localelement,globalelement,datapointidx,localdata,meshcomponentnumber
1176  INTEGER(INTG) :: insert_status,mpi_ierror,number_of_computational_nodes,my_computational_node_number,number_of_ghost_data, &
1177  & NUMBER_OF_LOCAL_DATA
1178  TYPE(decomposition_type), POINTER :: decomposition
1179  TYPE(decomposition_elements_type), POINTER :: decompositionelements
1180  TYPE(decompositiondatapointstype), POINTER :: decompositiondata
1181  TYPE(domain_mapping_type), POINTER :: elementsmapping
1182  TYPE(meshdatapointstype), POINTER :: meshdata
1183 
1184  enters("DecompositionTopology_DataPointsCalculate",err,error,*999)
1185 
1186  IF(ASSOCIATED(topology)) THEN
1187  decompositiondata=>topology%dataPoints
1188  IF(ASSOCIATED(decompositiondata)) THEN
1189  decomposition=>decompositiondata%DECOMPOSITION
1190  IF(ASSOCIATED(decomposition)) THEN
1191  decompositionelements=>topology%ELEMENTS
1192  IF(ASSOCIATED(decompositionelements)) THEN
1193  elementsmapping=>decomposition%DOMAIN(decomposition%MESH_COMPONENT_NUMBER)%PTR%MAPPINGS%ELEMENTS
1194  IF(ASSOCIATED(elementsmapping)) THEN
1195  meshcomponentnumber=decomposition%MESH_COMPONENT_NUMBER
1196  meshdata=>decomposition%MESH%TOPOLOGY(meshcomponentnumber)%PTR%dataPoints
1197  IF(ASSOCIATED(meshdata)) THEN
1198  number_of_computational_nodes=computational_nodes_number_get(err,error)
1199  IF(err/=0) GOTO 999
1200  my_computational_node_number=computational_node_number_get(err,error)
1201  IF(err/=0) GOTO 999
1202  ALLOCATE(decompositiondata%numberOfDomainLocal(0:number_of_computational_nodes-1),stat=err)
1203  ALLOCATE(decompositiondata%numberOfDomainGhost(0:number_of_computational_nodes-1),stat=err)
1204  ALLOCATE(decompositiondata%numberOfElementDataPoints(decompositionelements%NUMBER_OF_GLOBAL_ELEMENTS),stat=err)
1205  ALLOCATE(decompositiondata%elementDataPoint(decompositionelements%TOTAL_NUMBER_OF_ELEMENTS),stat=err)
1206  IF(err/=0) CALL flagerror("Could not allocate decomposition element data points.",err,error,*999)
1207  CALL tree_create_start(decompositiondata%dataPointsTree,err,error,*999)
1208  CALL tree_insert_type_set(decompositiondata%dataPointsTree,tree_no_duplicates_allowed,err,error,*999)
1209  CALL tree_create_finish(decompositiondata%dataPointsTree,err,error,*999)
1210  decompositiondata%numberOfGlobalDataPoints=meshdata%totalNumberOfProjectedData
1211  DO globalelement=1,decompositionelements%NUMBER_OF_GLOBAL_ELEMENTS
1212  decompositiondata%numberOfElementDataPoints(globalelement)= &
1213  & meshdata%elementDataPoint(globalelement)%numberOfProjectedData
1214  ENDDO !globalElement
1215  localdata=0;
1216  DO localelement=1,decompositionelements%TOTAL_NUMBER_OF_ELEMENTS
1217  globalelement=decompositionelements%ELEMENTS(localelement)%GLOBAL_NUMBER
1218  decompositiondata%elementDataPoint(localelement)%numberOfProjectedData= &
1219  & meshdata%elementDataPoint(globalelement)%numberOfProjectedData
1220  decompositiondata%elementDataPoint(localelement)%globalElementNumber=globalelement
1221  IF(localelement<elementsmapping%GHOST_START) THEN
1222  decompositiondata%numberOfDataPoints=decompositiondata%numberOfDataPoints+ &
1223  & decompositiondata%elementDataPoint(localelement)%numberOfProjectedData
1224  ENDIF
1225  decompositiondata%totalNumberOfDataPoints=decompositiondata%totalNumberOfDataPoints+ &
1226  & decompositiondata%elementDataPoint(localelement)%numberOfProjectedData
1227  ALLOCATE(decompositiondata%elementDataPoint(localelement)%dataIndices(decompositiondata% &
1228  & elementdatapoint(localelement)%numberOfProjectedData),stat=err)
1229  DO datapointidx=1,decompositiondata%elementDataPoint(localelement)%numberOfProjectedData
1230  decompositiondata%elementDataPoint(localelement)%dataIndices(datapointidx)%userNumber= &
1231  & meshdata%elementDataPoint(globalelement)%dataIndices(datapointidx)%userNumber
1232  decompositiondata%elementDataPoint(localelement)%dataIndices(datapointidx)%globalNumber= &
1233  & meshdata%elementDataPoint(globalelement)%dataIndices(datapointidx)%globalNumber
1234  localdata=localdata+1
1235  decompositiondata%elementDataPoint(localelement)%dataIndices(datapointidx)%localNumber=localdata
1236  CALL tree_item_insert(decompositiondata%dataPointsTree,decompositiondata% &
1237  & elementdatapoint(localelement)%dataIndices(datapointidx)%userNumber,localdata, &
1238  & insert_status,err,error,*999)
1239  ENDDO !dataPointIdx
1240  ENDDO !localElement
1241  !Calculate number of ghost data points on the current computational domain
1242  number_of_local_data=decompositiondata%numberOfDataPoints
1243  number_of_ghost_data=decompositiondata%totalNumberOfDataPoints-decompositiondata%numberOfDataPoints
1244  !Gather number of local data points on all computational nodes
1245  CALL mpi_allgather(number_of_local_data,1,mpi_integer,decompositiondata% &
1246  & numberofdomainlocal,1,mpi_integer,computational_environment%MPI_COMM,mpi_ierror)
1247  CALL mpi_error_check("MPI_ALLGATHER",mpi_ierror,err,error,*999)
1248  !Gather number of ghost data points on all computational nodes
1249  CALL mpi_allgather(number_of_ghost_data,1,mpi_integer,decompositiondata% &
1250  & numberofdomainghost,1,mpi_integer,computational_environment%MPI_COMM,mpi_ierror)
1251  CALL mpi_error_check("MPI_ALLGATHER",mpi_ierror,err,error,*999)
1252  ELSE
1253  CALL flagerror("Mesh data points topology is not associated.",err,error,*999)
1254  ENDIF
1255  ELSE
1256  CALL flagerror("Element mapping is not associated.",err,error,*999)
1257  ENDIF
1258  ELSE
1259  CALL flagerror("Decomposition elements topology is not associated.",err,error,*999)
1260  ENDIF
1261  ELSE
1262  CALL flagerror("Decomposition is not associated.",err,error,*999)
1263  ENDIF
1264  ELSE
1265  CALL flagerror("Decomposition data points topology is not associated.",err,error,*999)
1266  ENDIF
1267  ELSE
1268  CALL flagerror("Topology is not associated.",err,error,*999)
1269  ENDIF
1270 
1271  exits("DecompositionTopology_DataPointsCalculate")
1272  RETURN
1273 999 errorsexits("DecompositionTopology_DataPointsCalculate",err,error)
1274  RETURN 1
1275  END SUBROUTINE decompositiontopology_datapointscalculate
1276 
1277  !
1278  !================================================================================================================================
1279  !
1280 
1282  SUBROUTINE decompositiontopology_dataprojectioncalculate(decompositionTopology,err,error,*)
1283 
1284  !Argument variables
1285  TYPE(decomposition_topology_type), POINTER :: decompositiontopology
1286  INTEGER(INTG), INTENT(OUT) :: err
1287  TYPE(varying_string), INTENT(OUT) :: error
1288 
1289  enters("DecompositionTopology_DataProjectionCalculate",err,error,*999)
1290 
1291  IF(ASSOCIATED(decompositiontopology)) THEN
1292  CALL decompositiontopology_datapointsinitialise(decompositiontopology,err,error,*999)
1293  CALL decompositiontopology_datapointscalculate(decompositiontopology,err,error,*999)
1294  ELSE
1295  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1296  ENDIF
1297 
1298  exits("DecompositionTopology_DataProjectionCalculate")
1299  RETURN
1300 999 errors("DecompositionTopology_DataProjectionCalculate",err,error)
1301  exits("DecompositionTopology_DataProjectionCalculate")
1302  RETURN 1
1303  END SUBROUTINE decompositiontopology_dataprojectioncalculate
1304 
1305  !
1306  !================================================================================================================================
1307  !
1308 
1310  SUBROUTINE decompositiontopology_elementdatapointlocalnumberget(decompositionTopology,elementNumber,dataPointIndex, &
1311  & datapointlocalnumber,err,error,*)
1312 
1313  !Argument variables
1314  TYPE(decomposition_topology_type), POINTER :: decompositiontopology
1315  INTEGER(INTG), INTENT(IN) :: elementnumber
1316  INTEGER(INTG), INTENT(IN) :: datapointindex
1317  INTEGER(INTG), INTENT(OUT) :: datapointlocalnumber
1318  INTEGER(INTG), INTENT(OUT) :: err
1319  TYPE(varying_string), INTENT(OUT) :: error
1320  !Local variables
1321  TYPE(decompositiondatapointstype), POINTER :: decompositiondata
1322  INTEGER(INTG) :: numberofdatapoints
1323  TYPE(varying_string) :: localerror
1324 
1325  enters("DecompositionTopology_ElementDataPointLocalNumberGet",err,error,*999)
1326 
1327  IF(ASSOCIATED(decompositiontopology)) THEN
1328  decompositiondata=>decompositiontopology%dataPoints
1329  IF(ASSOCIATED(decompositiondata)) THEN
1330  numberofdatapoints = decompositiondata%elementDataPoint(elementnumber)%numberOfProjectedData
1331  IF(datapointindex > 0 .AND. datapointindex <= numberofdatapoints) THEN
1332  datapointlocalnumber = decompositiondata%elementDataPoint(elementnumber)%dataIndices(datapointindex)%localNumber
1333  ELSE
1334  localerror="Element data point index "//trim(number_to_vstring(datapointindex,"*",err,error))// &
1335  & " out of range for element "//trim(number_to_vstring(elementnumber,"*",err,error))//"."
1336  CALL flagerror(localerror,err,error,*999)
1337  ENDIF
1338  ELSE
1339  CALL flagerror("Decomposition topology data points are not associated.",err,error,*999)
1340  ENDIF
1341  ELSE
1342  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1343  ENDIF
1344 
1345  exits("DecompositionTopology_ElementDataPointLocalNumberGet")
1346  RETURN
1347 999 errors("DecompositionTopology_ElementDataPointLocalNumberGet",err,error)
1348  exits("DecompositionTopology_ElementDataPointLocalNumberGet")
1349  RETURN 1
1350  END SUBROUTINE decompositiontopology_elementdatapointlocalnumberget
1351 
1352  !
1353  !================================================================================================================================
1354  !
1355 
1357  SUBROUTINE decompositiontopology_elementdatapointusernumberget(decompositionTopology,userElementNumber,dataPointIndex, &
1358  & datapointusernumber,err,error,*)
1359 
1360  !Argument variables
1361  TYPE(decomposition_topology_type), POINTER :: decompositiontopology
1362  INTEGER(INTG), INTENT(IN) :: userelementnumber
1363  INTEGER(INTG), INTENT(IN) :: datapointindex
1364  INTEGER(INTG), INTENT(OUT) :: datapointusernumber
1365  INTEGER(INTG), INTENT(OUT) :: err
1366  TYPE(varying_string), INTENT(OUT) :: error
1367  !Local variables
1368  TYPE(decompositiondatapointstype), POINTER :: decompositiondata
1369  INTEGER(INTG) :: numberofdatapoints,decompositionlocalelementnumber
1370  LOGICAL :: ghostelement,userelementexists
1371  TYPE(varying_string) :: localerror
1372 
1373  enters("DecompositionTopology_ElementDataPointUserNumberGet",err,error,*999)
1374 
1375  IF(ASSOCIATED(decompositiontopology)) THEN
1376  decompositiondata=>decompositiontopology%dataPoints
1377  IF(ASSOCIATED(decompositiondata)) THEN
1378  CALL decomposition_topology_element_check_exists(decompositiontopology,userelementnumber, &
1379  & userelementexists,decompositionlocalelementnumber,ghostelement,err,error,*999)
1380  IF(userelementexists) THEN
1381  IF(ghostelement) THEN
1382  localerror="Cannot update by data point for user element "// &
1383  & trim(number_to_vstring(userelementnumber,"*",err,error))//" as it is a ghost element."
1384  CALL flagerror(localerror,err,error,*999)
1385  ELSE
1386  numberofdatapoints = decompositiondata%elementDataPoint(decompositionlocalelementnumber)%numberOfProjectedData
1387  IF(datapointindex > 0 .AND. datapointindex <= numberofdatapoints) THEN
1388  datapointusernumber = decompositiondata%elementDataPoint(decompositionlocalelementnumber)% &
1389  & dataindices(datapointindex)%userNumber
1390  ELSE
1391  localerror="Element data point index "//trim(number_to_vstring(datapointindex,"*",err,error))// &
1392  & " out of range for element "//trim(number_to_vstring(userelementnumber,"*",err,error))//"."
1393  CALL flagerror(localerror,err,error,*999)
1394  ENDIF
1395  ENDIF
1396  ELSE
1397  localerror="The specified user element number of "// &
1398  & trim(number_to_vstring(userelementnumber,"*",err,error))// &
1399  & " does not exist."
1400  CALL flagerror(localerror,err,error,*999)
1401  ENDIF
1402  ELSE
1403  CALL flagerror("Decomposition topology data points are not associated.",err,error,*999)
1404  ENDIF
1405  ELSE
1406  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1407  ENDIF
1408 
1409  exits("DecompositionTopology_ElementDataPointUserNumberGet")
1410  RETURN
1411 999 errors("DecompositionTopology_ElementDataPointUserNumberGet",err,error)
1412  exits("DecompositionTopology_ElementDataPointUserNumberGet")
1413  RETURN 1
1414 
1415  END SUBROUTINE decompositiontopology_elementdatapointusernumberget
1416 
1417  !
1418  !================================================================================================================================
1419  !
1420 
1422  SUBROUTINE decompositiontopology_numberofelementdatapointsget(decompositionTopology,userElementNumber, &
1423  & numberofdatapoints,err,error,*)
1424 
1425  !Argument variables
1426  TYPE(decomposition_topology_type), POINTER :: decompositiontopology
1427  INTEGER(INTG), INTENT(IN) :: userelementnumber
1428  INTEGER(INTG), INTENT(OUT) :: numberofdatapoints
1429  INTEGER(INTG), INTENT(OUT) :: err
1430  TYPE(varying_string), INTENT(OUT) :: error
1431  !Local variables
1432  TYPE(decompositiondatapointstype), POINTER :: decompositiondata
1433  INTEGER(INTG) :: decompositionlocalelementnumber
1434  LOGICAL :: ghostelement,userelementexists
1435  TYPE(varying_string) :: localerror
1436 
1437  enters("DecompositionTopology_NumberOfElementDataPointsGet",err,error,*999)
1438 
1439  IF(ASSOCIATED(decompositiontopology)) THEN
1440  decompositiondata=>decompositiontopology%dataPoints
1441  IF(ASSOCIATED(decompositiondata)) THEN
1442  CALL decomposition_topology_element_check_exists(decompositiontopology,userelementnumber, &
1443  & userelementexists,decompositionlocalelementnumber,ghostelement,err,error,*999)
1444  IF(userelementexists) THEN
1445  IF(ghostelement) THEN
1446  localerror="Cannot update by data point for user element "// &
1447  & trim(number_to_vstring(userelementnumber,"*",err,error))//" as it is a ghost element."
1448  CALL flagerror(localerror,err,error,*999)
1449  ELSE
1450  numberofdatapoints = decompositiondata%elementDataPoint(decompositionlocalelementnumber)%numberOfProjectedData
1451  ENDIF
1452  ELSE
1453  localerror="The specified user element number of "// &
1454  & trim(number_to_vstring(userelementnumber,"*",err,error))// &
1455  & " does not exist."
1456  CALL flagerror(localerror,err,error,*999)
1457  ENDIF
1458  ELSE
1459  CALL flagerror("Decomposition topology data points are not associated.",err,error,*999)
1460  ENDIF
1461  ELSE
1462  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1463  ENDIF
1464 
1465  exits("DecompositionTopology_NumberOfElementDataPointsGet")
1466  RETURN
1467 999 errors("DecompositionTopology_NumberOfElementDataPointsGet",err,error)
1468  exits("DecompositionTopology_NumberOfElementDataPointsGet")
1469  RETURN 1
1470  END SUBROUTINE decompositiontopology_numberofelementdatapointsget
1471 
1472  !
1473  !================================================================================================================================
1474  !
1475 
1477  SUBROUTINE decompositiontopology_datapointcheckexists(decompositionTopology,userDataPointNumber,userDataPointExists, &
1478  & decompositionlocaldatapointnumber,ghostdatapoint,err,error,*)
1479 
1480  !Argument variables
1481  TYPE(decomposition_topology_type), POINTER :: decompositiontopology
1482  INTEGER(INTG), INTENT(IN) :: userdatapointnumber
1483  LOGICAL, INTENT(OUT) :: userdatapointexists
1484  INTEGER(INTG), INTENT(OUT) :: decompositionlocaldatapointnumber
1485  LOGICAL, INTENT(OUT) :: ghostdatapoint
1486  INTEGER(INTG), INTENT(OUT) :: err
1487  TYPE(varying_string), INTENT(OUT) :: error
1488  !Local Variables
1489  TYPE(decompositiondatapointstype), POINTER :: decompositiondata
1490  TYPE(tree_node_type), POINTER :: treenode
1491 
1492  enters("DecompositionTopology_DataPointCheckExists",err,error,*999)
1493 
1494  userdatapointexists=.false.
1495  decompositionlocaldatapointnumber=0
1496  ghostdatapoint=.false.
1497  IF(ASSOCIATED(decompositiontopology)) THEN
1498  decompositiondata=>decompositiontopology%dataPoints
1499  IF(ASSOCIATED(decompositiondata)) THEN
1500  NULLIFY(treenode)
1501  CALL tree_search(decompositiondata%dataPointsTree,userdatapointnumber,treenode,err,error,*999)
1502  IF(ASSOCIATED(treenode)) THEN
1503  CALL tree_node_value_get(decompositiondata%dataPointsTree,treenode,decompositionlocaldatapointnumber,err,error,*999)
1504  userdatapointexists=.true.
1505  ghostdatapoint=decompositionlocaldatapointnumber>decompositiondata%numberOfDataPoints
1506  ENDIF
1507  ELSE
1508  CALL flagerror("Decomposition data point topology is not associated.",err,error,*999)
1509  ENDIF
1510  ELSE
1511  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1512  ENDIF
1513 
1514  exits("DecompositionTopology_DataPointCheckExists")
1515  RETURN
1516 999 errors("DecompositionTopology_DataPointCheckExists",err,error)
1517  exits("DecompositionTopology_DataPointCheckExists")
1518  RETURN 1
1519 
1520  END SUBROUTINE decompositiontopology_datapointcheckexists
1521 
1522  !
1523  !================================================================================================================================
1524  !
1525 
1527  SUBROUTINE decomposition_topology_element_check_exists(DECOMPOSITION_TOPOLOGY,USER_ELEMENT_NUMBER,ELEMENT_EXISTS, &
1528  & decomposition_local_element_number,ghost_element,err,error,*)
1529 
1530  !Argument variables
1531  TYPE(decomposition_topology_type), POINTER :: decomposition_topology
1532  INTEGER(INTG), INTENT(IN) :: user_element_number
1533  LOGICAL, INTENT(OUT) :: element_exists
1534  INTEGER(INTG), INTENT(OUT) :: decomposition_local_element_number
1535  LOGICAL, INTENT(OUT) :: ghost_element
1536  INTEGER(INTG), INTENT(OUT) :: err
1537  TYPE(varying_string), INTENT(OUT) :: error
1538  !Local Variables
1539  TYPE(decomposition_elements_type), POINTER :: decomposition_elements
1540  TYPE(tree_node_type), POINTER :: tree_node
1541 
1542  enters("DECOMPOSITION_TOPOLOGY_ELEMENT_CHECK_EXISTS",err,error,*999)
1543 
1544  element_exists=.false.
1545  decomposition_local_element_number=0
1546  ghost_element=.false.
1547  IF(ASSOCIATED(decomposition_topology)) THEN
1548  decomposition_elements=>decomposition_topology%ELEMENTS
1549  IF(ASSOCIATED(decomposition_elements)) THEN
1550  NULLIFY(tree_node)
1551  CALL tree_search(decomposition_elements%ELEMENTS_TREE,user_element_number,tree_node,err,error,*999)
1552  IF(ASSOCIATED(tree_node)) THEN
1553  CALL tree_node_value_get(decomposition_elements%ELEMENTS_TREE,tree_node,decomposition_local_element_number,err,error,*999)
1554  element_exists=.true.
1555  ghost_element=decomposition_local_element_number>decomposition_elements%NUMBER_OF_ELEMENTS
1556  ENDIF
1557  ELSE
1558  CALL flagerror("Decomposition topology elements is not associated.",err,error,*999)
1559  ENDIF
1560  ELSE
1561  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1562  ENDIF
1563 
1564  exits("DECOMPOSITION_TOPOLOGY_ELEMENT_CHECK_EXISTS")
1565  RETURN
1566 999 errorsexits("DECOMPOSITION_TOPOLOGY_ELEMENT_CHECK_EXISTS",err,error)
1567  RETURN 1
1568 
1569  END SUBROUTINE decomposition_topology_element_check_exists
1570 
1571  !
1572  !================================================================================================================================
1573  !
1574 
1576  SUBROUTINE domaintopology_elementbasisget(domainTopology,userElementNumber, &
1577  & basis,err,error,*)
1578 
1579  !Argument variables
1580  TYPE(domain_topology_type), POINTER :: domaintopology
1581  INTEGER(INTG), INTENT(IN) :: userelementnumber
1582  TYPE(basis_type), POINTER, INTENT(OUT) :: basis
1583  INTEGER(INTG), INTENT(OUT) :: err
1584  TYPE(varying_string), INTENT(OUT) :: error
1585  !Local Variables
1586  TYPE(decomposition_topology_type), POINTER :: decompositiontopology
1587  TYPE(domain_elements_type), POINTER :: domainelements
1588  LOGICAL :: userelementexists,ghostelement
1589  INTEGER(INTG) :: localelementnumber
1590 
1591  enters("DomainTopology_ElementBasisGet",err,error,*999)
1592 
1593  NULLIFY(basis)
1594 
1595  IF(ASSOCIATED(domaintopology)) THEN
1596  domainelements=>domaintopology%elements
1597  IF(ASSOCIATED(domainelements)) THEN
1598  decompositiontopology=>domaintopology%domain%decomposition%topology
1599  IF(ASSOCIATED(decompositiontopology)) THEN
1600  CALL decomposition_topology_element_check_exists(decompositiontopology,userelementnumber, &
1601  & userelementexists,localelementnumber,ghostelement,err,error,*999)
1602  IF(.NOT.userelementexists) THEN
1603  CALL flagerror("The specified user element number of "// &
1604  & trim(numbertovstring(userelementnumber,"*",err,error))// &
1605  & " does not exist in the domain decomposition.",err,error,*999)
1606  END IF
1607  basis=>domainelements%elements(localelementnumber)%basis
1608  ELSE
1609  CALL flagerror("Decomposition topology is not associated.",err,error,*999)
1610  END IF
1611  ELSE
1612  CALL flagerror("Domain topology elements is not associated.",err,error,*999)
1613  END IF
1614  ELSE
1615  CALL flagerror("Domain topology is not associated.",err,error,*999)
1616  END IF
1617 
1618  exits("DomainTopology_ElementBasisGet")
1619  RETURN
1620  999 errorsexits("DomainTopology_ElementBasisGet",err,error)
1621  RETURN 1
1622 
1623  END SUBROUTINE domaintopology_elementbasisget
1624 
1625  !
1626  !================================================================================================================================
1627  !
1628 
1630  SUBROUTINE decomposition_topology_element_finalise(ELEMENT,ERR,ERROR,*)
1631 
1632  !Argument variables
1633  TYPE(decomposition_element_type) :: element
1634  INTEGER(INTG), INTENT(OUT) :: err
1635  TYPE(varying_string), INTENT(OUT) :: error
1636  !Local Variables
1637  INTEGER(INTG) :: nic !\todo add comment
1638 
1639  enters("DECOMPOSITION_TOPOLOGY_ELEMENT_FINALISE",err,error,*999)
1640 
1641  IF(ALLOCATED(element%ADJACENT_ELEMENTS)) THEN
1642  DO nic=lbound(element%ADJACENT_ELEMENTS,1),ubound(element%ADJACENT_ELEMENTS,1)
1643  CALL decomposition_adjacent_element_finalise(element%ADJACENT_ELEMENTS(nic),err,error,*999)
1644  ENDDO !nic
1645  DEALLOCATE(element%ADJACENT_ELEMENTS)
1646  ENDIF
1647  IF(ALLOCATED(element%ELEMENT_LINES)) DEALLOCATE(element%ELEMENT_LINES)
1648  IF(ALLOCATED(element%ELEMENT_FACES)) DEALLOCATE(element%ELEMENT_FACES)
1649 
1650  exits("DECOMPOSITION_TOPOLOGY_ELEMENT_FINALISE")
1651  RETURN
1652 999 errorsexits("DECOMPOSITION_TOPOLOGY_ELEMENT_FINALISE",err,error)
1653  RETURN 1
1654  END SUBROUTINE decomposition_topology_element_finalise
1655 
1656  !
1657  !================================================================================================================================
1658  !
1659 
1661  SUBROUTINE decomposition_topology_element_initialise(ELEMENT,ERR,ERROR,*)
1662 
1663  !Argument variables
1664  TYPE(decomposition_element_type) :: element
1665  INTEGER(INTG), INTENT(OUT) :: err
1666  TYPE(varying_string), INTENT(OUT) :: error
1667  !Local Variables
1668 
1669  enters("DECOMPOSITION_TOPOLOGY_ELEMENT_INITIALISE",err,error,*999)
1670 
1671  element%USER_NUMBER=0
1672  element%LOCAL_NUMBER=0
1673  element%GLOBAL_NUMBER=0
1674  element%BOUNDARY_ELEMENT=.false.
1675 
1676  exits("DECOMPOSITION_TOPOLOGY_ELEMENT_INITALISE")
1677  RETURN
1678 999 errorsexits("DECOMPOSITION_TOPOLOGY_ELEMENT_INITALISE",err,error)
1679  RETURN 1
1680  END SUBROUTINE decomposition_topology_element_initialise
1681 
1682  !
1683  !================================================================================================================================
1684  !
1685 
1687  SUBROUTINE decompositiontopology_elementadjacentelementcalculate(TOPOLOGY,ERR,ERROR,*)
1688 
1689  !Argument variables
1690  TYPE(decomposition_topology_type), POINTER :: topology
1691  INTEGER(INTG), INTENT(OUT) :: err
1692  TYPE(varying_string), INTENT(OUT) :: error
1693  !Local Variables
1694  INTEGER(INTG) :: j,ne,ne1,nep1,ni,nic,nn,nn1,nn2,nn3,np,np1,dummy_err,face_xi(2),face_xic(3),node_position_index(4)
1695  INTEGER(INTG) :: xi_direction,direction_index,xi_dir_check,xi_dir_search,number_node_matches
1696  INTEGER(INTG) :: candidate_idx,face_node_idx,node_idx,surrounding_el_idx,candidate_el,idx
1697  INTEGER(INTG) :: number_surrounding,number_of_nodes_xic(4),numbersurroundingelements
1698  INTEGER(INTG), ALLOCATABLE :: node_matches(:),adjacent_elements(:), surroundingelements(:)
1699  LOGICAL :: xi_collapsed,face_collapsed(-3:3),subset
1700  TYPE(list_type), POINTER :: node_match_list, surroundingelementslist
1701  TYPE(list_ptr_type) :: adjacent_elements_list(-4:4)
1702  TYPE(basis_type), POINTER :: basis
1703  TYPE(decomposition_type), POINTER :: decomposition
1704  TYPE(decomposition_elements_type), POINTER :: decomposition_elements
1705  TYPE(domain_type), POINTER :: domain
1706  TYPE(domain_elements_type), POINTER :: domain_elements
1707  TYPE(domain_nodes_type), POINTER :: domain_nodes
1708  TYPE(domain_topology_type), POINTER :: domain_topology
1709  TYPE(varying_string) :: dummy_error,local_error
1710 
1711  NULLIFY(node_match_list)
1712  DO nic=-4,4
1713  NULLIFY(adjacent_elements_list(nic)%PTR)
1714  ENDDO !nic
1715 
1716  enters("DecompositionTopology_ElementAdjacentElementCalculate",err,error,*999)
1717 
1718  IF(ASSOCIATED(topology)) THEN
1719  decomposition=>topology%DECOMPOSITION
1720  IF(ASSOCIATED(decomposition)) THEN
1721  decomposition_elements=>topology%ELEMENTS
1722  IF(ASSOCIATED(decomposition_elements)) THEN
1723  domain=>decomposition%DOMAIN(decomposition%MESH_COMPONENT_NUMBER)%PTR
1724  IF(ASSOCIATED(domain)) THEN
1725  domain_topology=>domain%TOPOLOGY
1726  IF(ASSOCIATED(domain_topology)) THEN
1727  domain_nodes=>domain_topology%NODES
1728  IF(ASSOCIATED(domain_nodes)) THEN
1729  domain_elements=>domain_topology%ELEMENTS
1730  IF(ASSOCIATED(domain_elements)) THEN
1731  !Loop over the elements in the decomposition
1732  DO ne=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
1733  basis=>domain_elements%ELEMENTS(ne)%BASIS
1734  !Create a list for every xi direction (plus and minus)
1735  DO nic=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
1736  NULLIFY(adjacent_elements_list(nic)%PTR)
1737  CALL list_create_start(adjacent_elements_list(nic)%PTR,err,error,*999)
1738  CALL list_data_type_set(adjacent_elements_list(nic)%PTR,list_intg_type,err,error,*999)
1739  CALL list_initial_size_set(adjacent_elements_list(nic)%PTR,5,err,error,*999)
1740  CALL list_create_finish(adjacent_elements_list(nic)%PTR,err,error,*999)
1741  ENDDO !nic
1742  number_of_nodes_xic=1
1743  number_of_nodes_xic(1:basis%NUMBER_OF_XI_COORDINATES)= &
1744  & basis%NUMBER_OF_NODES_XIC(1:basis%NUMBER_OF_XI_COORDINATES)
1745  !Place the current element in the surrounding list
1746  CALL list_item_add(adjacent_elements_list(0)%PTR,decomposition_elements%ELEMENTS(ne)%LOCAL_NUMBER, &
1747  & err,error,*999)
1748  SELECT CASE(basis%TYPE)
1749  CASE(basis_lagrange_hermite_tp_type)
1750 !!TODO: Calculate this and set it as part of the basis type
1751  !Determine the collapsed "faces" if any
1752  node_position_index=1
1753  !Loop over the face normals of the element
1754  DO ni=1,basis%NUMBER_OF_XI
1755  !Determine the face xi directions that lie in this xi direction
1756  face_xi(1)=other_xi_directions3(ni,2,1)
1757  face_xi(2)=other_xi_directions3(ni,3,1)
1758  !Reset the node_position_index in this xi direction
1759  node_position_index(ni)=1
1760  !Loop over the two faces with this normal
1761  DO direction_index=-1,1,2
1762  xi_direction=direction_index*ni
1763  face_collapsed(xi_direction)=.false.
1764  DO j=1,2
1765  xi_dir_check=face_xi(j)
1766  IF(xi_dir_check<=basis%NUMBER_OF_XI) THEN
1767  xi_dir_search=face_xi(3-j)
1768  node_position_index(xi_dir_search)=1
1769  xi_collapsed=.true.
1770  DO WHILE(node_position_index(xi_dir_search)<=number_of_nodes_xic(xi_dir_search).AND.xi_collapsed)
1771  !Get the first local node along the xi check direction
1772  node_position_index(xi_dir_check)=1
1773  nn1=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2), &
1774  & node_position_index(3),1)
1775  !Get the second local node along the xi check direction
1776  node_position_index(xi_dir_check)=2
1777  nn2=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2), &
1778  & node_position_index(3),1)
1779  IF(nn1/=0.AND.nn2/=0) THEN
1780  IF(domain_elements%ELEMENTS(ne)%ELEMENT_NODES(nn1)/= &
1781  & domain_elements%ELEMENTS(ne)%ELEMENT_NODES(nn2)) xi_collapsed=.false.
1782  ENDIF
1783  node_position_index(xi_dir_search)=node_position_index(xi_dir_search)+1
1784  ENDDO !xi_dir_search
1785  IF(xi_collapsed) face_collapsed(xi_direction)=.true.
1786  ENDIF
1787  ENDDO !j
1788  node_position_index(ni)=number_of_nodes_xic(ni)
1789  ENDDO !direction_index
1790  ENDDO !ni
1791  !Loop over the xi directions and calculate the surrounding elements
1792  DO ni=1,basis%NUMBER_OF_XI
1793  !Determine the xi directions that lie in this xi direction
1794  face_xi(1)=other_xi_directions3(ni,2,1)
1795  face_xi(2)=other_xi_directions3(ni,3,1)
1796  !Loop over the two faces
1797  DO direction_index=-1,1,2
1798  xi_direction=direction_index*ni
1799  !Find nodes in the element on the appropriate face/line/point
1800  NULLIFY(node_match_list)
1801  CALL list_create_start(node_match_list,err,error,*999)
1802  CALL list_data_type_set(node_match_list,list_intg_type,err,error,*999)
1803  CALL list_initial_size_set(node_match_list,16,err,error,*999)
1804  CALL list_create_finish(node_match_list,err,error,*999)
1805  IF(direction_index==-1) THEN
1806  node_position_index(ni)=1
1807  ELSE
1808  node_position_index(ni)=number_of_nodes_xic(ni)
1809  ENDIF
1810  !If the face is collapsed then don't look in this xi direction. The exception is if the opposite face is
1811  !also collapsed. This may indicate that we have a funny element in non-rc coordinates that goes around the
1812  !central axis back to itself
1813  IF(face_collapsed(xi_direction).AND..NOT.face_collapsed(-xi_direction)) THEN
1814  !Do nothing - the match lists are already empty
1815  ELSE
1816  !Find the nodes to match and add them to the node match list
1817  SELECT CASE(basis%NUMBER_OF_XI)
1818  CASE(1)
1819  nn=basis%NODE_POSITION_INDEX_INV(node_position_index(1),1,1,1)
1820  IF(nn/=0) THEN
1821  np=domain_elements%ELEMENTS(ne)%ELEMENT_NODES(nn)
1822  CALL list_item_add(node_match_list,np,err,error,*999)
1823  ENDIF
1824  CASE(2)
1825  DO nn1=1,number_of_nodes_xic(face_xi(1)),number_of_nodes_xic(face_xi(1))-1
1826  node_position_index(face_xi(1))=nn1
1827  nn=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2),1,1)
1828  IF(nn/=0) THEN
1829  np=domain_elements%ELEMENTS(ne)%ELEMENT_NODES(nn)
1830  CALL list_item_add(node_match_list,np,err,error,*999)
1831  ENDIF
1832  ENDDO !nn1
1833  CASE(3)
1834  DO nn1=1,number_of_nodes_xic(face_xi(1)),number_of_nodes_xic(face_xi(1))-1
1835  node_position_index(face_xi(1))=nn1
1836  DO nn2=1,number_of_nodes_xic(face_xi(2)),number_of_nodes_xic(face_xi(2))-1
1837  node_position_index(face_xi(2))=nn2
1838  nn=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2), &
1839  & node_position_index(3),1)
1840  IF(nn/=0) THEN
1841  np=domain_elements%ELEMENTS(ne)%ELEMENT_NODES(nn)
1842  CALL list_item_add(node_match_list,np,err,error,*999)
1843  ENDIF
1844  ENDDO !nn2
1845  ENDDO !nn1
1846  CASE DEFAULT
1847  local_error="The number of xi directions in the basis of "// &
1848  & trim(number_to_vstring(basis%NUMBER_OF_XI,"*",err,error))//" is invalid."
1849  CALL flagerror(local_error,err,error,*999)
1850  END SELECT
1851  ENDIF
1852  CALL list_remove_duplicates(node_match_list,err,error,*999)
1853  CALL list_detach_and_destroy(node_match_list,number_node_matches,node_matches,err,error,*999)
1854  number_surrounding=0
1855  IF(number_node_matches>0) THEN
1856  !NODE_MATCHES now contain the list of corner nodes in the current face with normal_xi of ni.
1857  !Look at the surrounding elements of each of these nodes, if there is a repeated element that
1858  !is not the current element ne, it's an adjacent element.
1859  candidate_idx=0
1860  NULLIFY(surroundingelementslist)
1861  CALL list_create_start(surroundingelementslist,err,error,*999)
1862  CALL list_data_type_set(surroundingelementslist,list_intg_type,err,error,*999)
1863  CALL list_initial_size_set(surroundingelementslist,2,err,error,*999)
1864  CALL list_create_finish(surroundingelementslist,err,error,*999)
1865  DO face_node_idx=1,number_node_matches
1866  !Dump all the surrounding elements into an array, see if any are repeated
1867  node_idx=node_matches(face_node_idx)
1868  DO surrounding_el_idx=1,domain_nodes%NODES(node_idx)%NUMBER_OF_SURROUNDING_ELEMENTS
1869  candidate_el=domain_nodes%NODES(node_idx)%SURROUNDING_ELEMENTS(surrounding_el_idx)
1870  IF(candidate_el/=ne) THEN
1871  candidate_idx=candidate_idx+1
1872  CALL list_item_add(surroundingelementslist,candidate_el,err,error,*999)
1873  ENDIF
1874  ENDDO
1875  ENDDO !face_node_idx
1876  CALL list_detach_and_destroy(surroundingelementslist,numbersurroundingelements,surroundingelements, &
1877  & err,error,*999)
1878  DO idx=1,candidate_idx
1879  ne1=surroundingelements(idx)
1880  IF(count(surroundingelements(1:numbersurroundingelements)==ne1)>=basis%NUMBER_OF_XI) THEN
1881  !Found it, just exit
1882  CALL list_item_add(adjacent_elements_list(xi_direction)%PTR,ne1,err,error,*999)
1883  number_surrounding=number_surrounding+1
1884  EXIT
1885  ENDIF
1886  ENDDO
1887  ENDIF
1888  IF(ALLOCATED(node_matches)) DEALLOCATE(node_matches)
1889  IF(ALLOCATED(surroundingelements)) DEALLOCATE(surroundingelements)
1890  ENDDO !direction_index
1891  ENDDO !ni
1892  CASE(basis_simplex_type)
1893  !Loop over the xi coordinates and calculate the surrounding elements
1894  DO nic=1,basis%NUMBER_OF_XI_COORDINATES
1895  !Find the other coordinates of the face/line/point
1896  face_xic(1)=other_xi_directions4(nic,1)
1897  face_xic(2)=other_xi_directions4(nic,2)
1898  face_xic(3)=other_xi_directions4(nic,3)
1899  !Find nodes in the element on the appropriate face/line/point
1900  NULLIFY(node_match_list)
1901  CALL list_create_start(node_match_list,err,error,*999)
1902  CALL list_data_type_set(node_match_list,list_intg_type,err,error,*999)
1903  CALL list_initial_size_set(node_match_list,16,err,error,*999)
1904  CALL list_create_finish(node_match_list,err,error,*999)
1905  node_position_index(nic)=1 !Furtherest away from node with the nic'th coordinate
1906  !Find the nodes to match and add them to the node match list
1907  DO nn1=1,number_of_nodes_xic(face_xic(1))
1908  node_position_index(face_xic(1))=nn1
1909  DO nn2=1,number_of_nodes_xic(face_xic(2))
1910  node_position_index(face_xic(2))=nn2
1911  DO nn3=1,number_of_nodes_xic(face_xic(3))
1912  node_position_index(face_xic(3))=nn3
1913  nn=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2), &
1914  & node_position_index(3),node_position_index(4))
1915  IF(nn/=0) THEN
1916  np=domain_elements%ELEMENTS(ne)%ELEMENT_NODES(nn)
1917  CALL list_item_add(node_match_list,np,err,error,*999)
1918  ENDIF
1919  ENDDO !nn3
1920  ENDDO !nn2
1921  ENDDO !nn1
1922  CALL list_remove_duplicates(node_match_list,err,error,*999)
1923  CALL list_detach_and_destroy(node_match_list,number_node_matches,node_matches,err,error,*999)
1924  IF(number_node_matches>0) THEN
1925  !Find list of elements surrounding those nodes
1926  DO node_idx=1,number_node_matches
1927  np1=node_matches(node_idx)
1928  DO nep1=1,domain_nodes%NODES(np1)%NUMBER_OF_SURROUNDING_ELEMENTS
1929  ne1=domain_nodes%NODES(np1)%SURROUNDING_ELEMENTS(nep1)
1930  IF(ne1/=ne) THEN !Don't want the current element
1931  ! grab the nodes list for current and this surrouding elements
1932  ! current face : NODE_MATCHES
1933  ! candidate elem : TOPOLOGY%ELEMENTS%ELEMENTS(ne1)%MESH_ELEMENT_NODES
1934  ! if all of current face belongs to the candidate element, we will have found the neighbour
1935  CALL list_subset_of(node_matches(1:number_node_matches),domain_elements%ELEMENTS(ne1)% &
1936  & element_nodes,subset,err,error,*999)
1937  IF(subset) THEN
1938  CALL list_item_add(adjacent_elements_list(nic)%PTR,ne1,err,error,*999)
1939  ENDIF
1940  ENDIF
1941  ENDDO !nep1
1942  ENDDO !node_idx
1943  ENDIF
1944  IF(ALLOCATED(node_matches)) DEALLOCATE(node_matches)
1945  ENDDO !nic
1946  CASE(basis_serendipity_type)
1947  CALL flagerror("Not implemented.",err,error,*999)
1948  CASE(basis_auxilliary_type)
1949  CALL flagerror("Not implemented.",err,error,*999)
1950  CASE(basis_b_spline_tp_type)
1951  CALL flagerror("Not implemented.",err,error,*999)
1952  CASE(basis_fourier_lagrange_hermite_tp_type)
1953  CALL flagerror("Not implemented.",err,error,*999)
1954  CASE(basis_extended_lagrange_tp_type)
1955  CALL flagerror("Not implemented.",err,error,*999)
1956  CASE DEFAULT
1957  local_error="The basis type of "//trim(number_to_vstring(basis%TYPE,"*",err,error))// &
1958  & " is invalid."
1959  CALL flagerror(local_error,err,error,*999)
1960  END SELECT
1961  !Set the surrounding elements for this element
1962  ALLOCATE(decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(-basis%NUMBER_OF_XI_COORDINATES: &
1963  basis%NUMBER_OF_XI_COORDINATES),stat=err)
1964  IF(err/=0) CALL flagerror("Could not allocate adjacent elements.",err,error,*999)
1965  DO nic=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
1966  CALL decomposition_adjacent_element_initialise(decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic), &
1967  & err,error,*999)
1968  CALL list_detach_and_destroy(adjacent_elements_list(nic)%PTR,decomposition_elements%ELEMENTS(ne)% &
1969  & adjacent_elements(nic)%NUMBER_OF_ADJACENT_ELEMENTS,adjacent_elements,err,error,*999)
1970  ALLOCATE(decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%ADJACENT_ELEMENTS( &
1971  decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS),stat=err)
1972  IF(err/=0) CALL flagerror("Could not allocate element adjacent elements.",err,error,*999)
1973  decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%ADJACENT_ELEMENTS(1: &
1974  & decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS)= &
1975  adjacent_elements(1:decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS)
1976  IF(ALLOCATED(adjacent_elements)) DEALLOCATE(adjacent_elements)
1977  ENDDO !nic
1978  ENDDO !ne
1979  ELSE
1980  CALL flagerror("Domain topology elements is not associated.",err,error,*999)
1981  ENDIF
1982  ELSE
1983  CALL flagerror("Domain topology nodes is not associated.",err,error,*999)
1984  ENDIF
1985  ELSE
1986  CALL flagerror("Topology decomposition domain topology is not associated.",err,error,*999)
1987  ENDIF
1988  ELSE
1989  CALL flagerror("Topology decomposition domain is not associated.",err,error,*999)
1990  ENDIF
1991  ELSE
1992  CALL flagerror("Topology elements is not associated.",err,error,*999)
1993  ENDIF
1994  ELSE
1995  CALL flagerror("Topology decomposition is not associated.",err,error,*999)
1996  ENDIF
1997  ELSE
1998  CALL flagerror("Topology is not allocated.",err,error,*999)
1999  ENDIF
2000 
2001  IF(diagnostics1) THEN
2002  CALL write_string_value(diagnostic_output_type,"Total number of elements = ",decomposition_elements% &
2003  & total_number_of_elements,err,error,*999)
2004  DO ne=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
2005  basis=>domain_elements%ELEMENTS(ne)%BASIS
2006  CALL write_string_value(diagnostic_output_type," Local element number : ",ne,err,error,*999)
2007  CALL write_string_value(diagnostic_output_type," Number of xi coordinates = ",basis%NUMBER_OF_XI_COORDINATES, &
2008  & err,error,*999)
2009  DO nic=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
2010  CALL write_string_value(diagnostic_output_type," Xi coordinate : ",nic,err,error,*999)
2011  CALL write_string_value(diagnostic_output_type," Number of adjacent elements = ", &
2012  & decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS,err,error,*999)
2013  IF(decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS>0) THEN
2014  CALL write_string_vector(diagnostic_output_type,1,1,decomposition_elements%ELEMENTS(ne)% &
2015  & adjacent_elements(nic)%NUMBER_OF_ADJACENT_ELEMENTS,8,8,decomposition_elements%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)% &
2016  & adjacent_elements,'(" Adjacent elements :",8(X,I6))','(30x,8(X,I6))',err,error,*999)
2017  ENDIF
2018  ENDDO !nic
2019  ENDDO !ne
2020  ENDIF
2021 
2022  exits("DecompositionTopology_ElementAdjacentElementCalculate")
2023  RETURN
2024 999 IF(ALLOCATED(node_matches)) DEALLOCATE(node_matches)
2025  IF(ALLOCATED(surroundingelements)) DEALLOCATE(surroundingelements)
2026  IF(ALLOCATED(adjacent_elements)) DEALLOCATE(adjacent_elements)
2027  IF(ASSOCIATED(node_match_list)) CALL list_destroy(node_match_list,dummy_err,dummy_error,*998)
2028 998 IF(ASSOCIATED(surroundingelementslist)) CALL list_destroy(surroundingelementslist,dummy_err,dummy_error,*997)
2029 997 DO nic=-4,4
2030  IF(ASSOCIATED(adjacent_elements_list(nic)%PTR)) CALL list_destroy(adjacent_elements_list(nic)%PTR,dummy_err,dummy_error,*996)
2031  ENDDO !ni
2032 996 errors("DecompositionTopology_ElementAdjacentElementCalculate",err,error)
2033  exits("DecompositionTopology_ElementAdjacentElementCalculate")
2034  RETURN 1
2035 
2036  END SUBROUTINE decompositiontopology_elementadjacentelementcalculate
2037 
2038  !
2039  !================================================================================================================================
2040  !
2041 
2043  SUBROUTINE decomposition_topology_elements_calculate(TOPOLOGY,ERR,ERROR,*)
2044 
2045  !Argument variables
2046  TYPE(decomposition_topology_type), POINTER :: topology
2047  INTEGER(INTG), INTENT(OUT) :: err
2048  TYPE(varying_string), INTENT(OUT) :: error
2049  !Local Variables
2050  INTEGER(INTG) :: global_element,insert_status,local_element
2051  TYPE(decomposition_type), POINTER :: decomposition
2052  TYPE(decomposition_elements_type), POINTER :: decomposition_elements
2053  TYPE(domain_type), POINTER :: domain
2054  TYPE(domain_elements_type), POINTER :: domain_elements
2055  TYPE(domain_mapping_type), POINTER :: domain_elements_mapping
2056  TYPE(domain_mappings_type), POINTER :: domain_mappings
2057  TYPE(domain_topology_type), POINTER :: domain_topology
2058  TYPE(mesh_type), POINTER :: mesh
2059  TYPE(meshelementstype), POINTER :: mesh_elements
2060  TYPE(meshcomponenttopologytype), POINTER :: mesh_topology
2061 
2062  enters("DECOMPOSITION_TOPOLOGY_ELEMENTS_CALCULATE",err,error,*999)
2063 
2064  IF(ASSOCIATED(topology)) THEN
2065  decomposition_elements=>topology%ELEMENTS
2066  IF(ASSOCIATED(decomposition_elements)) THEN
2067  decomposition=>topology%DECOMPOSITION
2068  IF(ASSOCIATED(decomposition)) THEN
2069  domain=>decomposition%DOMAIN(decomposition%MESH_COMPONENT_NUMBER)%PTR
2070  IF(ASSOCIATED(domain)) THEN
2071  domain_topology=>domain%TOPOLOGY
2072  IF(ASSOCIATED(domain_topology)) THEN
2073  domain_elements=>domain_topology%ELEMENTS
2074  IF(ASSOCIATED(domain_elements)) THEN
2075  domain_mappings=>domain%MAPPINGS
2076  IF(ASSOCIATED(domain_mappings)) THEN
2077  domain_elements_mapping=>domain_mappings%ELEMENTS
2078  IF(ASSOCIATED(domain_elements_mapping)) THEN
2079  mesh=>decomposition%MESH
2080  IF(ASSOCIATED(mesh)) THEN
2081  mesh_topology=>mesh%TOPOLOGY(decomposition%MESH_COMPONENT_NUMBER)%PTR
2082  IF(ASSOCIATED(mesh_topology)) THEN
2083  mesh_elements=>mesh_topology%ELEMENTS
2084  IF(ASSOCIATED(mesh_elements)) THEN
2085  !Allocate the element topology arrays
2086  ALLOCATE(decomposition_elements%ELEMENTS(domain_elements%TOTAL_NUMBER_OF_ELEMENTS),stat=err)
2087  IF(err/=0) CALL flagerror("Could not allocate decomposition elements elements.",err,error,*999)
2088  decomposition_elements%NUMBER_OF_ELEMENTS=domain_elements%NUMBER_OF_ELEMENTS
2089  decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS=domain_elements%TOTAL_NUMBER_OF_ELEMENTS
2090  decomposition_elements%NUMBER_OF_GLOBAL_ELEMENTS=domain_elements%NUMBER_OF_GLOBAL_ELEMENTS
2091  CALL tree_create_start(decomposition_elements%ELEMENTS_TREE,err,error,*999)
2092  CALL tree_insert_type_set(decomposition_elements%ELEMENTS_TREE,tree_no_duplicates_allowed,err,error,*999)
2093  CALL tree_create_finish(decomposition_elements%ELEMENTS_TREE,err,error,*999)
2094  DO local_element=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
2095  CALL decomposition_topology_element_initialise(decomposition_elements%ELEMENTS(local_element), &
2096  & err,error,*999)
2097  global_element=domain_elements_mapping%LOCAL_TO_GLOBAL_MAP(local_element)
2098  decomposition_elements%ELEMENTS(local_element)%USER_NUMBER=mesh_elements%ELEMENTS(global_element)% &
2099  & user_number
2100  decomposition_elements%ELEMENTS(local_element)%LOCAL_NUMBER=local_element
2101  CALL tree_item_insert(decomposition_elements%ELEMENTS_TREE,decomposition_elements% &
2102  & elements(local_element)%USER_NUMBER,local_element,insert_status,err,error,*999)
2103  decomposition_elements%ELEMENTS(local_element)%GLOBAL_NUMBER=global_element
2104  decomposition_elements%ELEMENTS(local_element)%BOUNDARY_ELEMENT=mesh_elements% &
2105  & elements(global_element)%BOUNDARY_ELEMENT
2106  ENDDO !local_element
2107  !Calculate the elements surrounding the elements in the decomposition topology
2108  CALL decompositiontopology_elementadjacentelementcalculate(topology,err,error,*999)
2109  ELSE
2110  CALL flagerror("Mesh elements is not associated.",err,error,*999)
2111  ENDIF
2112  ELSE
2113  CALL flagerror("Mesh topology is not associated.",err,error,*999)
2114  ENDIF
2115  ELSE
2116  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
2117  ENDIF
2118  ELSE
2119  CALL flagerror("Domain mappings elements is not associated.",err,error,*999)
2120  ENDIF
2121  ELSE
2122  CALL flagerror("Domain mappings is not associated.",err,error,*999)
2123  ENDIF
2124  ELSE
2125  CALL flagerror("Domain topology elements is not associated.",err,error,*999)
2126  ENDIF
2127  ELSE
2128  CALL flagerror("Topology decomposition domain topology is not associated.",err,error,*999)
2129  ENDIF
2130  ELSE
2131  CALL flagerror("Topology decomposition domain is not associated.",err,error,*999)
2132  ENDIF
2133  ELSE
2134  CALL flagerror("Topology decomposition is not associated.",err,error,*999)
2135  ENDIF
2136  ELSE
2137  CALL flagerror("Topology elements is not associated.",err,error,*999)
2138  ENDIF
2139  ELSE
2140  CALL flagerror("Topology is not associated.",err,error,*999)
2141  ENDIF
2142 
2143  exits("DECOMPOSITION_TOPOLOGY_ELEMENTS_CALCULATE")
2144  RETURN
2145 999 errorsexits("DECOMPOSITION_TOPOLOGY_ELEMENTS_CALCULATE",err,error)
2146  RETURN 1
2147  END SUBROUTINE decomposition_topology_elements_calculate
2148 
2149  !
2150  !================================================================================================================================
2151  !
2152 
2154  SUBROUTINE decomposition_topology_elements_finalise(TOPOLOGY,ERR,ERROR,*)
2155 
2156  !Argument variables
2157  TYPE(decomposition_topology_type), POINTER :: topology
2158  INTEGER(INTG), INTENT(OUT) :: err
2159  TYPE(varying_string), INTENT(OUT) :: error
2160  !Local Variables
2161  INTEGER(INTG) :: ne
2162 
2163  enters("DECOMPOSITION_TOPOLOGY_ELEMENTS_FINALISE",err,error,*999)
2164 
2165  IF(ASSOCIATED(topology)) THEN
2166  IF(ASSOCIATED(topology%ELEMENTS)) THEN
2167  DO ne=1,topology%ELEMENTS%TOTAL_NUMBER_OF_ELEMENTS
2168  CALL decomposition_topology_element_finalise(topology%ELEMENTS%ELEMENTS(ne),err,error,*999)
2169  ENDDO !ne
2170  IF(ASSOCIATED(topology%ELEMENTS%ELEMENTS)) DEALLOCATE(topology%ELEMENTS%ELEMENTS)
2171  IF(ASSOCIATED(topology%ELEMENTS%ELEMENTS_TREE)) CALL tree_destroy(topology%ELEMENTS%ELEMENTS_TREE,err,error,*999)
2172  DEALLOCATE(topology%ELEMENTS)
2173  ENDIF
2174  ELSE
2175  CALL flagerror("Topology is not associated.",err,error,*999)
2176  ENDIF
2177 
2178  exits("DECOMPOSITION_TOPOLOGY_ELEMENTS_FINALISE")
2179  RETURN
2180 999 errorsexits("DECOMPOSITION_TOPOLOGY_ELEMENTS_FINALISE",err,error)
2181  RETURN 1
2182  END SUBROUTINE decomposition_topology_elements_finalise
2183 
2184  !
2185  !================================================================================================================================
2186  !
2187 
2189  SUBROUTINE decomposition_topology_elements_initialise(TOPOLOGY,ERR,ERROR,*)
2190 
2191  !Argument variables
2192  TYPE(decomposition_topology_type), POINTER :: topology
2193  INTEGER(INTG), INTENT(OUT) :: err
2194  TYPE(varying_string), INTENT(OUT) :: error
2195  !Local Variables
2196 
2197  enters("DECOMPOSITION_TOPOLOGY_ELEMENTS_INITIALISE",err,error,*999)
2198 
2199  IF(ASSOCIATED(topology)) THEN
2200  IF(ASSOCIATED(topology%ELEMENTS)) THEN
2201  CALL flagerror("Decomposition already has topology elements associated.",err,error,*999)
2202  ELSE
2203  ALLOCATE(topology%ELEMENTS,stat=err)
2204  IF(err/=0) CALL flagerror("Could not allocate topology elements.",err,error,*999)
2205  topology%ELEMENTS%NUMBER_OF_ELEMENTS=0
2206  topology%ELEMENTS%TOTAL_NUMBER_OF_ELEMENTS=0
2207  topology%ELEMENTS%NUMBER_OF_GLOBAL_ELEMENTS=0
2208  topology%ELEMENTS%DECOMPOSITION=>topology%DECOMPOSITION
2209  NULLIFY(topology%ELEMENTS%ELEMENTS)
2210  NULLIFY(topology%ELEMENTS%ELEMENTS_TREE)
2211  ENDIF
2212  ELSE
2213  CALL flagerror("Topology is not associated.",err,error,*999)
2214  ENDIF
2215 
2216  exits("DECOMPOSITION_TOPOLOGY_ELEMENTS_INITIALISE")
2217  RETURN
2218 999 errorsexits("DECOMPOSITION_TOPOLOGY_ELEMENTS_INITIALISE",err,error)
2219  RETURN 1
2220  END SUBROUTINE decomposition_topology_elements_initialise
2221 
2222  !
2223  !================================================================================================================================
2224  !
2225 
2227  SUBROUTINE decomposition_topology_finalise(DECOMPOSITION,ERR,ERROR,*)
2228 
2229  !Argument variables
2230  TYPE(decomposition_type), POINTER :: decomposition
2231  INTEGER(INTG), INTENT(OUT) :: err
2232  TYPE(varying_string), INTENT(OUT) :: error
2233  !Local Variables
2234 
2235  enters("DECOMPOSITION_TOPOLOGY_FINALISE",err,error,*999)
2236 
2237  IF(ASSOCIATED(decomposition)) THEN
2238  CALL decomposition_topology_elements_finalise(decomposition%TOPOLOGY,err,error,*999)
2239  IF(decomposition%CALCULATE_LINES) THEN
2240  CALL decomposition_topology_lines_finalise(decomposition%TOPOLOGY,err,error,*999)
2241  ENDIF
2242  IF(decomposition%CALCULATE_FACES) THEN
2243  CALL decomposition_topology_faces_finalise(decomposition%TOPOLOGY,err,error,*999)
2244  ENDIF
2245  DEALLOCATE(decomposition%TOPOLOGY)
2246  ELSE
2247  CALL flagerror("Decomposition is not associated.",err,error,*999)
2248  ENDIF
2249 
2250  exits("DECOMPOSITION_TOPOLOGY_FINALISE")
2251  RETURN
2252 999 errorsexits("DECOMPOSITION_TOPOLOGY_FINALISE",err,error)
2253  RETURN 1
2254 
2255  END SUBROUTINE decomposition_topology_finalise
2256 
2257  !
2258  !================================================================================================================================
2259  !
2260 
2262  SUBROUTINE decomposition_topology_initialise(DECOMPOSITION,ERR,ERROR,*)
2263 
2264  !Argument variables
2265  TYPE(decomposition_type), POINTER :: decomposition
2266  INTEGER(INTG), INTENT(OUT) :: err
2267  TYPE(varying_string), INTENT(OUT) :: error
2268  !Local Variables
2269  INTEGER(INTG) :: meshcomponentnumber
2270 
2271  enters("DECOMPOSITION_TOPOLOGY_INITIALISE",err,error,*999)
2272 
2273  IF(ASSOCIATED(decomposition)) THEN
2274  IF(ASSOCIATED(decomposition%TOPOLOGY)) THEN
2275  CALL flagerror("Decomposition already has topology associated.",err,error,*999)
2276  ELSE
2277  !Allocate decomposition topology
2278  ALLOCATE(decomposition%TOPOLOGY,stat=err)
2279  IF(err/=0) CALL flagerror("Decomposition topology could not be allocated.",err,error,*999)
2280  decomposition%TOPOLOGY%DECOMPOSITION=>decomposition
2281  NULLIFY(decomposition%TOPOLOGY%ELEMENTS)
2282  NULLIFY(decomposition%TOPOLOGY%LINES)
2283  NULLIFY(decomposition%TOPOLOGY%FACES)
2284  NULLIFY(decomposition%TOPOLOGY%dataPoints)
2285  !Initialise the topology components
2286  CALL decomposition_topology_elements_initialise(decomposition%TOPOLOGY,err,error,*999)
2287  IF(decomposition%CALCULATE_LINES) THEN !Default is currently true
2288  CALL decomposition_topology_lines_initialise(decomposition%TOPOLOGY,err,error,*999)
2289  ENDIF
2290  IF(decomposition%CALCULATE_FACES) THEN !Default is currently false
2291  CALL decomposition_topology_faces_initialise(decomposition%TOPOLOGY,err,error,*999)
2292  ENDIF
2293  meshcomponentnumber=decomposition%MESH_COMPONENT_NUMBER
2294  IF(ALLOCATED(decomposition%MESH%TOPOLOGY(meshcomponentnumber)%PTR%dataPoints%dataPoints)) THEN
2295  CALL decompositiontopology_datapointsinitialise(decomposition%TOPOLOGY,err,error,*999)
2296  ENDIF
2297  ENDIF
2298  ELSE
2299  CALL flagerror("Decomposition is not associated.",err,error,*999)
2300  ENDIF
2301 
2302  exits("DECOMPOSITION_TOPOLOGY_INITIALISE")
2303  RETURN
2304 999 errorsexits("DECOMPOSITION_TOPOLOGY_INITIALISE",err,error)
2305  RETURN 1
2306  END SUBROUTINE decomposition_topology_initialise
2307 
2308  !
2309  !================================================================================================================================
2310  !
2311 
2313  SUBROUTINE decomposition_topology_line_finalise(LINE,ERR,ERROR,*)
2314 
2315  !Argument variables
2316  TYPE(decomposition_line_type) :: line
2317  INTEGER(INTG), INTENT(OUT) :: err
2318  TYPE(varying_string), INTENT(OUT) :: error
2319  !Local Variables
2320 
2321  enters("DECOMPOSITION_TOPOLOGY_LINE_FINALISE",err,error,*999)
2322 
2323  line%NUMBER=0
2324  line%XI_DIRECTION=0
2325  line%NUMBER_OF_SURROUNDING_ELEMENTS=0
2326  IF(ALLOCATED(line%SURROUNDING_ELEMENTS)) DEALLOCATE(line%SURROUNDING_ELEMENTS)
2327  IF(ALLOCATED(line%ELEMENT_LINES)) DEALLOCATE(line%ELEMENT_LINES)
2328  line%ADJACENT_LINES=0
2329 
2330  exits("DECOMPOSITION_TOPOLOGY_LINE_FINALISE")
2331  RETURN
2332 999 errorsexits("DECOMPOSITION_TOPOLOGY_LINE_FINALISE",err,error)
2333  RETURN 1
2334  END SUBROUTINE decomposition_topology_line_finalise
2335 
2336  !
2337  !================================================================================================================================
2338  !
2339 
2341  SUBROUTINE decomposition_topology_line_initialise(LINE,ERR,ERROR,*)
2342 
2343  !Argument variables
2344  TYPE(decomposition_line_type) :: line
2345  INTEGER(INTG), INTENT(OUT) :: err
2346  TYPE(varying_string), INTENT(OUT) :: error
2347  !Local Variables
2348 
2349  enters("DECOMPOSITION_TOPOLOGY_LINE_INITIALISE",err,error,*999)
2350 
2351  line%NUMBER=0
2352  line%XI_DIRECTION=0
2353  line%NUMBER_OF_SURROUNDING_ELEMENTS=0
2354  line%ADJACENT_LINES=0
2355  line%BOUNDARY_LINE=.false.
2356 
2357  exits("DECOMPOSITION_TOPOLOGY_LINE_INITIALISE")
2358  RETURN
2359 999 errorsexits("DECOMPOSITION_TOPOLOGY_LINE_INITIALISE",err,error)
2360  RETURN 1
2361  END SUBROUTINE decomposition_topology_line_initialise
2362 
2363  !
2364  !================================================================================================================================
2365  !
2366 
2368  SUBROUTINE decomposition_topology_lines_calculate(TOPOLOGY,ERR,ERROR,*)
2369 
2370  !Argument variables
2371  TYPE(decomposition_topology_type), POINTER :: topology
2372  INTEGER(INTG), INTENT(OUT) :: err
2373  TYPE(varying_string), INTENT(OUT) :: error
2374  !Local Variables
2375  INTEGER(INTG) :: component_idx,element_idx,surrounding_element_idx,basis_local_line_idx, &
2376  & surrounding_element_basis_local_line_idx,element_local_node_idx,basis_local_line_node_idx,derivative_idx,version_idx, &
2377  & local_line_idx,surrounding_element_local_line_idx,node_idx,local_node_idx,elem_idx,line_end_node_idx,basis_node_idx, &
2378  & NODES_IN_LINE(4),NUMBER_OF_LINES,MAX_NUMBER_OF_LINES,NEW_MAX_NUMBER_OF_LINES,LINE_NUMBER,COUNT
2379  INTEGER(INTG), ALLOCATABLE :: nodes_number_of_lines(:)
2380  INTEGER(INTG), POINTER :: temp_lines(:,:),new_temp_lines(:,:)
2381  REAL(DP) :: approx_dimension
2382  LOGICAL :: found
2383  TYPE(basis_type), POINTER :: basis,basis2
2384  TYPE(decomposition_type), POINTER :: decomposition
2385  TYPE(decomposition_element_type), POINTER :: decomposition_element
2386  TYPE(decomposition_elements_type), POINTER :: decomposition_elements
2387  TYPE(decomposition_line_type), POINTER :: decomposition_line,decomposition_line2
2388  TYPE(decomposition_lines_type), POINTER :: decomposition_lines
2389  TYPE(domain_type), POINTER :: domain
2390  TYPE(domain_element_type), POINTER :: domain_element
2391  TYPE(domain_elements_type), POINTER :: domain_elements
2392  TYPE(domain_line_type), POINTER :: domain_line,domain_line2
2393  TYPE(domain_lines_type), POINTER :: domain_lines
2394  TYPE(domain_node_type), POINTER :: domain_node
2395  TYPE(domain_nodes_type), POINTER :: domain_nodes
2396  TYPE(domain_topology_type), POINTER :: domain_topology
2397  TYPE(mesh_type), POINTER :: mesh
2398 
2399  NULLIFY(temp_lines)
2400  NULLIFY(new_temp_lines)
2401 
2402  enters("DECOMPOSITION_TOPOLOGY_LINES_CALCULATE",err,error,*999)
2403 
2404  IF(ASSOCIATED(topology)) THEN
2405  decomposition_lines=>topology%LINES
2406  IF(ASSOCIATED(decomposition_lines)) THEN
2407  decomposition_elements=>topology%ELEMENTS
2408  IF(ASSOCIATED(decomposition_elements)) THEN
2409  decomposition=>topology%DECOMPOSITION
2410  IF(ASSOCIATED(decomposition)) THEN
2411  !Process the mesh component number (component number the decomposition was calculated from) first to establish line
2412  !topology then process the other mesh components.
2413  domain=>decomposition%DOMAIN(decomposition%MESH_COMPONENT_NUMBER)%PTR
2414  IF(ASSOCIATED(domain)) THEN
2415  domain_topology=>domain%TOPOLOGY
2416  IF(ASSOCIATED(domain_topology)) THEN
2417  domain_nodes=>domain_topology%NODES
2418  IF(ASSOCIATED(domain_nodes)) THEN
2419  domain_elements=>domain_topology%ELEMENTS
2420  IF(ASSOCIATED(domain_elements)) THEN
2421  !Guestimate the number of lines
2422  SELECT CASE(domain%NUMBER_OF_DIMENSIONS)
2423  CASE(1)
2424  max_number_of_lines=domain_elements%TOTAL_NUMBER_OF_ELEMENTS
2425  CASE(2)
2426  approx_dimension=sqrt(REAL(domain_elements%total_number_of_elements,dp))
2427  !This should give the maximum and will over estimate the number of lines for a "square mesh" by approx 33%
2428  max_number_of_lines=nint(3.0_dp*approx_dimension*(approx_dimension+1),intg)
2429  CASE(3)
2430  !This should give the maximum and will over estimate the number of lines for a "cube mesh" by approx 73%
2431  approx_dimension=REAL(domain_elements%total_number_of_elements,dp)**(1.0_dp/3.0_dp)
2432  max_number_of_lines=nint(11.0_dp*approx_dimension*approx_dimension*(approx_dimension+1),intg)
2433  CASE DEFAULT
2434  CALL flagerror("Invalid number of dimensions for a topology domain.",err,error,*999)
2435  END SELECT
2436  domain_lines=>domain_topology%LINES
2437  IF(ASSOCIATED(domain_lines)) THEN
2438  ALLOCATE(temp_lines(4,max_number_of_lines),stat=err)
2439  IF(err/=0) CALL flagerror("Could not allocate temporary lines array.",err,error,*999)
2440  ALLOCATE(nodes_number_of_lines(domain_nodes%TOTAL_NUMBER_OF_NODES),stat=err)
2441  IF(err/=0) CALL flagerror("Could not allocate nodes number of lines array.",err,error,*999)
2442  nodes_number_of_lines=0
2443  number_of_lines=0
2444  temp_lines=0
2445  !Loop over the elements in the topology
2446  DO element_idx=1,domain_elements%TOTAL_NUMBER_OF_ELEMENTS
2447  domain_element=>domain_elements%ELEMENTS(element_idx)
2448  decomposition_element=>decomposition_elements%ELEMENTS(element_idx)
2449  basis=>domain_element%BASIS
2450  ALLOCATE(decomposition_element%ELEMENT_LINES(basis%NUMBER_OF_LOCAL_LINES),stat=err)
2451  IF(err/=0) CALL flagerror("Could not allocate element element lines.",err,error,*999)
2452  !Loop over the local lines of the element
2453  DO basis_local_line_idx=1,basis%NUMBER_OF_LOCAL_LINES
2454  !Calculate the topology node numbers that make up the line
2455  nodes_in_line=0
2456  DO basis_local_line_node_idx=1,basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)
2457  nodes_in_line(basis_local_line_node_idx)=domain_element%ELEMENT_NODES( &
2458  & basis%NODE_NUMBERS_IN_LOCAL_LINE(basis_local_line_node_idx,basis_local_line_idx))
2459  ENDDO !basis_local_line_node_idx
2460  !Try and find a previously created line that matches in the adjacent elements
2461  found=.false.
2462  node_idx=nodes_in_line(1)
2463  DO elem_idx=1,domain_nodes%NODES(node_idx)%NUMBER_OF_SURROUNDING_ELEMENTS
2464  surrounding_element_idx=domain_nodes%NODES(node_idx)%SURROUNDING_ELEMENTS(elem_idx)
2465  IF(surrounding_element_idx/=element_idx) THEN
2466  IF(ALLOCATED(decomposition_elements%ELEMENTS(surrounding_element_idx)%ELEMENT_LINES)) THEN
2467  basis2=>domain_elements%ELEMENTS(surrounding_element_idx)%BASIS
2468  DO surrounding_element_basis_local_line_idx=1,basis2%NUMBER_OF_LOCAL_LINES
2469  local_line_idx=decomposition_elements%ELEMENTS(surrounding_element_idx)% &
2470  & element_lines(surrounding_element_basis_local_line_idx)
2471  IF(all(nodes_in_line(1:basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx))== &
2472  & temp_lines(1:basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx),local_line_idx))) THEN
2473  found=.true.
2474  EXIT
2475  ENDIF
2476  ENDDO !surrounding_element_basis_local_line_idx
2477  IF(found) EXIT
2478  ENDIF
2479  ENDIF
2480  ENDDO !elem_idx
2481  IF(found) THEN
2482  !Line has already been created
2483  decomposition_element%ELEMENT_LINES(basis_local_line_idx)=local_line_idx
2484  ELSE
2485  !Line has not been created
2486  IF(number_of_lines==max_number_of_lines) THEN
2487  !We are at maximum. Reallocate the LINES array to be 20% bigger and try again.
2488  new_max_number_of_lines=nint(1.20_dp*REAL(MAX_NUMBER_OF_LINES,DP),intg)
2489  ALLOCATE(new_temp_lines(4,new_max_number_of_lines),stat=err)
2490  IF(err/=0) CALL flagerror("Could not allocate new number of lines.",err,error,*999)
2491  new_temp_lines(:,1:number_of_lines)=temp_lines(:,1:number_of_lines)
2492  new_temp_lines(:,number_of_lines+1:new_max_number_of_lines)=0
2493  DEALLOCATE(temp_lines)
2494  temp_lines=>new_temp_lines
2495  NULLIFY(new_temp_lines)
2496  max_number_of_lines=new_max_number_of_lines
2497  ENDIF
2498  number_of_lines=number_of_lines+1
2499  temp_lines(:,number_of_lines)=nodes_in_line
2500  decomposition_element%ELEMENT_LINES(basis_local_line_idx)=number_of_lines
2501  DO basis_local_line_node_idx=1,SIZE(nodes_in_line,1)
2502  IF(nodes_in_line(basis_local_line_node_idx)/=0) &
2503  & nodes_number_of_lines(nodes_in_line(basis_local_line_node_idx))= &
2504  & nodes_number_of_lines(nodes_in_line(basis_local_line_node_idx))+1
2505  ENDDO !basis_local_line_node_idx
2506  ENDIF
2507  ENDDO !basis_local_line_idx
2508  ENDDO !element_idx
2509  !Allocate the line arrays and set them from the LINES and NODE_LINES arrays
2510  DO node_idx=1,domain_nodes%TOTAL_NUMBER_OF_NODES
2511  ALLOCATE(domain_nodes%NODES(node_idx)%NODE_LINES(nodes_number_of_lines(node_idx)),stat=err)
2512  IF(err/=0) CALL flagerror("Could not allocate node lines array.",err,error,*999)
2513  domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_LINES=0
2514  ENDDO !node_idx
2515  DEALLOCATE(nodes_number_of_lines)
2516  ALLOCATE(decomposition_lines%LINES(number_of_lines),stat=err)
2517  IF(err/=0) CALL flagerror("Could not allocate decomposition topology lines.",err,error,*999)
2518  decomposition_lines%NUMBER_OF_LINES=number_of_lines
2519  ALLOCATE(domain_lines%LINES(number_of_lines),stat=err)
2520  IF(err/=0) CALL flagerror("Could not allocate domain topology lines.",err,error,*999)
2521  domain_lines%NUMBER_OF_LINES=number_of_lines
2522  DO local_line_idx=1,domain_lines%NUMBER_OF_LINES
2523  CALL decomposition_topology_line_initialise(decomposition_lines%LINES(local_line_idx),err,error,*999)
2524  CALL domain_topology_line_initialise(domain_lines%LINES(local_line_idx),err,error,*999)
2525  DO basis_local_line_node_idx=1,SIZE(temp_lines,1)
2526  IF(temp_lines(basis_local_line_node_idx,local_line_idx)/=0) THEN
2527  node_idx=temp_lines(basis_local_line_node_idx,local_line_idx)
2528  domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_LINES=domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_LINES+1
2529  domain_nodes%NODES(node_idx)%NODE_LINES(domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_LINES)= &
2530  & local_line_idx
2531  ENDIF
2532  ENDDO !basis_local_line_node_idx
2533  ENDDO !local_line_idx
2534  DO element_idx=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
2535  decomposition_element=>decomposition_elements%ELEMENTS(element_idx)
2536  domain_element=>domain_elements%ELEMENTS(element_idx)
2537  basis=>domain_element%BASIS
2538  DO basis_local_line_idx=1,basis%NUMBER_OF_LOCAL_LINES
2539  line_number=decomposition_element%ELEMENT_LINES(basis_local_line_idx)
2540  decomposition_line=>decomposition_lines%LINES(line_number)
2541  domain_line=>domain_lines%LINES(line_number)
2542  decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS=decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS+1
2543  IF(.NOT.ASSOCIATED(domain_line%BASIS)) THEN
2544  decomposition_line%NUMBER=line_number
2545  domain_line%NUMBER=line_number
2546  domain_line%ELEMENT_NUMBER=element_idx !Needs checking
2547  decomposition_line%XI_DIRECTION=basis%LOCAL_LINE_XI_DIRECTION(basis_local_line_idx)
2548  domain_line%BASIS=>basis%LINE_BASES(decomposition_line%XI_DIRECTION)%PTR
2549  ALLOCATE(domain_line%NODES_IN_LINE(basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)),stat=err)
2550  IF(err/=0) CALL flagerror("Could not allocate line nodes in line.",err,error,*999)
2551  ALLOCATE(domain_line%DERIVATIVES_IN_LINE(2,domain_line%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES, &
2552  & basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)),stat=err)
2553  IF(err/=0) CALL flagerror("Could not allocate line derivatives in line.",err,error,*999)
2554  domain_line%NODES_IN_LINE(1:basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx))= &
2555  & temp_lines(1:basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx),line_number)
2556  DO basis_local_line_node_idx=1,basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)
2557  !Set derivative number of u (NO_GLOBAL_DERIV) for the domain line
2558  domain_line%DERIVATIVES_IN_LINE(1,1,basis_local_line_node_idx)=no_global_deriv
2559  !Set version number of u (NO_GLOBAL_DERIV) for the domain line
2560  version_idx=domain_element%elementVersions(1,basis%NODE_NUMBERS_IN_LOCAL_LINE( &
2561  & basis_local_line_node_idx,basis_local_line_idx))
2562  domain_line%DERIVATIVES_IN_LINE(2,1,basis_local_line_node_idx)=version_idx
2563  IF(domain_line%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES>1) THEN
2564  derivative_idx=domain_element%ELEMENT_DERIVATIVES( &
2565  & basis%DERIVATIVE_NUMBERS_IN_LOCAL_LINE(basis_local_line_node_idx,basis_local_line_idx), &
2566  & basis%NODE_NUMBERS_IN_LOCAL_LINE(basis_local_line_node_idx,basis_local_line_idx))
2567  domain_line%DERIVATIVES_IN_LINE(1,2,basis_local_line_node_idx)=derivative_idx
2568  version_idx=domain_element%elementVersions(basis%DERIVATIVE_NUMBERS_IN_LOCAL_LINE( &
2569  & basis_local_line_node_idx,basis_local_line_idx),basis%NODE_NUMBERS_IN_LOCAL_LINE( &
2570  & basis_local_line_node_idx,basis_local_line_idx))
2571  domain_line%DERIVATIVES_IN_LINE(2,2,basis_local_line_node_idx)=version_idx
2572  ENDIF
2573  ENDDO !basis_local_line_node_idx
2574  ENDIF
2575  ENDDO !basis_local_line_idx
2576  ENDDO !element_idx
2577  DEALLOCATE(temp_lines)
2578  !Calculate adjacent lines and the surrounding elements for each line
2579  DO local_line_idx=1,decomposition_lines%NUMBER_OF_LINES
2580  decomposition_line=>decomposition_lines%LINES(local_line_idx)
2581  domain_line=>domain_lines%LINES(local_line_idx)
2582  basis=>domain_line%BASIS
2583  IF(decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS==1) THEN
2584  decomposition_line%BOUNDARY_LINE=.true.
2585  domain_line%BOUNDARY_LINE=.true.
2586  ENDIF
2587  !Allocate the elements surrounding the line
2588  ALLOCATE(decomposition_line%SURROUNDING_ELEMENTS(decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS), &
2589  & stat=err)
2590  IF(err/=0) CALL flagerror("Could not allocate line surrounding elements.",err,error,*999)
2591  ALLOCATE(decomposition_line%ELEMENT_LINES(decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS), &
2592  & stat=err)
2593  IF(err/=0) CALL flagerror("Could not allocate line element lines.",err,error,*999)
2594  decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS=0
2595  decomposition_line%ADJACENT_LINES=0
2596  !Loop over the nodes at each end of the line
2597  DO line_end_node_idx=0,1
2598  found=.false.
2599  node_idx=domain_line%NODES_IN_LINE(line_end_node_idx*(basis%NUMBER_OF_NODES-1)+1)
2600  !Loop over the elements surrounding the node.
2601  DO elem_idx=1,domain_nodes%NODES(node_idx)%NUMBER_OF_SURROUNDING_ELEMENTS
2602  element_idx=domain_nodes%NODES(node_idx)%SURROUNDING_ELEMENTS(elem_idx)
2603  decomposition_element=>decomposition_elements%ELEMENTS(element_idx)
2604  domain_element=>domain_elements%ELEMENTS(element_idx)
2605  !Loop over the local lines of the element
2606  DO basis_local_line_idx=1,domain_element%BASIS%NUMBER_OF_LOCAL_LINES
2607  surrounding_element_local_line_idx=decomposition_element%ELEMENT_LINES(basis_local_line_idx)
2608  IF(surrounding_element_local_line_idx/=local_line_idx) THEN
2609  decomposition_line2=>decomposition_lines%LINES(surrounding_element_local_line_idx)
2610  domain_line2=>domain_lines%LINES(surrounding_element_local_line_idx)
2611  IF(decomposition_line2%XI_DIRECTION==decomposition_line%XI_DIRECTION) THEN
2612  !Lines run in the same direction.
2613  basis2=>domain_line2%BASIS
2614  IF(line_end_node_idx==0) THEN
2615  local_node_idx=domain_line2%NODES_IN_LINE(basis2%NUMBER_OF_NODES)
2616  ELSE
2617  local_node_idx=domain_line2%NODES_IN_LINE(1)
2618  ENDIF
2619  IF(local_node_idx==node_idx) THEN
2620  !The node at the 'other' end of this line matches the node at the current end of the line.
2621  !Check it is not a coexistant line running the other way
2622  IF(basis2%INTERPOLATION_ORDER(1)==basis%INTERPOLATION_ORDER(1)) THEN
2623  count=0
2624  DO basis_node_idx=1,basis%NUMBER_OF_NODES
2625  IF(domain_line2%NODES_IN_LINE(basis_node_idx)== &
2626  & domain_line%NODES_IN_LINE(basis2%NUMBER_OF_NODES-basis_node_idx+1)) &
2627  & count=count+1
2628  ENDDO !basis_node_idx
2629  IF(count<basis%NUMBER_OF_NODES) THEN
2630  found=.true.
2631  EXIT
2632  ENDIF
2633  ELSE
2634  found=.true.
2635  EXIT
2636  ENDIF
2637  ENDIF
2638  ENDIF
2639  ENDIF
2640  ENDDO !basis_local_line_idx
2641  IF(found) EXIT
2642  ENDDO !element_idx
2643  IF(found) decomposition_line%ADJACENT_LINES(line_end_node_idx)=surrounding_element_local_line_idx
2644  ENDDO !line_end_node_idx
2645  ENDDO !local_line_idx
2646  !Set the surrounding elements
2647  DO element_idx=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
2648  decomposition_element=>decomposition_elements%ELEMENTS(element_idx)
2649  domain_element=>domain_elements%ELEMENTS(element_idx)
2650  basis=>domain_element%BASIS
2651  DO basis_local_line_idx=1,basis%NUMBER_OF_LOCAL_LINES
2652  line_number=decomposition_element%ELEMENT_LINES(basis_local_line_idx)
2653  decomposition_line=>decomposition_lines%LINES(line_number)
2654  decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS=decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS+1
2655  decomposition_line%SURROUNDING_ELEMENTS(decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS)=element_idx
2656  decomposition_line%ELEMENT_LINES(decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS)=basis_local_line_idx
2657  ENDDO !basis_local_line_idx
2658  ENDDO !element_idx
2659  ELSE
2660  CALL flagerror("Domain topology lines is not associated.",err,error,*999)
2661  ENDIF
2662  ELSE
2663  CALL flagerror("Domain topology elements is not associated.",err,error,*999)
2664  ENDIF
2665  ELSE
2666  CALL flagerror("Domain topology nodes is not associated.",err,error,*999)
2667  ENDIF
2668  ELSE
2669  CALL flagerror("Topology decomposition domain topology is not associated.",err,error,*999)
2670  ENDIF
2671  ELSE
2672  CALL flagerror("Topology decomposition domain is not associated.",err,error,*999)
2673  ENDIF
2674  !Now loop over the other mesh components in the decomposition and calculate the domain lines
2675  mesh=>decomposition%MESH
2676  IF(ASSOCIATED(mesh)) THEN
2677  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
2678  IF(component_idx/=decomposition%MESH_COMPONENT_NUMBER) THEN
2679  domain=>decomposition%DOMAIN(component_idx)%PTR
2680  IF(ASSOCIATED(domain)) THEN
2681  domain_topology=>domain%TOPOLOGY
2682  IF(ASSOCIATED(domain_topology)) THEN
2683  domain_nodes=>domain_topology%NODES
2684  IF(ASSOCIATED(domain_nodes)) THEN
2685  domain_elements=>domain_topology%ELEMENTS
2686  IF(ASSOCIATED(domain_elements)) THEN
2687  domain_lines=>domain_topology%LINES
2688  IF(ASSOCIATED(domain_lines)) THEN
2689  ALLOCATE(domain_lines%LINES(decomposition_lines%NUMBER_OF_LINES),stat=err)
2690  IF(err/=0) CALL flagerror("Could not allocate domain lines lines.",err,error,*999)
2691  domain_lines%NUMBER_OF_LINES=decomposition_lines%NUMBER_OF_LINES
2692  ALLOCATE(nodes_number_of_lines(domain_nodes%TOTAL_NUMBER_OF_NODES),stat=err)
2693  IF(err/=0) CALL flagerror("Could not allocate nodes number of lines array.",err,error,*999)
2694  nodes_number_of_lines=0
2695  !Loop over the lines in the topology
2696  DO local_line_idx=1,decomposition_lines%NUMBER_OF_LINES
2697  decomposition_line=>decomposition_lines%LINES(local_line_idx)
2698  domain_line=>domain_lines%LINES(local_line_idx)
2699  IF(decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS>0) THEN
2700  element_idx=decomposition_line%SURROUNDING_ELEMENTS(1)
2701  basis_local_line_idx=decomposition_line%ELEMENT_LINES(1)
2702  CALL domain_topology_line_initialise(domain_lines%LINES(local_line_idx),err,error,*999)
2703  domain_line%NUMBER=local_line_idx
2704  domain_element=>domain_elements%ELEMENTS(element_idx)
2705  basis=>domain_element%BASIS
2706  domain_line%ELEMENT_NUMBER=domain_element%NUMBER
2707  domain_line%BASIS=>basis%LINE_BASES(decomposition_line%XI_DIRECTION)%PTR
2708  ALLOCATE(domain_line%NODES_IN_LINE(basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)), &
2709  & stat=err)
2710  IF(err/=0) CALL flagerror("Could not allocate nodes in line.",err,error,*999)
2711  ALLOCATE(domain_line%DERIVATIVES_IN_LINE(2,domain_line%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES, &
2712  & basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)),stat=err)
2713  IF(err/=0) CALL flagerror("Could not allocate derivatives in line.",err,error,*999)
2714  DO basis_local_line_node_idx=1,basis%NUMBER_OF_NODES_IN_LOCAL_LINE(basis_local_line_idx)
2715  element_local_node_idx=basis%NODE_NUMBERS_IN_LOCAL_LINE(basis_local_line_node_idx, &
2716  & basis_local_line_idx)
2717  node_idx=domain_element%ELEMENT_NODES(element_local_node_idx)
2718  domain_line%NODES_IN_LINE(basis_local_line_node_idx)=node_idx
2719  !Set derivative number of u (NO_GLOBAL_DERIV) for the domain line
2720  domain_line%DERIVATIVES_IN_LINE(1,1,basis_local_line_node_idx)=no_global_deriv
2721  !Set version number of u (NO_GLOBAL_DERIV) for the domain line
2722  version_idx=domain_element%elementVersions(1,basis%NODE_NUMBERS_IN_LOCAL_LINE( &
2723  & basis_local_line_node_idx,basis_local_line_idx))
2724  domain_line%DERIVATIVES_IN_LINE(2,1,basis_local_line_node_idx)=version_idx
2725  IF(domain_line%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES>1) THEN
2726  derivative_idx=domain_element%ELEMENT_DERIVATIVES(basis%DERIVATIVE_NUMBERS_IN_LOCAL_LINE( &
2727  & basis_local_line_node_idx,basis_local_line_idx),element_local_node_idx)
2728  domain_line%DERIVATIVES_IN_LINE(1,2,basis_local_line_node_idx)=derivative_idx
2729  version_idx=domain_element%elementVersions(basis%DERIVATIVE_NUMBERS_IN_LOCAL_LINE( &
2730  & basis_local_line_node_idx,basis_local_line_idx),basis%NODE_NUMBERS_IN_LOCAL_LINE( &
2731  & basis_local_line_node_idx,basis_local_line_idx))
2732  domain_line%DERIVATIVES_IN_LINE(2,2,basis_local_line_node_idx)=version_idx
2733  ENDIF
2734  nodes_number_of_lines(node_idx)=nodes_number_of_lines(node_idx)+1
2735  ENDDO !basis_local_line_node_idx
2736  ELSE
2737  CALL flagerror("Line is not surrounded by any elements?",err,error,*999)
2738  ENDIF
2739  ENDDO !local_line_idx
2740  DO node_idx=1,domain_nodes%TOTAL_NUMBER_OF_NODES
2741  ALLOCATE(domain_nodes%NODES(node_idx)%NODE_LINES(nodes_number_of_lines(node_idx)),stat=err)
2742  IF(err/=0) CALL flagerror("Could not allocate node lines.",err,error,*999)
2743  domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_LINES=0
2744  ENDDO !node_idx
2745  DEALLOCATE(nodes_number_of_lines)
2746  DO local_line_idx=1,domain_lines%NUMBER_OF_LINES
2747  domain_line=>domain_lines%LINES(local_line_idx)
2748  basis=>domain_line%BASIS
2749  DO basis_local_line_node_idx=1,basis%NUMBER_OF_NODES
2750  node_idx=domain_line%NODES_IN_LINE(basis_local_line_node_idx)
2751  domain_node=>domain_nodes%NODES(node_idx)
2752  domain_node%NUMBER_OF_NODE_LINES=domain_node%NUMBER_OF_NODE_LINES+1
2753  domain_node%NODE_LINES(domain_node%NUMBER_OF_NODE_LINES)=local_line_idx
2754  ENDDO !basis_local_line_node_idx
2755  ENDDO !local_line_idx
2756  ELSE
2757  CALL flagerror("Domain lines is not associated.",err,error,*999)
2758  ENDIF
2759  ELSE
2760  CALL flagerror("Domain elements is not associated.",err,error,*999)
2761  ENDIF
2762  ELSE
2763  CALL flagerror("Domain nodes is not associated.",err,error,*999)
2764  ENDIF
2765  ELSE
2766  CALL flagerror("Domain topology is not associated.",err,error,*999)
2767  ENDIF
2768  ELSE
2769  CALL flagerror("Decomposition mesh is not associated",err,error,*999)
2770  ENDIF
2771  ENDIF
2772  ENDDO !component_idx
2773  ELSE
2774  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
2775  ENDIF
2776  ELSE
2777  CALL flagerror("Topology decomposition is not associated.",err,error,*999)
2778  ENDIF
2779  ELSE
2780  CALL flagerror("Topology decomposition elements is not associated.",err,error,*999)
2781  ENDIF
2782  ELSE
2783  CALL flagerror("Topology lines is not associated.",err,error,*999)
2784 
2785  ENDIF
2786  ELSE
2787  CALL flagerror("Topology is not associated.",err,error,*999)
2788  ENDIF
2789 
2790  IF(diagnostics1) THEN
2791  CALL write_string(diagnostic_output_type,"Decomposition topology lines:",err,error,*999)
2792  CALL write_string_value(diagnostic_output_type," Number of mesh components = ",mesh%NUMBER_OF_COMPONENTS,err,error,*999)
2793  CALL write_string_value(diagnostic_output_type," Number of lines = ",decomposition_lines%NUMBER_OF_LINES,err,error,*999)
2794  DO local_line_idx=1,decomposition_lines%NUMBER_OF_LINES
2795  decomposition_line=>decomposition_lines%LINES(local_line_idx)
2796  domain_line=>domain_lines%LINES(local_line_idx)
2797  CALL write_string_value(diagnostic_output_type," Line number = ",decomposition_line%NUMBER,err,error,*999)
2798  CALL write_string_value(diagnostic_output_type," Xi direction = ",decomposition_line%XI_DIRECTION,err,error,*999)
2799  CALL write_string_value(diagnostic_output_type," Number of surrounding elements = ", &
2800  & decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS,err,error,*999)
2801  CALL write_string_vector(diagnostic_output_type,1,1,decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS,4,4, &
2802  & decomposition_line%SURROUNDING_ELEMENTS,'(" Surrounding elements :",4(X,I8))','(28X,4(X,I8))',err,error,*999)
2803  CALL write_string_vector(diagnostic_output_type,1,1,decomposition_line%NUMBER_OF_SURROUNDING_ELEMENTS,4,4, &
2804  & decomposition_line%ELEMENT_LINES,'(" Element lines :",4(X,I8))','(28X,4(X,I8))',err,error,*999)
2805  CALL write_string_vector(diagnostic_output_type,1,1,2,2,2,decomposition_line%ADJACENT_LINES, &
2806  & '(" Adjacent lines :",2(X,I8))','(28X,2(X,I8))',err,error,*999)
2807  CALL write_string_value(diagnostic_output_type," Boundary line = ",decomposition_line%BOUNDARY_LINE,err,error,*999)
2808  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
2809  CALL write_string_value(diagnostic_output_type," Mesh component : ",component_idx,err,error,*999)
2810  domain=>decomposition%DOMAIN(component_idx)%PTR
2811  domain_line=>domain%TOPOLOGY%LINES%LINES(local_line_idx)
2812  CALL write_string_value(diagnostic_output_type," Basis user number = ",domain_line%BASIS%USER_NUMBER, &
2813  & err,error,*999)
2814  CALL write_string_value(diagnostic_output_type," Basis family number = ",domain_line%BASIS%FAMILY_NUMBER, &
2815  & err,error,*999)
2816  CALL write_string_value(diagnostic_output_type," Basis interpolation type = ",domain_line%BASIS% &
2817  & interpolation_type(1),err,error,*999)
2818  CALL write_string_value(diagnostic_output_type," Basis interpolation order = ",domain_line%BASIS% &
2819  & interpolation_order(1),err,error,*999)
2820  CALL write_string_value(diagnostic_output_type," Number of nodes in lines = ",domain_line%BASIS%NUMBER_OF_NODES, &
2821  & err,error,*999)
2822  CALL write_string_vector(diagnostic_output_type,1,1,domain_line%BASIS%NUMBER_OF_NODES,4,4,domain_line%NODES_IN_LINE, &
2823  & '(" Nodes in line :",4(X,I8))','(30X,4(X,I8))',err,error,*999)
2824  DO basis_local_line_node_idx=1,domain_line%BASIS%NUMBER_OF_NODES
2825  CALL write_string_value(diagnostic_output_type," Node : ",basis_local_line_node_idx,err,error,*999)
2826  !/TODO::Loop over local_derivative index so this output makes more sense !<DERIVATIVES_IN_LINE(i,local_derivative_idx,local_node_idx)
2827  CALL write_string_vector(diagnostic_output_type,1,1, &
2828  & domain_line%BASIS%NUMBER_OF_DERIVATIVES(basis_local_line_node_idx),4,4, &
2829  & domain_line%DERIVATIVES_IN_LINE(1,:,basis_local_line_node_idx),'(" Derivatives in line :",4(X,I8))', &
2830  & '(34X,4(X,I8))',err,error,*999)
2831  CALL write_string_vector(diagnostic_output_type,1,1, &
2832  & domain_line%BASIS%NUMBER_OF_DERIVATIVES(basis_local_line_node_idx),4,4, &
2833  & domain_line%DERIVATIVES_IN_LINE(2,:,basis_local_line_node_idx), &
2834  & '(" Derivatives Versions in line :",4(X,I8))','(34X,4(X,I8))',err,error,*999)
2835  ENDDO !basis_local_line_node_idx
2836  ENDDO !component_idx
2837  ENDDO !local_line_idx
2838  ENDIF
2839 
2840  exits("DECOMPOSITION_TOPOLOGY_LINES_CALCULATE")
2841  RETURN
2842 999 IF(ASSOCIATED(temp_lines)) DEALLOCATE(temp_lines)
2843  IF(ASSOCIATED(new_temp_lines)) DEALLOCATE(new_temp_lines)
2844  IF(ALLOCATED(nodes_number_of_lines)) DEALLOCATE(nodes_number_of_lines)
2845  errorsexits("DECOMPOSITION_TOPOLOGY_LINES_CALCULATE",err,error)
2846  RETURN 1
2847  END SUBROUTINE decomposition_topology_lines_calculate
2848 
2849  !
2850  !================================================================================================================================
2851  !
2852 
2854  SUBROUTINE decomposition_topology_lines_finalise(TOPOLOGY,ERR,ERROR,*)
2855 
2856  !Argument variables
2857  TYPE(decomposition_topology_type), POINTER :: topology
2858  INTEGER(INTG), INTENT(OUT) :: err
2859  TYPE(varying_string), INTENT(OUT) :: error
2860  !Local Variables
2861  INTEGER(INTG) :: nl
2862 
2863  enters("DECOMPOSITION_TOPOLOGY_LINES_FINALISE",err,error,*999)
2864 
2865  IF(ASSOCIATED(topology)) THEN
2866  IF(ASSOCIATED(topology%LINES)) THEN
2867  DO nl=1,topology%LINES%NUMBER_OF_LINES
2868  CALL decomposition_topology_line_finalise(topology%LINES%LINES(nl),err,error,*999)
2869  ENDDO !nl
2870  IF(ALLOCATED(topology%LINES%LINES)) DEALLOCATE(topology%LINES%LINES)
2871  DEALLOCATE(topology%LINES)
2872  ENDIF
2873  ELSE
2874  CALL flagerror("Topology is not associated.",err,error,*999)
2875  ENDIF
2876 
2877  exits("DECOMPOSITION_TOPOLOGY_LINES_FINALISE")
2878  RETURN
2879 999 errorsexits("DECOMPOSITION_TOPOLOGY_LINES_FINALISE",err,error)
2880  RETURN 1
2881  END SUBROUTINE decomposition_topology_lines_finalise
2882 
2883  !
2884  !================================================================================================================================
2885  !
2886 
2888  SUBROUTINE decomposition_topology_lines_initialise(TOPOLOGY,ERR,ERROR,*)
2889 
2890  !Argument variables
2891  TYPE(decomposition_topology_type), POINTER :: topology
2892  INTEGER(INTG), INTENT(OUT) :: err
2893  TYPE(varying_string), INTENT(OUT) :: error
2894  !Local Variables
2895 
2896  enters("DECOMPOSITION_TOPOLOGY_LINES_INITIALISE",err,error,*999)
2897 
2898  IF(ASSOCIATED(topology)) THEN
2899  IF(ASSOCIATED(topology%LINES)) THEN
2900  CALL flagerror("Decomposition already has topology lines associated.",err,error,*999)
2901  ELSE
2902  ALLOCATE(topology%LINES,stat=err)
2903  IF(err/=0) CALL flagerror("Could not allocate topology lines.",err,error,*999)
2904  topology%LINES%NUMBER_OF_LINES=0
2905  topology%LINES%DECOMPOSITION=>topology%DECOMPOSITION
2906  ENDIF
2907  ELSE
2908  CALL flagerror("Topology is not associated.",err,error,*999)
2909  ENDIF
2910 
2911  exits("DECOMPOSITION_TOPOLOGY_LINES_INITIALISE")
2912  RETURN
2913 999 errorsexits("DECOMPOSITION_TOPOLOGY_LINES_INITIALISE",err,error)
2914  RETURN 1
2915  END SUBROUTINE decomposition_topology_lines_initialise
2916 
2917  !
2918  !================================================================================================================================
2919  !
2920 
2922  SUBROUTINE decompositiontopology_datapointsinitialise(TOPOLOGY,ERR,ERROR,*)
2923 
2924  !Argument variables
2925  TYPE(decomposition_topology_type), POINTER :: topology
2926  INTEGER(INTG), INTENT(OUT) :: err
2927  TYPE(varying_string), INTENT(OUT) :: error
2928  !Local Variables
2929 
2930  enters("DecompositionTopology_DataPointsInitialise",err,error,*999)
2931 
2932  IF(ASSOCIATED(topology)) THEN
2933  IF(ASSOCIATED(topology%dataPoints)) THEN
2934  CALL flagerror("Decomposition already has topology data points associated.",err,error,*999)
2935  ELSE
2936  ALLOCATE(topology%dataPoints,stat=err)
2937  IF(err/=0) CALL flagerror("Could not allocate topology data points.",err,error,*999)
2938  topology%dataPoints%numberOfDataPoints=0
2939  topology%dataPoints%totalNumberOfDataPoints=0
2940  topology%dataPoints%numberOfGlobalDataPoints=0
2941  NULLIFY(topology%dataPoints%dataPointsTree)
2942  topology%dataPoints%DECOMPOSITION=>topology%DECOMPOSITION
2943  ENDIF
2944  ELSE
2945  CALL flagerror("Topology is not associated.",err,error,*999)
2946  ENDIF
2947 
2948  exits("DecompositionTopology_DataPointsInitialise")
2949  RETURN
2950 999 errorsexits("DecompositionTopology_DataPointsInitialise",err,error)
2951  RETURN 1
2952  END SUBROUTINE decompositiontopology_datapointsinitialise
2953 
2954  !
2955  !================================================================================================================================
2956  !
2957 
2959  SUBROUTINE decomposition_topology_face_finalise(FACE,ERR,ERROR,*)
2960 
2961  !Argument variables
2962  TYPE(decomposition_face_type) :: face
2963  INTEGER(INTG), INTENT(OUT) :: err
2964  TYPE(varying_string), INTENT(OUT) :: error
2965  !Local Variables
2966 
2967  enters("DECOMPOSITION_TOPOLOGY_FACE_FINALISE",err,error,*999)
2968 
2969  face%NUMBER=0
2970  face%XI_DIRECTION=0
2971  face%NUMBER_OF_SURROUNDING_ELEMENTS=0
2972  IF(ALLOCATED(face%SURROUNDING_ELEMENTS)) DEALLOCATE(face%SURROUNDING_ELEMENTS)
2973  IF(ALLOCATED(face%ELEMENT_FACES)) DEALLOCATE(face%ELEMENT_FACES)
2974 ! FACE%ADJACENT_FACES=0
2975 
2976  exits("DECOMPOSITION_TOPOLOGY_FACE_FINALISE")
2977  RETURN
2978 999 errorsexits("DECOMPOSITION_TOPOLOGY_FACE_FINALISE",err,error)
2979  RETURN 1
2980  END SUBROUTINE decomposition_topology_face_finalise
2981 
2982  !
2983  !================================================================================================================================
2984  !
2985 
2987  SUBROUTINE decomposition_topology_face_initialise(FACE,ERR,ERROR,*)
2988 
2989  !Argument variables
2990  TYPE(decomposition_face_type) :: face
2991  INTEGER(INTG), INTENT(OUT) :: err
2992  TYPE(varying_string), INTENT(OUT) :: error
2993  !Local Variables
2994 
2995  enters("DECOMPOSITION_TOPOLOGY_FACE_INITIALISE",err,error,*999)
2996 
2997  face%NUMBER=0
2998  face%XI_DIRECTION=0
2999  face%NUMBER_OF_SURROUNDING_ELEMENTS=0
3000 ! FACE%ADJACENT_FACES=0
3001  face%BOUNDARY_FACE=.false.
3002 
3003  exits("DECOMPOSITION_TOPOLOGY_FACE_INITIALISE")
3004  RETURN
3005 999 errorsexits("DECOMPOSITION_TOPOLOGY_FACE_INITIALISE",err,error)
3006  RETURN 1
3007  END SUBROUTINE decomposition_topology_face_initialise
3008 
3009  !
3010  !================================================================================================================================
3011  !
3012 
3014  SUBROUTINE decomposition_topology_faces_calculate(TOPOLOGY,ERR,ERROR,*)
3015 
3016  !Argument variables
3017  TYPE(decomposition_topology_type), POINTER :: topology
3018  INTEGER(INTG), INTENT(OUT) :: err
3019  TYPE(varying_string), INTENT(OUT) :: error
3020  !Local Variables
3021  INTEGER(INTG) :: component_idx,ne,surrounding_element_idx,basis_local_face_idx,surrounding_element_basis_local_face_idx, &
3022  & element_local_node_idx,basis_local_face_node_idx,basis_local_face_derivative_idx,derivative_idx,version_idx,face_idx, &
3023  & node_idx,elem_idx,NODES_IN_FACE(16),NUMBER_OF_FACES,MAX_NUMBER_OF_FACES,NEW_MAX_NUMBER_OF_FACES,FACE_NUMBER
3024  INTEGER(INTG), ALLOCATABLE :: nodes_number_of_faces(:)
3025  INTEGER(INTG), POINTER :: temp_faces(:,:),new_temp_faces(:,:)
3026  LOGICAL :: found
3027  TYPE(basis_type), POINTER :: basis,basis2
3028  TYPE(decomposition_type), POINTER :: decomposition
3029  TYPE(decomposition_element_type), POINTER :: decomposition_element
3030  TYPE(decomposition_elements_type), POINTER :: decomposition_elements
3031  TYPE(decomposition_face_type), POINTER :: decomposition_face!,DECOMPOSITION_FACE2
3032  TYPE(decomposition_faces_type), POINTER :: decomposition_faces
3033  TYPE(domain_type), POINTER :: domain
3034  TYPE(domain_element_type), POINTER :: domain_element
3035  TYPE(domain_elements_type), POINTER :: domain_elements
3036  TYPE(domain_face_type), POINTER :: domain_face!,DOMAIN_FACE2
3037  TYPE(domain_faces_type), POINTER :: domain_faces
3038  TYPE(domain_node_type), POINTER :: domain_node
3039  TYPE(domain_nodes_type), POINTER :: domain_nodes
3040  TYPE(domain_topology_type), POINTER :: domain_topology
3041  TYPE(mesh_type), POINTER :: mesh
3042 
3043  NULLIFY(temp_faces)
3044  NULLIFY(new_temp_faces)
3045 
3046  enters("DECOMPOSITION_TOPOLOGY_FACES_CALCULATE",err,error,*999)
3047 
3048  IF(ASSOCIATED(topology)) THEN
3049  decomposition_faces=>topology%FACES
3050  IF(ASSOCIATED(decomposition_faces)) THEN
3051  decomposition_elements=>topology%ELEMENTS
3052  IF(ASSOCIATED(decomposition_elements)) THEN
3053  decomposition=>topology%DECOMPOSITION
3054  IF(ASSOCIATED(decomposition)) THEN
3055  !Process the mesh component number (component number the decomposition was calculated from) first to establish face
3056  !topology then process the other mesh components.
3057  domain=>decomposition%DOMAIN(decomposition%MESH_COMPONENT_NUMBER)%PTR
3058  IF(ASSOCIATED(domain)) THEN
3059  domain_topology=>domain%TOPOLOGY
3060  IF(ASSOCIATED(domain_topology)) THEN
3061  domain_nodes=>domain_topology%NODES
3062  IF(ASSOCIATED(domain_nodes)) THEN
3063  domain_elements=>domain_topology%ELEMENTS
3064  IF(ASSOCIATED(domain_elements)) THEN
3065  !Estimate the number of faces
3066  SELECT CASE(domain%NUMBER_OF_DIMENSIONS)
3067  CASE(1)
3068  ! Faces not calculated in 1D
3069  CASE(2)
3070  ! Faces not calculated in 2D
3071  CASE(3)
3072  !This should give the maximum and will over estimate the number of faces for a "cube mesh" by approx 33%
3073  max_number_of_faces= &
3074  & nint(((REAL(domain_elements%total_number_of_elements,dp)*5.0_dp)+1.0_dp)*(4.0_dp/3.0_dp),intg)
3075 
3076  domain_faces=>domain_topology%FACES
3077  IF(ASSOCIATED(domain_faces)) THEN
3078  ALLOCATE(temp_faces(16,max_number_of_faces),stat=err)
3079  IF(err/=0) CALL flagerror("Could not allocate temporary faces array",err,error,*999)
3080  ALLOCATE(nodes_number_of_faces(domain_nodes%TOTAL_NUMBER_OF_NODES),stat=err)
3081  IF(err/=0) CALL flagerror("Could not allocate nodes number of faces array",err,error,*999)
3082  nodes_number_of_faces=0
3083  number_of_faces=0
3084  temp_faces=0
3085  !Loop over the elements in the topology and fill temp_faces with node numbers for each element
3086  DO ne=1,domain_elements%TOTAL_NUMBER_OF_ELEMENTS
3087  domain_element=>domain_elements%ELEMENTS(ne)
3088  decomposition_element=>decomposition_elements%ELEMENTS(ne)
3089  basis=>domain_element%BASIS
3090  ALLOCATE(decomposition_element%ELEMENT_FACES(basis%NUMBER_OF_LOCAL_FACES),stat=err)
3091  IF(err/=0) CALL flagerror("Could not allocate element faces of element",err,error,*999)
3092  !Loop over the local faces of the element
3093  DO basis_local_face_idx=1,basis%NUMBER_OF_LOCAL_FACES
3094  !Calculate the topology node numbers that make up the face
3095  nodes_in_face=0
3096  !Check whether face has already been read out
3097  DO basis_local_face_node_idx=1,basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)
3098  !Read out node numbers of local face from ELEMENT_NODES
3099  nodes_in_face(basis_local_face_node_idx)=domain_element%ELEMENT_NODES( &
3100  & basis%NODE_NUMBERS_IN_LOCAL_FACE(basis_local_face_node_idx,basis_local_face_idx))
3101  ENDDO !basis_local_face_node_idx
3102  !Try and find a previously created face that matches in the adjacent elements
3103  found=.false.
3104  node_idx=nodes_in_face(1)
3105  DO elem_idx=1,domain_nodes%NODES(node_idx)%NUMBER_OF_SURROUNDING_ELEMENTS
3106  surrounding_element_idx=domain_nodes%NODES(node_idx)%SURROUNDING_ELEMENTS(elem_idx)
3107  IF(surrounding_element_idx/=ne) THEN
3108  IF(ALLOCATED(decomposition_elements%ELEMENTS(surrounding_element_idx)%ELEMENT_FACES)) THEN
3109  basis2=>domain_elements%ELEMENTS(surrounding_element_idx)%BASIS
3110  DO surrounding_element_basis_local_face_idx=1,basis2%NUMBER_OF_LOCAL_FACES
3111  face_idx=decomposition_elements%ELEMENTS(surrounding_element_idx)%ELEMENT_FACES( &
3112  & surrounding_element_basis_local_face_idx)
3113  IF(all(nodes_in_face(1:basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx))== &
3114  & temp_faces(1:basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx),face_idx))) THEN
3115  found=.true.
3116  EXIT
3117  ENDIF
3118  ENDDO !surrounding_element_basis_local_face_idx
3119  IF(found) EXIT
3120  ENDIF
3121  ENDIF
3122  ENDDO !elem_idx
3123  IF(found) THEN
3124  !Face has already been created
3125  decomposition_element%ELEMENT_FACES(basis_local_face_idx)=face_idx
3126  ELSE
3127  !Face has not been created
3128  IF(number_of_faces==max_number_of_faces) THEN
3129  !We are at maximum. Reallocate the FACES array to be 20% bigger and try again.
3130  new_max_number_of_faces=nint(1.20_dp*REAL(MAX_NUMBER_OF_FACES,DP),intg)
3131  !\todo: Change 16 to a variable and above for NODES_IN_FACE
3132  ALLOCATE(new_temp_faces(16,new_max_number_of_faces),stat=err)
3133  IF(err/=0) CALL flagerror("Could not allocate new number of faces",err,error,*999)
3134  new_temp_faces(:,1:number_of_faces)=temp_faces(:,1:number_of_faces)
3135  new_temp_faces(:,number_of_faces+1:new_max_number_of_faces)=0
3136  DEALLOCATE(temp_faces)
3137  temp_faces=>new_temp_faces
3138  NULLIFY(new_temp_faces)
3139  max_number_of_faces=new_max_number_of_faces
3140  ENDIF
3141  number_of_faces=number_of_faces+1
3142  temp_faces(:,number_of_faces)=nodes_in_face(:)
3143  decomposition_element%ELEMENT_FACES(basis_local_face_idx)=number_of_faces
3144  DO basis_local_face_node_idx=1,SIZE(nodes_in_face,1)
3145  IF(nodes_in_face(basis_local_face_node_idx)/=0) &
3146  & nodes_number_of_faces(nodes_in_face(basis_local_face_node_idx))= &
3147  & nodes_number_of_faces(nodes_in_face(basis_local_face_node_idx))+1
3148  ENDDO !basis_local_face_node_idx
3149  ENDIF
3150  ENDDO !basis_local_face_idx
3151  ENDDO !ne
3152 
3153  !Allocate the face arrays and set them from the FACES and NODE_FACES arrays
3154  DO node_idx=1,domain_nodes%TOTAL_NUMBER_OF_NODES
3155  ALLOCATE(domain_nodes%NODES(node_idx)%NODE_FACES(nodes_number_of_faces(node_idx)),stat=err)
3156  IF(err/=0) CALL flagerror("Could not allocate node faces array",err,error,*999)
3157  domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_FACES=0
3158  ENDDO !node_idx
3159  DEALLOCATE(nodes_number_of_faces)
3160  ALLOCATE(decomposition_faces%FACES(number_of_faces),stat=err)
3161  IF(err/=0) CALL flagerror("Could not allocate decomposition topology faces",err,error,*999)
3162  decomposition_faces%NUMBER_OF_FACES=number_of_faces
3163  ALLOCATE(domain_faces%FACES(number_of_faces),stat=err)
3164  IF(err/=0) CALL flagerror("Could not allocate domain topology faces",err,error,*999)
3165  domain_faces%NUMBER_OF_FACES=number_of_faces
3166  DO face_idx=1,domain_faces%NUMBER_OF_FACES
3167  CALL decomposition_topology_face_initialise(decomposition_faces%FACES(face_idx),err,error,*999)
3168  CALL domain_topology_face_initialise(domain_faces%FACES(face_idx),err,error,*999)
3169  DO basis_local_face_node_idx=1,SIZE(temp_faces,1)
3170  IF(temp_faces(basis_local_face_node_idx,face_idx)/=0) THEN
3171  node_idx=temp_faces(basis_local_face_node_idx,face_idx)
3172  domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_FACES=domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_FACES+1
3173  domain_nodes%NODES(node_idx)%NODE_FACES(domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_FACES)=face_idx
3174  ENDIF
3175  ENDDO !basis_local_face_node_idx
3176  ENDDO !face_idx
3177 
3178  !Set nodes in face and derivatives of nodes in face for domain faces
3179  DO ne=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
3180  decomposition_element=>decomposition_elements%ELEMENTS(ne)
3181  domain_element=>domain_elements%ELEMENTS(ne)
3182  basis=>domain_element%BASIS
3183  !Loop over local faces of element
3184  DO basis_local_face_idx=1,basis%NUMBER_OF_LOCAL_FACES
3185  face_number=decomposition_element%ELEMENT_FACES(basis_local_face_idx)
3186  decomposition_face=>decomposition_faces%FACES(face_number)
3187  domain_face=>domain_faces%FACES(face_number)
3188  decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS=decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS+1
3189  IF(.NOT.ASSOCIATED(domain_face%BASIS)) THEN
3190  decomposition_face%NUMBER=face_number
3191  domain_face%NUMBER=face_number
3192  domain_face%ELEMENT_NUMBER=ne !! Needs checking
3193 ! DECOMPOSITION_FACE%ELEMENT_NUMBER=DECOMPOSITION_ELEMENT%NUMBER
3194 ! DOMAIN_FACE%ELEMENT_NUMBER=DOMAIN_ELEMENT%NUMBER
3195  decomposition_face%XI_DIRECTION=basis%LOCAL_FACE_XI_DIRECTION(basis_local_face_idx)
3196  domain_face%BASIS=>basis%FACE_BASES(abs(decomposition_face%XI_DIRECTION))%PTR
3197  ALLOCATE(domain_face%NODES_IN_FACE(basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)), &
3198  & stat=err)
3199  IF(err/=0) CALL flagerror("Could not allocate face nodes in face",err,error,*999)
3200  ALLOCATE(domain_face%DERIVATIVES_IN_FACE(2,domain_face%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES, &
3201  & basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)),stat=err)
3202  IF(err/=0) CALL flagerror("Could not allocate face derivatives in face",err,error,*999)
3203  domain_face%DERIVATIVES_IN_FACE=0
3204  !Set nodes in face based upon face number
3205  domain_face%NODES_IN_FACE(1:basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx))= &
3206  & temp_faces(1:basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx),face_number)
3207  !Set derivatives of nodes in domain face from derivatives of nodes in element
3208  DO basis_local_face_node_idx=1,basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)
3209  element_local_node_idx=basis%NODE_NUMBERS_IN_LOCAL_FACE(basis_local_face_node_idx, &
3210  & basis_local_face_idx)
3211  !Set derivative number of u (NO_GLOBAL_DERIV) for the domain face
3212  domain_face%DERIVATIVES_IN_FACE(1,1,basis_local_face_node_idx)=no_global_deriv
3213  !Set version number of u (NO_GLOBAL_DERIV) for the domain face
3214  version_idx=domain_element%elementVersions(1,basis%NODE_NUMBERS_IN_LOCAL_FACE( &
3215  & basis_local_face_node_idx,basis_local_face_idx))
3216  domain_face%DERIVATIVES_IN_FACE(2,1,basis_local_face_node_idx)=version_idx
3217  IF(domain_face%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES>1) THEN
3218  DO basis_local_face_derivative_idx=2,domain_face%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES
3219  derivative_idx=domain_element%ELEMENT_DERIVATIVES(basis%DERIVATIVE_NUMBERS_IN_LOCAL_FACE( &
3220  & basis_local_face_derivative_idx,basis_local_face_node_idx,basis_local_face_idx), &
3221  & element_local_node_idx)
3222  domain_face%DERIVATIVES_IN_FACE(1,basis_local_face_derivative_idx, &
3223  & basis_local_face_node_idx)=derivative_idx
3224  version_idx=domain_element%elementVersions(basis%DERIVATIVE_NUMBERS_IN_LOCAL_FACE( &
3225  & basis_local_face_derivative_idx,basis_local_face_node_idx,basis_local_face_idx), &
3226  & element_local_node_idx)
3227  domain_face%DERIVATIVES_IN_FACE(2,basis_local_face_derivative_idx, &
3228  & basis_local_face_node_idx)=version_idx
3229  ENDDO !basis_local_face_derivative_idx
3230  ENDIF
3231  ENDDO !basis_local_face_node_idx
3232  ENDIF
3233  ENDDO !basis_local_face_idx
3234  ENDDO !ne
3235 
3236  DEALLOCATE(temp_faces)
3237  !\todo Note: Adjacency will be left out of faces calculation for the time being
3238  !Calculate adjacent faces and the surrounding elements for each face
3239  DO face_idx=1,decomposition_faces%NUMBER_OF_FACES
3240  decomposition_face=>decomposition_faces%FACES(face_idx)
3241  domain_face=>domain_faces%FACES(face_idx)
3242  basis=>domain_face%BASIS
3243  IF(decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS==1) THEN
3244  decomposition_face%BOUNDARY_FACE=.true.
3245  domain_face%BOUNDARY_FACE=.true.
3246  ENDIF
3247  !Allocate the elements surrounding the face
3248  ALLOCATE(decomposition_face%SURROUNDING_ELEMENTS(decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS), &
3249  & stat=err)
3250  IF(err/=0) CALL flagerror("Could not allocate face surrounding elements",err,error,*999)
3251 
3252  ALLOCATE(decomposition_face%ELEMENT_FACES(decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS), &
3253  & stat=err)
3254  IF(err/=0) CALL flagerror("Could not allocate face element faces",err,error,*999)
3255 ! DECOMPOSITION_FACE%NUMBER_OF_SURROUNDING_ELEMENTS=0
3256 ! DECOMPOSITION_FACE%ADJACENT_FACES=0
3257 
3258  !Loop over the nodes at each end of the face
3259 ! DO node_idx1=0,1
3260 ! DO node_idx2=0,1
3261 ! FOUND=.FALSE.
3262 ! node_idx=DOMAIN_FACE%NODES_IN_FACE((node_idx2*BASIS%NUMBER_OF_NODES_IN_XI_DIRECTION*(BASIS%NUMBER_OF_FACES-1))&
3263 ! &+(node_idx1*(BASIS%NUMBER_OF_NODES_IN_XI_DIRECTION-1))+1)
3264  !Loop over the elements surrounding the node.
3265 ! DO elem_idx=1,DOMAIN_NODES%NODES(node_idx)%NUMBER_OF_SURROUNDING_ELEMENTS
3266 ! ne=DOMAIN_NODES%NODES(node_idx)%SURROUNDING_ELEMENTS(elem_idx)
3267 ! DECOMPOSITION_ELEMENT=>DECOMPOSITION_ELEMENTS%ELEMENTS(ne)
3268 ! DOMAIN_ELEMENT=>DOMAIN_ELEMENTS%ELEMENTS(ne)
3269  !Loop over the local faces of the element
3270 ! DO basis_local_face_idx=1,DOMAIN_ELEMENT%BASIS%NUMBER_OF_LOCAL_FACES
3271 ! nf2=DECOMPOSITION_ELEMENT%ELEMENT_FACES(basis_local_face_idx)
3272 ! IF(nf2/=face_idx) THEN
3273 ! DECOMPOSITION_FACE2=>DECOMPOSITION_FACES%FACES(nf2)
3274 ! DOMAIN_FACE2=>DOMAIN_FACES%FACES(nf2)
3275  !Check whether XI of face have same direction
3276 ! IF ((OTHER_XI_DIRECTIONS3(BASIS%LOCAL_FACE_XI_DIRECTION(basis_local_face_idx),2,1)==&
3277 ! &OTHER_XI_DIRECTIONS3(BASIS2%LOCAL_FACE_XI_DIRECTION(basis_local_face_idx),2,1)).OR.&
3278 ! &(OTHER_XI_DIRECTIONS3(BASIS%LOCAL_FACE_XI_DIRECTION(basis_local_face_idx),3,1)==&
3279 ! &OTHER_XI_DIRECTIONS3(BASIS2%LOCAL_FACE_XI_DIRECTION(basis_local_face_idx),3,1))) THEN
3280  !Loop over nodes in face of surrounding element
3281 ! BASIS2=>DOMAIN_FACE2%BASIS
3282 ! IF(BASIS2%INTERPOLATION_ORDER(1)==BASIS%INTERPOLATION_ORDER(1)) THEN
3283 ! NODE_COUNT=0
3284 ! DO node_idx3=1,BASIS%NUMBER_OF_NODES_IN_XI_DIRECTION
3285 ! DO node_idx4=1,BASIS%NUMBER_OF_NODES_IN_XI_DIRECTION
3286 ! np2=DOMAIN_FACE2%NODES_IN_FACE((node_idx4*(BASIS2%NUMBER_OF_FACES-1))&
3287 ! &+(node_idx3*(BASIS2%NUMBER_OF_NODES_IN_XI_DIRECTION-1))+1)
3288 ! IF(np2==node_idx) NODE_COUNT=NODE_COUNT+1
3289 ! ENDDO !node_idx4
3290 ! ENDDO !node_idx3
3291 ! IF(NODE_COUNT<BASIS%NUMBER_OF_NODES) THEN
3292 ! FOUND=.TRUE.
3293 ! EXIT
3294 ! ENDIF
3295 ! ENDIF
3296 ! ENDIF
3297 ! ENDIF
3298 ! ENDDO !basis_local_face_idx
3299 ! IF(FOUND) EXIT
3300 ! ENDDO !elem_idx
3301 ! IF(FOUND) DECOMPOSITION_FACE%ADJACENT_FACES(node_idx2)=nf2
3302 ! ENDDO !node_idx2
3303 ! IF(FOUND) DECOMPOSITION_FACE%ADJACENT_FACES(node_idx1)=nf2
3304 ! ENDDO !node_idx1
3305  ENDDO !face_idx
3306 
3307  !Set the surrounding elements
3308  DO ne=1,decomposition_elements%TOTAL_NUMBER_OF_ELEMENTS
3309  decomposition_element=>decomposition_elements%ELEMENTS(ne)
3310  domain_element=>domain_elements%ELEMENTS(ne)
3311  basis=>domain_element%BASIS
3312  DO basis_local_face_idx=1,basis%NUMBER_OF_LOCAL_FACES
3313  face_number=decomposition_element%ELEMENT_FACES(basis_local_face_idx)
3314  decomposition_face=>decomposition_faces%FACES(face_number)
3315  DO face_idx=1,decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS
3316  decomposition_face%SURROUNDING_ELEMENTS(face_idx)=ne
3317  decomposition_face%ELEMENT_FACES(face_idx)=basis_local_face_idx
3318  ENDDO
3319  ENDDO !basis_local_face_idx
3320  ENDDO !ne
3321  ELSE
3322  CALL flagerror("Domain topology faces is not associated",err,error,*999)
3323  ENDIF
3324  CASE DEFAULT
3325  CALL flagerror("Invalid number of dimensions for a topology domain",err,error,*999)
3326  END SELECT
3327  ELSE
3328  CALL flagerror("Domain topology elements is not associated",err,error,*999)
3329  ENDIF
3330  ELSE
3331  CALL flagerror("Domain topology nodes is not associated",err,error,*999)
3332  ENDIF
3333  ELSE
3334  CALL flagerror("Topology decomposition domain topology is not associated",err,error,*999)
3335  ENDIF
3336  ELSE
3337  CALL flagerror("Topology decomposition domain is not associated",err,error,*999)
3338  ENDIF
3339  !Now loop over the other mesh components in the decomposition and calculate the domain faces
3340  mesh=>decomposition%MESH
3341  IF(ASSOCIATED(mesh)) THEN
3342  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
3343  IF(component_idx/=decomposition%MESH_COMPONENT_NUMBER) THEN
3344  domain=>decomposition%DOMAIN(component_idx)%PTR
3345  IF(ASSOCIATED(domain)) THEN
3346  domain_topology=>domain%TOPOLOGY
3347  IF(ASSOCIATED(domain_topology)) THEN
3348  domain_nodes=>domain_topology%NODES
3349  IF(ASSOCIATED(domain_nodes)) THEN
3350  domain_elements=>domain_topology%ELEMENTS
3351  IF(ASSOCIATED(domain_elements)) THEN
3352  domain_faces=>domain_topology%FACES
3353  IF(ASSOCIATED(domain_faces)) THEN
3354  ALLOCATE(domain_faces%FACES(decomposition_faces%NUMBER_OF_FACES),stat=err)
3355  IF(err/=0) CALL flagerror("Could not allocate domain faces faces",err,error,*999)
3356  domain_faces%NUMBER_OF_FACES=decomposition_faces%NUMBER_OF_FACES
3357  ALLOCATE(nodes_number_of_faces(domain_nodes%TOTAL_NUMBER_OF_NODES),stat=err)
3358  IF(err/=0) CALL flagerror("Could not allocate nodes number of faces array",err,error,*999)
3359  nodes_number_of_faces=0
3360  !Loop over the faces in the topology
3361  DO face_idx=1,decomposition_faces%NUMBER_OF_FACES
3362  decomposition_face=>decomposition_faces%FACES(face_idx)
3363  domain_face=>domain_faces%FACES(face_idx)
3364  IF(decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS>0) THEN
3365  ne=decomposition_face%SURROUNDING_ELEMENTS(1)
3366  basis_local_face_idx=decomposition_face%ELEMENT_FACES(1)
3367  CALL domain_topology_face_initialise(domain_faces%FACES(face_idx),err,error,*999)
3368  domain_face%NUMBER=face_idx
3369  domain_element=>domain_elements%ELEMENTS(ne)
3370  basis=>domain_element%BASIS
3371  domain_face%BASIS=>basis%FACE_BASES(abs(decomposition_face%XI_DIRECTION))%PTR
3372  ALLOCATE(domain_face%NODES_IN_FACE(basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)), &
3373  & stat=err)
3374  IF(err/=0) CALL flagerror("Could not allocate nodes in face",err,error,*999)
3375  ALLOCATE(domain_face%DERIVATIVES_IN_FACE(2,domain_face%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES, &
3376  & basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)),stat=err)
3377  IF(err/=0) CALL flagerror("Could not allocate derivatives in face",err,error,*999)
3378  !Set derivatives of nodes in domain face from derivatives of nodes in element
3379  DO basis_local_face_node_idx=1,basis%NUMBER_OF_NODES_IN_LOCAL_FACE(basis_local_face_idx)
3380  element_local_node_idx=basis%NODE_NUMBERS_IN_LOCAL_FACE(basis_local_face_node_idx, &
3381  & basis_local_face_idx)
3382  node_idx=domain_element%ELEMENT_NODES(element_local_node_idx)
3383  domain_face%NODES_IN_FACE(basis_local_face_node_idx)=node_idx
3384  !Set derivative number of u (NO_GLOBAL_DERIV) for the domain face
3385  domain_face%DERIVATIVES_IN_FACE(1,1,basis_local_face_node_idx)=no_global_deriv
3386  !Set version number of u (NO_GLOBAL_DERIV) for the domain face
3387  version_idx=domain_element%elementVersions(1,basis%NODE_NUMBERS_IN_LOCAL_FACE( &
3388  & basis_local_face_node_idx,basis_local_face_idx))
3389  domain_face%DERIVATIVES_IN_FACE(2,1,basis_local_face_node_idx)=version_idx
3390  IF(domain_face%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES>1) THEN
3391  DO basis_local_face_derivative_idx=2,domain_face%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES
3392  derivative_idx=domain_element%ELEMENT_DERIVATIVES(basis%DERIVATIVE_NUMBERS_IN_LOCAL_FACE( &
3393  & basis_local_face_derivative_idx,basis_local_face_node_idx,basis_local_face_idx), &
3394  & element_local_node_idx)
3395  domain_face%DERIVATIVES_IN_FACE(1,basis_local_face_derivative_idx, &
3396  & basis_local_face_node_idx)=derivative_idx
3397  version_idx=domain_element%elementVersions(basis%DERIVATIVE_NUMBERS_IN_LOCAL_FACE( &
3398  & basis_local_face_derivative_idx,basis_local_face_node_idx,basis_local_face_idx), &
3399  & element_local_node_idx)
3400  domain_face%DERIVATIVES_IN_FACE(2,basis_local_face_derivative_idx, &
3401  & basis_local_face_node_idx)=version_idx
3402  ENDDO !basis_local_face_derivative_idx
3403  ENDIF
3404  nodes_number_of_faces(node_idx)=nodes_number_of_faces(node_idx)+1
3405  ENDDO !basis_local_face_node_idx
3406  ELSE
3407  CALL flagerror("Face is not surrounded by any elements?",err,error,*999)
3408  ENDIF
3409  ENDDO !face_idx
3410  DO node_idx=1,domain_nodes%TOTAL_NUMBER_OF_NODES
3411  ALLOCATE(domain_nodes%NODES(node_idx)%NODE_FACES(nodes_number_of_faces(node_idx)),stat=err)
3412  IF(err/=0) CALL flagerror("Could not allocate node faces",err,error,*999)
3413  domain_nodes%NODES(node_idx)%NUMBER_OF_NODE_FACES=0
3414  ENDDO !node_idx
3415  DEALLOCATE(nodes_number_of_faces)
3416  DO face_idx=1,domain_faces%NUMBER_OF_FACES
3417  domain_face=>domain_faces%FACES(face_idx)
3418  basis=>domain_face%BASIS
3419  DO basis_local_face_node_idx=1,basis%NUMBER_OF_NODES
3420  node_idx=domain_face%NODES_IN_FACE(basis_local_face_node_idx)
3421  domain_node=>domain_nodes%NODES(node_idx)
3422  domain_node%NUMBER_OF_NODE_FACES=domain_node%NUMBER_OF_NODE_FACES+1
3423  !Set the face numbers a node is on
3424  domain_node%NODE_FACES(domain_node%NUMBER_OF_NODE_FACES)=face_idx
3425  ENDDO !basis_local_face_node_idx
3426  ENDDO !face_idx
3427  ELSE
3428  CALL flagerror("Domain faces is not associated",err,error,*999)
3429  ENDIF
3430  ELSE
3431  CALL flagerror("Domain elements is not associated",err,error,*999)
3432  ENDIF
3433  ELSE
3434  CALL flagerror("Domain nodes is not associated",err,error,*999)
3435  ENDIF
3436  ELSE
3437  CALL flagerror("Domain topology is not associated",err,error,*999)
3438  ENDIF
3439  ELSE
3440  CALL flagerror("Decomposition mesh is not associated",err,error,*999)
3441  ENDIF
3442  ENDIF
3443  ENDDO !component_idx
3444  ELSE
3445  CALL flagerror("Decomposition mesh is not associated",err,error,*999)
3446  ENDIF
3447  ELSE
3448  CALL flagerror("Topology decomposition is not associated",err,error,*999)
3449  ENDIF
3450  ELSE
3451  CALL flagerror("Topology decomposition elements is not associated",err,error,*999)
3452  ENDIF
3453  ELSE
3454  CALL flagerror("Topology faces is not associated",err,error,*999)
3455  ENDIF
3456  ELSE
3457  CALL flagerror("Topology is not associated",err,error,*999)
3458  ENDIF
3459 
3460  IF(diagnostics1) THEN
3461  CALL write_string(diagnostic_output_type,"Decomposition topology faces:",err,error,*999)
3462  CALL write_string_value(diagnostic_output_type," Number of mesh components = ",mesh%NUMBER_OF_COMPONENTS,err,error,*999)
3463  CALL write_string_value(diagnostic_output_type," Number of faces = ",decomposition_faces%NUMBER_OF_FACES,err,error,*999)
3464  DO face_idx=1,decomposition_faces%NUMBER_OF_FACES
3465  decomposition_face=>decomposition_faces%FACES(face_idx)
3466  domain_face=>domain_faces%FACES(face_idx)
3467  CALL write_string_value(diagnostic_output_type," Face number = ",decomposition_face%NUMBER,err,error,*999)
3468  CALL write_string_value(diagnostic_output_type," Xi direction (Normal to Face) = &
3469  &",decomposition_face%XI_DIRECTION,err,error,*999)
3470  CALL write_string_value(diagnostic_output_type," Number of surrounding elements = ", &
3471  & decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS,err,error,*999)
3472  CALL write_string_vector(diagnostic_output_type,1,1,decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS,4,4, &
3473  & decomposition_face%SURROUNDING_ELEMENTS,'(" Surrounding elements :",4(X,I8))','(28X,4(X,I8))',err,error,*999)
3474  CALL write_string_vector(diagnostic_output_type,1,1,decomposition_face%NUMBER_OF_SURROUNDING_ELEMENTS,4,4, &
3475  & decomposition_face%ELEMENT_FACES,'(" Element faces :",4(X,I8))','(28X,4(X,I8))',err,error,*999)
3476 ! CALL WRITE_STRING_VECTOR(DIAGNOSTIC_OUTPUT_TYPE,1,1,2,2,2,DECOMPOSITION_FACE%ADJACENT_FACES, &
3477 ! & '(" Adjacent faces :",2(X,I8))','(28X,2(X,I8))',ERR,ERROR,*999)
3478  CALL write_string_value(diagnostic_output_type," Boundary face = ",decomposition_face%BOUNDARY_FACE,err,error,*999)
3479  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
3480  CALL write_string_value(diagnostic_output_type," Mesh component : ",component_idx,err,error,*999)
3481  domain=>decomposition%DOMAIN(component_idx)%PTR
3482  domain_face=>domain%TOPOLOGY%FACES%FACES(face_idx)
3483  CALL write_string_value(diagnostic_output_type," Basis user number = ",domain_face%BASIS%USER_NUMBER, &
3484  & err,error,*999)
3485  CALL write_string_value(diagnostic_output_type," Basis family number = ",domain_face%BASIS%FAMILY_NUMBER, &
3486  & err,error,*999)
3487  CALL write_string_value(diagnostic_output_type," Basis interpolation type = ",domain_face%BASIS% &
3488  & interpolation_type(1),err,error,*999)
3489  CALL write_string_value(diagnostic_output_type," Basis interpolation order = ",domain_face%BASIS% &
3490  & interpolation_order(1),err,error,*999)
3491  CALL write_string_value(diagnostic_output_type," Number of nodes in faces = ",domain_face%BASIS%NUMBER_OF_NODES, &
3492  & err,error,*999)
3493  CALL write_string_vector(diagnostic_output_type,1,1,domain_face%BASIS%NUMBER_OF_NODES,4,4,domain_face%NODES_IN_FACE, &
3494  & '(" Nodes in face :",4(X,I8))','(30X,4(X,I8))',err,error,*999)
3495  DO basis_local_face_node_idx=1,domain_face%BASIS%NUMBER_OF_NODES
3496  CALL write_string_value(diagnostic_output_type," Node : ",basis_local_face_node_idx,err,error,*999)
3497  !/TODO::Loop over local_derivative index so this output makes more sense !<DERIVATIVES_IN_LINE(i,local_derivative_idx,local_node_idx)
3498  CALL write_string_vector(diagnostic_output_type,1,1, &
3499  & domain_face%BASIS%NUMBER_OF_DERIVATIVES(basis_local_face_node_idx),4,4,domain_face% &
3500  & derivatives_in_face(1,:,basis_local_face_node_idx),'(" Derivatives in face :",4(X,I8))', &
3501  & '(34X,4(X,I8))',err,error,*999)
3502  CALL write_string_vector(diagnostic_output_type,1,1, &
3503  & domain_face%BASIS%NUMBER_OF_DERIVATIVES(basis_local_face_node_idx),4,4,domain_face% &
3504  & derivatives_in_face(2,:,basis_local_face_node_idx),'(" Derivatives Versions in face :",4(X,I8))', &
3505  & '(34X,4(X,I8))',err,error,*999)
3506  ENDDO !basis_local_face_node_idx
3507  ENDDO !component_idx
3508  ENDDO !face_idx
3509  ENDIF
3510 
3511  exits("DECOMPOSITION_TOPOLOGY_FACES_CALCULATE")
3512  RETURN
3513 999 IF(ASSOCIATED(temp_faces)) DEALLOCATE(temp_faces)
3514  IF(ASSOCIATED(new_temp_faces)) DEALLOCATE(new_temp_faces)
3515  IF(ALLOCATED(nodes_number_of_faces)) DEALLOCATE(nodes_number_of_faces)
3516  errorsexits("DECOMPOSITION_TOPOLOGY_FACES_CALCULATE",err,error)
3517  RETURN 1
3518  END SUBROUTINE decomposition_topology_faces_calculate
3519 
3520  !
3521  !================================================================================================================================
3522  !
3523 
3525  SUBROUTINE decomposition_topology_faces_finalise(TOPOLOGY,ERR,ERROR,*)
3526 
3527  !Argument variables
3528  TYPE(decomposition_topology_type), POINTER :: topology
3529  INTEGER(INTG), INTENT(OUT) :: err
3530  TYPE(varying_string), INTENT(OUT) :: error
3531  !Local Variables
3532  INTEGER(INTG) :: nf
3533 
3534  enters("DECOMPOSITION_TOPOLOGY_FACES_FINALISE",err,error,*999)
3535 
3536  IF(ASSOCIATED(topology)) THEN
3537  IF(ASSOCIATED(topology%FACES)) THEN
3538  DO nf=1,topology%FACES%NUMBER_OF_FACES
3539  CALL decomposition_topology_face_finalise(topology%FACES%FACES(nf),err,error,*999)
3540  ENDDO !nf
3541  IF(ALLOCATED(topology%FACES%FACES)) DEALLOCATE(topology%FACES%FACES)
3542  DEALLOCATE(topology%FACES)
3543  ENDIF
3544  ELSE
3545  CALL flagerror("Topology is not associated",err,error,*999)
3546  ENDIF
3547 
3548  exits("DECOMPOSITION_TOPOLOGY_FACES_FINALISE")
3549  RETURN
3550 999 errorsexits("DECOMPOSITION_TOPOLOGY_FACES_FINALISE",err,error)
3551  RETURN 1
3552  END SUBROUTINE decomposition_topology_faces_finalise
3553 
3554  !
3555  !================================================================================================================================
3556  !
3557 
3559  SUBROUTINE decomposition_topology_faces_initialise(TOPOLOGY,ERR,ERROR,*)
3560 
3561  !Argument variables
3562  TYPE(decomposition_topology_type), POINTER :: topology
3563  INTEGER(INTG), INTENT(OUT) :: err
3564  TYPE(varying_string), INTENT(OUT) :: error
3565  !Local Variables
3566 
3567  enters("DECOMPOSITION_TOPOLOGY_FACES_INITIALISE",err,error,*999)
3568 
3569  IF(ASSOCIATED(topology)) THEN
3570  IF(ASSOCIATED(topology%FACES)) THEN
3571  CALL flagerror("Decomposition already has topology faces associated",err,error,*999)
3572  ELSE
3573  ALLOCATE(topology%FACES,stat=err)
3574  IF(err/=0) CALL flagerror("Could not allocate topology faces",err,error,*999)
3575  topology%FACES%NUMBER_OF_FACES=0
3576  topology%FACES%DECOMPOSITION=>topology%DECOMPOSITION
3577  ENDIF
3578  ELSE
3579  CALL flagerror("Topology is not associated",err,error,*999)
3580  ENDIF
3581 
3582  exits("DECOMPOSITION_TOPOLOGY_FACES_INITIALISE")
3583  RETURN
3584 999 errorsexits("DECOMPOSITION_TOPOLOGY_FACES_INITIALISE",err,error)
3585  RETURN 1
3586  END SUBROUTINE decomposition_topology_faces_initialise
3587 
3588  !
3589  !================================================================================================================================
3590  !
3591 
3593  SUBROUTINE decomposition_type_get(DECOMPOSITION,TYPE,ERR,ERROR,*)
3594 
3595  !Argument variables
3596  TYPE(decomposition_type), POINTER :: decomposition
3597  INTEGER(INTG), INTENT(OUT) :: TYPE
3598  INTEGER(INTG), INTENT(OUT) :: err
3599  TYPE(varying_string), INTENT(OUT) :: error
3600  !Local Variables
3601 
3602  enters("DECOMPOSITION_TYPE_GET",err,error,*999)
3603 
3604  IF(ASSOCIATED(decomposition)) THEN
3605  IF(decomposition%DECOMPOSITION_FINISHED) THEN
3606  TYPE=decomposition%DECOMPOSITION_TYPE
3607  ELSE
3608  CALL flagerror("Decomposition has not finished.",err,error,*999)
3609  ENDIF
3610  ELSE
3611  CALL flagerror("Decomposition is not associated.",err,error,*999)
3612  ENDIF
3613 
3614  exits("DECOMPOSITION_TYPE_GET")
3615  RETURN
3616 999 errorsexits("DECOMPOSITION_TYPE_GET",err,error)
3617  RETURN
3618  END SUBROUTINE decomposition_type_get
3619 
3620  !
3621  !================================================================================================================================
3622  !
3623 
3625  SUBROUTINE decomposition_type_set(DECOMPOSITION,TYPE,ERR,ERROR,*)
3626 
3627  !Argument variables
3628  TYPE(decomposition_type), POINTER :: decomposition
3629  INTEGER(INTG), INTENT(IN) :: TYPE
3630  INTEGER(INTG), INTENT(OUT) :: err
3631  TYPE(varying_string), INTENT(OUT) :: error
3632  !Local Variables
3633  TYPE(varying_string) :: local_error
3634 
3635  enters("DECOMPOSITION_TYPE_SET",err,error,*999)
3636 
3637  IF(ASSOCIATED(decomposition)) THEN
3638  IF(decomposition%DECOMPOSITION_FINISHED) THEN
3639  CALL flagerror("Decomposition has been finished.",err,error,*999)
3640  ELSE
3641  SELECT CASE(type)
3642  CASE(decomposition_all_type)
3643  !heye: three types for decomposition--decompostion_all_type means no decomposition
3644  decomposition%DECOMPOSITION_TYPE=decomposition_all_type
3645  CASE(decomposition_calculated_type)
3646  decomposition%DECOMPOSITION_TYPE=decomposition_calculated_type
3647  CASE(decomposition_user_defined_type)
3648  decomposition%DECOMPOSITION_TYPE=decomposition_user_defined_type
3649  CASE DEFAULT
3650  local_error="Decomposition type "//trim(number_to_vstring(TYPE,"*",err,error))//" is not valid."
3651  CALL flagerror(local_error,err,error,*999)
3652  END SELECT
3653  ENDIF
3654  ELSE
3655  CALL flagerror("Decomposition is not associated.",err,error,*999)
3656  ENDIF
3657 
3658  exits("DECOMPOSITION_TYPE_SET")
3659  RETURN
3660 999 errorsexits("DECOMPOSITION_TYPE_SET",err,error)
3661  RETURN 1
3662  END SUBROUTINE decomposition_type_set
3663 
3664  !
3665  !================================================================================================================================
3666  !
3667 
3669  SUBROUTINE decomposition_calculate_lines_set(DECOMPOSITION,CALCULATE_LINES_FLAG,ERR,ERROR,*)
3670 
3671  !Argument variables
3672  TYPE(decomposition_type), POINTER :: decomposition
3673  LOGICAL, INTENT(IN) :: calculate_lines_flag
3674  INTEGER(INTG), INTENT(OUT) :: err
3675  TYPE(varying_string), INTENT(OUT) :: error
3676 
3677  enters("DECOMPOSITION_CALCULATE_LINES_SET",err,error,*999)
3678 
3679  IF(ASSOCIATED(decomposition)) THEN
3680  IF(decomposition%DECOMPOSITION_FINISHED) THEN
3681  CALL flagerror("Decomposition has been finished.",err,error,*999)
3682  ELSE
3683  decomposition%CALCULATE_LINES=calculate_lines_flag
3684  ENDIF
3685  ELSE
3686  CALL flagerror("Decomposition is not associated.",err,error,*999)
3687  ENDIF
3688 
3689  exits("DECOMPOSITION_CALCULATE_LINES_SET")
3690  RETURN
3691 999 errorsexits("DECOMPOSITION_CALCULATE_LINES_SET",err,error)
3692  RETURN 1
3693  END SUBROUTINE decomposition_calculate_lines_set
3694 
3695  !
3696  !================================================================================================================================
3697  !
3698 
3700  SUBROUTINE decomposition_calculate_faces_set(DECOMPOSITION,CALCULATE_FACES_FLAG,ERR,ERROR,*)
3701 
3702  !Argument variables
3703  TYPE(decomposition_type), POINTER :: decomposition
3704  LOGICAL, INTENT(IN) :: calculate_faces_flag
3705  INTEGER(INTG), INTENT(OUT) :: err
3706  TYPE(varying_string), INTENT(OUT) :: error
3707 
3708  enters("DECOMPOSITION_CALCULATE_FACES_SET",err,error,*999)
3709 
3710  IF(ASSOCIATED(decomposition)) THEN
3711  IF(decomposition%DECOMPOSITION_FINISHED) THEN
3712  CALL flagerror("Decomposition has been finished.",err,error,*999)
3713  ELSE
3714  decomposition%CALCULATE_FACES=calculate_faces_flag
3715  ENDIF
3716  ELSE
3717  CALL flagerror("Decomposition is not associated.",err,error,*999)
3718  ENDIF
3719 
3720  exits("DECOMPOSITION_CALCULATE_FACES_SET")
3721  RETURN
3722 999 errorsexits("DECOMPOSITION_CALCULATE_FACES_SET",err,error)
3723  RETURN 1
3724  END SUBROUTINE decomposition_calculate_faces_set
3725 
3726  !
3727  !================================================================================================================================
3728  !
3729 
3731  SUBROUTINE decomposition_user_number_find(USER_NUMBER,MESH,DECOMPOSITION,ERR,ERROR,*)
3732 
3733  !Argument variables
3734  INTEGER(INTG), INTENT(IN) :: user_number
3735  TYPE(mesh_type), POINTER :: mesh
3736  TYPE(decomposition_type), POINTER :: decomposition
3737  INTEGER(INTG), INTENT(OUT) :: err
3738  TYPE(varying_string), INTENT(OUT) :: error
3739  !Local Variables
3740  INTEGER(INTG) :: decomposition_idx
3741  TYPE(varying_string) :: local_error
3742 
3743  enters("DECOMPOSITION_USER_NUMBER_FIND",err,error,*999)
3744 
3745  NULLIFY(decomposition)
3746  IF(ASSOCIATED(mesh)) THEN
3747  IF(ASSOCIATED(mesh%DECOMPOSITIONS)) THEN
3748  decomposition_idx=1
3749  DO WHILE(decomposition_idx<=mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS.AND..NOT.ASSOCIATED(decomposition))
3750  IF(mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_idx)%PTR%USER_NUMBER==user_number) THEN
3751  decomposition=>mesh%DECOMPOSITIONS%DECOMPOSITIONS(decomposition_idx)%PTR
3752  ELSE
3753  decomposition_idx=decomposition_idx+1
3754  ENDIF
3755  ENDDO
3756  ELSE
3757  local_error="The decompositions on mesh number "//trim(number_to_vstring(mesh%USER_NUMBER,"*",err,error))// &
3758  & " are not associated."
3759  CALL flagerror(local_error,err,error,*999)
3760  ENDIF
3761  ELSE
3762  CALL flagerror("Mesh is not associated.",err,error,*999)
3763  ENDIF
3764 
3765  exits("DECOMPOSITION_USER_NUMBER_FIND")
3766  RETURN
3767 999 errorsexits("DECOMPOSITION_USER_NUMBER_FIND",err,error)
3768  RETURN 1
3769  END SUBROUTINE decomposition_user_number_find
3770 
3771  !
3772  !================================================================================================================================
3773  !
3774 
3776  SUBROUTINE decompositions_finalise(MESH,ERR,ERROR,*)
3777 
3778  !Argument variables
3779  TYPE(mesh_type), POINTER :: mesh
3780  INTEGER(INTG), INTENT(OUT) :: err
3781  TYPE(varying_string), INTENT(OUT) :: error
3782  !Local Variables
3783 
3784  enters("DECOMPOSITIONS_FINALISE",err,error,*999)
3785 
3786  IF(ASSOCIATED(mesh)) THEN
3787  IF(ASSOCIATED(mesh%DECOMPOSITIONS)) THEN
3788  DO WHILE(mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS>0)
3789  CALL decomposition_destroy(mesh%DECOMPOSITIONS%DECOMPOSITIONS(1)%PTR,err,error,*999)
3790  ENDDO !no_decomposition
3791  DEALLOCATE(mesh%DECOMPOSITIONS)
3792  ENDIF
3793  ELSE
3794  CALL flagerror("Mesh is not associated.",err,error,*999)
3795  ENDIF
3796 
3797  exits("DECOMPOSITIONS_FINALISE")
3798  RETURN
3799 999 errorsexits("DECOMPOSITIONS_FINALISE",err,error)
3800  RETURN 1
3801  END SUBROUTINE decompositions_finalise
3802 
3803  !
3804  !================================================================================================================================
3805  !
3806 
3808  SUBROUTINE decompositions_initialise(MESH,ERR,ERROR,*)
3809 
3810  !Argument variables
3811  TYPE(mesh_type), POINTER :: mesh
3812 
3813  INTEGER(INTG), INTENT(OUT) :: err
3814  TYPE(varying_string), INTENT(OUT) :: error
3815  !Local Variables
3816 
3817  enters("DECOMPOSITIONS_INITIALISE",err,error,*999)
3818 
3819  IF(ASSOCIATED(mesh)) THEN
3820  IF(ASSOCIATED(mesh%DECOMPOSITIONS)) THEN
3821  CALL flagerror("Mesh already has decompositions associated.",err,error,*999)
3822  ELSE
3823  ALLOCATE(mesh%DECOMPOSITIONS,stat=err)
3824  IF(err/=0) CALL flagerror("Mesh decompositions could not be allocated.",err,error,*999)
3825  mesh%DECOMPOSITIONS%NUMBER_OF_DECOMPOSITIONS=0
3826  NULLIFY(mesh%DECOMPOSITIONS%DECOMPOSITIONS)
3827  mesh%DECOMPOSITIONS%MESH=>mesh
3828  ENDIF
3829  ELSE
3830  CALL flagerror("Mesh is not associated.",err,error,*999)
3831  ENDIF
3832 
3833  exits("DECOMPOSITIONS_INITIALISE")
3834  RETURN
3835 999 errorsexits("DECOMPOSITIONS_INITIALISE",err,error)
3836  RETURN 1
3837  END SUBROUTINE decompositions_initialise
3838 
3839  !
3840  !================================================================================================================================
3841  !
3842 
3844  SUBROUTINE domain_finalise(DECOMPOSITION,ERR,ERROR,*)
3845 
3846  !Argument variables
3847  TYPE(decomposition_type), POINTER :: decomposition
3848  INTEGER(INTG), INTENT(OUT) :: err
3849  TYPE(varying_string), INTENT(OUT) :: error
3850  !Local Variables
3851  INTEGER(INTG) :: component_idx
3852 
3853  enters("DOMAIN_FINALISE",err,error,*999)
3854 
3855  IF(ASSOCIATED(decomposition)) THEN
3856  IF(ASSOCIATED(decomposition%MESH)) THEN
3857  IF(ASSOCIATED(decomposition%DOMAIN)) THEN
3858  DO component_idx=1,decomposition%MESH%NUMBER_OF_COMPONENTS
3859  IF(ALLOCATED(decomposition%DOMAIN(component_idx)%PTR%NODE_DOMAIN)) &
3860  & DEALLOCATE(decomposition%DOMAIN(component_idx)%PTR%NODE_DOMAIN)
3861  CALL domain_mappings_finalise(decomposition%DOMAIN(component_idx)%PTR,err,error,*999)
3862  CALL domain_topology_finalise(decomposition%DOMAIN(component_idx)%PTR,err,error,*999)
3863  DEALLOCATE(decomposition%DOMAIN(component_idx)%PTR)
3864  ENDDO !component_idx
3865  DEALLOCATE(decomposition%DOMAIN)
3866  ENDIF
3867  ENDIF
3868  ELSE
3869  CALL flagerror("Decomposition is not associated.",err,error,*999)
3870  ENDIF
3871 
3872  exits("DOMAIN_FINALISE")
3873  RETURN
3874 999 errorsexits("DOMAIN_FINALISE",err,error)
3875  RETURN 1
3876  END SUBROUTINE domain_finalise
3877 
3878  !
3879  !================================================================================================================================
3880  !
3881 
3883  SUBROUTINE domain_initialise(DECOMPOSITION,ERR,ERROR,*)
3884 
3885  !Argument variables
3886  TYPE(decomposition_type), POINTER :: decomposition
3887  INTEGER(INTG), INTENT(OUT) :: err
3888  TYPE(varying_string), INTENT(OUT) :: error
3889  !Local Variables
3890  INTEGER(INTG) :: component_idx
3891 
3892  enters("DOMAIN_INITIALISE",err,error,*999)
3893 
3894  IF(ASSOCIATED(decomposition)) THEN
3895  IF(ASSOCIATED(decomposition%MESH)) THEN
3896  IF(ASSOCIATED(decomposition%DOMAIN)) THEN
3897  CALL flagerror("Decomposition already has a domain associated.",err,error,*999)
3898  ELSE
3899  ALLOCATE(decomposition%DOMAIN(decomposition%MESH%NUMBER_OF_COMPONENTS),stat=err)
3900  IF(err/=0) CALL flagerror("Decomposition domain could not be allocated.",err,error,*999)
3901  DO component_idx=1,decomposition%MESH%NUMBER_OF_COMPONENTS !Mesh component
3902  ALLOCATE(decomposition%DOMAIN(component_idx)%PTR,stat=err)
3903  IF(err/=0) CALL flagerror("Decomposition domain component could not be allocated.",err,error,*999)
3904  decomposition%DOMAIN(component_idx)%PTR%DECOMPOSITION=>decomposition
3905  decomposition%DOMAIN(component_idx)%PTR%MESH=>decomposition%MESH
3906  decomposition%DOMAIN(component_idx)%PTR%MESH_COMPONENT_NUMBER=component_idx
3907  decomposition%DOMAIN(component_idx)%PTR%REGION=>decomposition%MESH%REGION
3908  decomposition%DOMAIN(component_idx)%PTR%NUMBER_OF_DIMENSIONS=decomposition%MESH%NUMBER_OF_DIMENSIONS
3909  !DECOMPOSITION%DOMAIN(component_idx)%PTR%NUMBER_OF_ELEMENTS=0
3910  !DECOMPOSITION%DOMAIN(component_idx)%PTR%NUMBER_OF_FACES=0
3911  !DECOMPOSITION%DOMAIN(component_idx)%PTR%NUMBER_OF_LINES=0
3912  !DECOMPOSITION%DOMAIN(component_idx)%PTR%NUMBER_OF_NODES=0
3913  !DECOMPOSITION%DOMAIN(component_idx)%PTR%NUMBER_OF_MESH_DOFS=0
3914  NULLIFY(decomposition%DOMAIN(component_idx)%PTR%MAPPINGS)
3915  NULLIFY(decomposition%DOMAIN(component_idx)%PTR%TOPOLOGY)
3916  CALL domain_mappings_initialise(decomposition%DOMAIN(component_idx)%PTR,err,error,*999)
3917  CALL domain_topology_initialise(decomposition%DOMAIN(component_idx)%PTR,err,error,*999)
3918  ENDDO !component_idx
3919  ENDIF
3920  ELSE
3921  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
3922  ENDIF
3923  ELSE
3924  CALL flagerror("Decomposition is not associated.",err,error,*999)
3925  ENDIF
3926 
3927  exits("DOMAIN_INITIALISE")
3928  RETURN
3929 999 errorsexits("DOMAIN_INITIALISE",err,error)
3930  RETURN 1
3931  END SUBROUTINE domain_initialise
3932 
3933 
3934  !
3935  !================================================================================================================================
3936  !
3937 
3939  SUBROUTINE domain_mappings_dofs_finalise(DOMAIN_MAPPINGS,ERR,ERROR,*)
3940 
3941  !Argument variables
3942  TYPE(domain_mappings_type), POINTER :: domain_mappings
3943  INTEGER(INTG), INTENT(OUT) :: err
3944  TYPE(varying_string), INTENT(OUT) :: error
3945  !Local Variables
3946 
3947  enters("DOMAIN_MAPPINGS_DOFS_FINALISE",err,error,*999)
3948 
3949  IF(ASSOCIATED(domain_mappings)) THEN
3950  IF(ASSOCIATED(domain_mappings%DOFS)) THEN
3951  CALL domain_mappings_mapping_finalise(domain_mappings%DOFS,err,error,*999)
3952  ENDIF
3953  ELSE
3954  CALL flagerror("Domain mapping is not associated.",err,error,*999)
3955  ENDIF
3956 
3957  exits("DOMAIN_MAPPINGS_DOFS_FINALISE")
3958  RETURN
3959 999 errorsexits("DOMAIN_MAPPINGS_DOFS_FINALISE",err,error)
3960  RETURN 1
3961 
3962  END SUBROUTINE domain_mappings_dofs_finalise
3963 
3964  !
3965  !================================================================================================================================
3966  !
3967 
3969  SUBROUTINE domain_mappings_dofs_initialise(DOMAIN_MAPPINGS,ERR,ERROR,*)
3970 
3971  !Argument variables
3972  TYPE(domain_mappings_type), POINTER :: domain_mappings
3973  INTEGER(INTG), INTENT(OUT) :: err
3974  TYPE(varying_string), INTENT(OUT) :: error
3975  !Local Variables
3976 
3977  enters("DOMAIN_MAPPINGS_DOFS_INITIALISE",err,error,*999)
3978 
3979  IF(ASSOCIATED(domain_mappings)) THEN
3980  IF(ASSOCIATED(domain_mappings%DOFS)) THEN
3981  CALL flagerror("Domain dofs mappings are already associated.",err,error,*999)
3982  ELSE
3983  ALLOCATE(domain_mappings%DOFS,stat=err)
3984  IF(err/=0) CALL flagerror("Could not allocate domain mappings dofs.",err,error,*999)
3985  CALL domain_mappings_mapping_initialise(domain_mappings%DOFS,domain_mappings%DOMAIN%DECOMPOSITION%NUMBER_OF_DOMAINS, &
3986  & err,error,*999)
3987  ENDIF
3988  ELSE
3989  CALL flagerror("Domain mapping is not associated.",err,error,*999)
3990  ENDIF
3991 
3992  exits("DOMAIN_MAPPINGS_DOFS_INITIALISE")
3993  RETURN
3994 999 errorsexits("DOMAIN_MAPPINGS_DOFS_INITIALISE",err,error)
3995  RETURN 1
3996 
3997  END SUBROUTINE domain_mappings_dofs_initialise
3998 
3999  !
4000  !================================================================================================================================
4001  !
4002 
4004  SUBROUTINE domain_mappings_elements_calculate(DOMAIN,ERR,ERROR,*)
4005 
4006  !Argument variables
4007  TYPE(domain_type), POINTER :: domain
4008  INTEGER(INTG), INTENT(OUT) :: err
4009  TYPE(varying_string), INTENT(OUT) :: error
4010  !Local Variables
4011  INTEGER(INTG) :: dummy_err,no_adjacent_element,adjacent_element,domain_no,domain_idx,ne,nn,np,number_of_domains, &
4012  & NUMBER_OF_ADJACENT_ELEMENTS,my_computational_node_number,component_idx
4013  INTEGER(INTG), ALLOCATABLE :: adjacent_elements(:),domains(:),local_element_numbers(:)
4014  TYPE(list_type), POINTER :: adjacent_domains_list
4015  TYPE(list_ptr_type), ALLOCATABLE :: adjacent_elements_list(:)
4016  TYPE(basis_type), POINTER :: basis
4017  TYPE(mesh_type), POINTER :: mesh
4018  TYPE(decomposition_type), POINTER :: decomposition
4019  TYPE(domain_mapping_type), POINTER :: elements_mapping
4020  TYPE(varying_string) :: dummy_error
4021 
4022  enters("DOMAIN_MAPPINGS_ELEMENTS_CALCULATE",err,error,*999)
4023 
4024  IF(ASSOCIATED(domain)) THEN
4025  IF(ASSOCIATED(domain%MAPPINGS)) THEN
4026  IF(ASSOCIATED(domain%MAPPINGS%ELEMENTS)) THEN
4027  elements_mapping=>domain%MAPPINGS%ELEMENTS
4028  IF(ASSOCIATED(domain%DECOMPOSITION)) THEN
4029  decomposition=>domain%DECOMPOSITION
4030  IF(ASSOCIATED(domain%MESH)) THEN
4031  mesh=>domain%MESH
4032  component_idx=domain%MESH_COMPONENT_NUMBER
4033  my_computational_node_number=computational_node_number_get(err,error)
4034  IF(err/=0) GOTO 999
4035 
4036  !Calculate the local and global numbers and set up the mappings
4037  ALLOCATE(elements_mapping%GLOBAL_TO_LOCAL_MAP(mesh%NUMBER_OF_ELEMENTS),stat=err)
4038  IF(err/=0) CALL flagerror("Could not allocate element mapping global to local map.",err,error,*999)
4039  elements_mapping%NUMBER_OF_GLOBAL=mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%NUMBER_OF_ELEMENTS
4040  !Loop over the global elements and calculate local numbers
4041  ALLOCATE(local_element_numbers(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4042  IF(err/=0) CALL flagerror("Could not allocate local element numbers.",err,error,*999)
4043  local_element_numbers=0
4044  ALLOCATE(adjacent_elements_list(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4045  IF(err/=0) CALL flagerror("Could not allocate adjacent elements list.",err,error,*999)
4046  DO domain_idx=0,decomposition%NUMBER_OF_DOMAINS-1
4047  NULLIFY(adjacent_elements_list(domain_idx)%PTR)
4048  CALL list_create_start(adjacent_elements_list(domain_idx)%PTR,err,error,*999)
4049  CALL list_data_type_set(adjacent_elements_list(domain_idx)%PTR,list_intg_type,err,error,*999)
4050  CALL list_initial_size_set(adjacent_elements_list(domain_idx)%PTR,max(int(mesh%NUMBER_OF_ELEMENTS/2),1), &
4051  & err,error,*999)
4052  CALL list_create_finish(adjacent_elements_list(domain_idx)%PTR,err,error,*999)
4053  ENDDO !domain_idx
4054 
4055  DO ne=1,mesh%NUMBER_OF_ELEMENTS
4056  !Calculate the local numbers
4057  domain_no=decomposition%ELEMENT_DOMAIN(ne)
4058  local_element_numbers(domain_no)=local_element_numbers(domain_no)+1
4059  !Calculate the adjacent elements to the computational domains and the adjacent domain numbers themselves
4060  basis=>mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%ELEMENTS(ne)%BASIS
4061  NULLIFY(adjacent_domains_list)
4062  CALL list_create_start(adjacent_domains_list,err,error,*999)
4063  CALL list_data_type_set(adjacent_domains_list,list_intg_type,err,error,*999)
4064  CALL list_initial_size_set(adjacent_domains_list,decomposition%NUMBER_OF_DOMAINS,err,error,*999)
4065  CALL list_create_finish(adjacent_domains_list,err,error,*999)
4066  CALL list_item_add(adjacent_domains_list,domain_no,err,error,*999)
4067  DO nn=1,basis%NUMBER_OF_NODES
4068  np=mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%ELEMENTS(ne)%MESH_ELEMENT_NODES(nn)
4069  DO no_adjacent_element=1,mesh%TOPOLOGY(component_idx)%PTR%NODES%NODES(np)%numberOfSurroundingElements
4070  adjacent_element=mesh%TOPOLOGY(component_idx)%PTR%NODES%NODES(np)%surroundingElements(no_adjacent_element)
4071  IF(decomposition%ELEMENT_DOMAIN(adjacent_element)/=domain_no) THEN
4072  CALL list_item_add(adjacent_elements_list(domain_no)%PTR,adjacent_element,err,error,*999)
4073  CALL list_item_add(adjacent_domains_list,decomposition%ELEMENT_DOMAIN(adjacent_element),err,error,*999)
4074  ENDIF
4075  ENDDO !no_adjacent_element
4076  ENDDO !nn
4077  CALL list_remove_duplicates(adjacent_domains_list,err,error,*999)
4078  CALL list_detach_and_destroy(adjacent_domains_list,number_of_domains,domains,err,error,*999)
4079  DEALLOCATE(domains)
4080  CALL domain_mappings_mapping_global_initialise(elements_mapping%GLOBAL_TO_LOCAL_MAP(ne),err,error,*999)
4081  ALLOCATE(elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_NUMBER(number_of_domains),stat=err)
4082  IF(err/=0) CALL flagerror("Could not allocate element global to local map local number.",err,error,*999)
4083  ALLOCATE(elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%DOMAIN_NUMBER(number_of_domains),stat=err)
4084  IF(err/=0) CALL flagerror("Could not allocate element global to local map domain number.",err,error,*999)
4085  ALLOCATE(elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_TYPE(number_of_domains),stat=err)
4086  IF(err/=0) CALL flagerror("Could not allocate element global to local map local type.",err,error,*999)
4087  elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%NUMBER_OF_DOMAINS=1
4088  elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_NUMBER(1)=local_element_numbers(domain_no)
4089  elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%DOMAIN_NUMBER(1)=decomposition%ELEMENT_DOMAIN(ne)
4090  IF(number_of_domains==1) THEN
4091  !Element is an internal element
4092  elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_TYPE(1)=domain_local_internal
4093  ELSE
4094  !Element is on the boundary of computational domains
4095  elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_TYPE(1)=domain_local_boundary
4096  ENDIF
4097  ENDDO !ne
4098 
4099  !Compute ghost element mappings
4100  DO domain_idx=0,decomposition%NUMBER_OF_DOMAINS-1
4101  CALL list_remove_duplicates(adjacent_elements_list(domain_idx)%PTR,err,error,*999)
4102  CALL list_detach_and_destroy(adjacent_elements_list(domain_idx)%PTR,number_of_adjacent_elements, &
4103  & adjacent_elements,err,error,*999)
4104  DO no_adjacent_element=1,number_of_adjacent_elements
4105  adjacent_element=adjacent_elements(no_adjacent_element)
4106  local_element_numbers(domain_idx)=local_element_numbers(domain_idx)+1
4107  elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%NUMBER_OF_DOMAINS= &
4108  & elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%NUMBER_OF_DOMAINS+1
4109  elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%LOCAL_NUMBER( &
4110  & elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%NUMBER_OF_DOMAINS)=local_element_numbers(domain_idx)
4111  elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%DOMAIN_NUMBER( &
4112  & elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%NUMBER_OF_DOMAINS)=domain_idx
4113  elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%LOCAL_TYPE( &
4114  & elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%NUMBER_OF_DOMAINS)= &
4115  & domain_local_ghost
4116  ENDDO !no_adjacent_element
4117  IF(ALLOCATED(adjacent_elements)) DEALLOCATE(adjacent_elements)
4118  ENDDO !domain_idx
4119 
4120  DEALLOCATE(adjacent_elements_list)
4121  DEALLOCATE(local_element_numbers)
4122 
4123  !Calculate element local to global maps from global to local map
4124  CALL domain_mappings_local_from_global_calculate(elements_mapping,err,error,*999)
4125 
4126  ELSE
4127  CALL flagerror("Domain mesh is not associated.",err,error,*999)
4128  ENDIF
4129  ELSE
4130  CALL flagerror("Domain decomposition is not associated.",err,error,*999)
4131  ENDIF
4132  ELSE
4133  CALL flagerror("Domain mappings elements is not associated.",err,error,*999)
4134  ENDIF
4135  ELSE
4136  CALL flagerror("Domain mappings is not associated.",err,error,*999)
4137  ENDIF
4138  ELSE
4139  CALL flagerror("Domain is not associated.",err,error,*998)
4140  ENDIF
4141 
4142  IF(diagnostics1) THEN
4143  CALL write_string(diagnostic_output_type,"Element mappings :",err,error,*999)
4144  CALL write_string(diagnostic_output_type," Global to local map :",err,error,*999)
4145  DO ne=1,mesh%NUMBER_OF_ELEMENTS
4146  CALL write_string_value(diagnostic_output_type," Global element = ",ne,err,error,*999)
4147  CALL write_string_value(diagnostic_output_type," Number of domains = ", &
4148  & elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%NUMBER_OF_DOMAINS,err,error,*999)
4149  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)% &
4150  & number_of_domains,8,8,elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_NUMBER, &
4151  & '(" Local number :",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4152  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)% &
4153  & number_of_domains,8,8,elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%DOMAIN_NUMBER, &
4154  & '(" Domain number:",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4155  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)% &
4156  & number_of_domains,8,8,elements_mapping%GLOBAL_TO_LOCAL_MAP(ne)%LOCAL_TYPE, &
4157  & '(" Local type :",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4158  ENDDO !ne
4159  CALL write_string(diagnostic_output_type," Local to global map :",err,error,*999)
4160  DO ne=1,elements_mapping%TOTAL_NUMBER_OF_LOCAL
4161  CALL write_string_value(diagnostic_output_type," Local element = ",ne,err,error,*999)
4162  CALL write_string_value(diagnostic_output_type," Global element = ", &
4163  & elements_mapping%LOCAL_TO_GLOBAL_MAP(ne),err,error,*999)
4164  ENDDO !ne
4165  IF(diagnostics2) THEN
4166  CALL write_string(diagnostic_output_type," Internal elements :",err,error,*999)
4167  CALL write_string_value(diagnostic_output_type," Number of internal elements = ", &
4168  & elements_mapping%NUMBER_OF_INTERNAL,err,error,*999)
4169  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%NUMBER_OF_INTERNAL,8,8, &
4170  & elements_mapping%DOMAIN_LIST(elements_mapping%INTERNAL_START:elements_mapping%INTERNAL_FINISH), &
4171  & '(" Internal elements:",8(X,I7))','(22X,8(X,I7))',err,error,*999)
4172  CALL write_string(diagnostic_output_type," Boundary elements :",err,error,*999)
4173  CALL write_string_value(diagnostic_output_type," Number of boundary elements = ", &
4174  & elements_mapping%NUMBER_OF_BOUNDARY,err,error,*999)
4175  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%NUMBER_OF_BOUNDARY,8,8, &
4176  & elements_mapping%DOMAIN_LIST(elements_mapping%BOUNDARY_START:elements_mapping%BOUNDARY_FINISH), &
4177  & '(" Boundary elements:",8(X,I7))','(22X,8(X,I7))',err,error,*999)
4178  CALL write_string(diagnostic_output_type," Ghost elements :",err,error,*999)
4179  CALL write_string_value(diagnostic_output_type," Number of ghost elements = ", &
4180  & elements_mapping%NUMBER_OF_GHOST,err,error,*999)
4181  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%NUMBER_OF_GHOST,8,8, &
4182  & elements_mapping%DOMAIN_LIST(elements_mapping%GHOST_START:elements_mapping%GHOST_FINISH), &
4183  & '(" Ghost elements :",8(X,I7))','(22X,8(X,I7))',err,error,*999)
4184  ENDIF
4185  CALL write_string(diagnostic_output_type," Adjacent domains :",err,error,*999)
4186  CALL write_string_value(diagnostic_output_type," Number of adjacent domains = ", &
4187  & elements_mapping%NUMBER_OF_ADJACENT_DOMAINS,err,error,*999)
4188  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%NUMBER_OF_DOMAINS+1,8,8, &
4189  & elements_mapping%ADJACENT_DOMAINS_PTR,'(" Adjacent domains ptr :",8(X,I7))','(27X,8(X,I7))',err,error,*999)
4190  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%ADJACENT_DOMAINS_PTR( &
4191  & elements_mapping%NUMBER_OF_DOMAINS)-1,8,8,elements_mapping%ADJACENT_DOMAINS_LIST, &
4192  '(" Adjacent domains list :",8(X,I7))','(27X,8(X,I7))',err,error,*999)
4193  DO domain_idx=1,elements_mapping%NUMBER_OF_ADJACENT_DOMAINS
4194  CALL write_string_value(diagnostic_output_type," Adjacent domain idx : ",domain_idx,err,error,*999)
4195  CALL write_string_value(diagnostic_output_type," Domain number = ", &
4196  & elements_mapping%ADJACENT_DOMAINS(domain_idx)%DOMAIN_NUMBER,err,error,*999)
4197  CALL write_string_value(diagnostic_output_type," Number of send ghosts = ", &
4198  & elements_mapping%ADJACENT_DOMAINS(domain_idx)%NUMBER_OF_SEND_GHOSTS,err,error,*999)
4199  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%ADJACENT_DOMAINS(domain_idx)% &
4200  & number_of_send_ghosts,6,6,elements_mapping%ADJACENT_DOMAINS(domain_idx)%LOCAL_GHOST_SEND_INDICES, &
4201  & '(" Local send ghost indicies :",6(X,I7))','(39X,6(X,I7))',err,error,*999)
4202  CALL write_string_value(diagnostic_output_type," Number of recieve ghosts = ", &
4203  & elements_mapping%ADJACENT_DOMAINS(domain_idx)%NUMBER_OF_RECEIVE_GHOSTS,err,error,*999)
4204  CALL write_string_vector(diagnostic_output_type,1,1,elements_mapping%ADJACENT_DOMAINS(domain_idx)% &
4205  & number_of_receive_ghosts,6,6,elements_mapping%ADJACENT_DOMAINS(domain_idx)%LOCAL_GHOST_RECEIVE_INDICES, &
4206  & '(" Local receive ghost indicies :",6(X,I7))','(39X,6(X,I7))',err,error,*999)
4207  ENDDO !domain_idx
4208  ENDIF
4209 
4210  exits("DOMAIN_MAPPINGS_ELEMENTS_CALCULATE")
4211  RETURN
4212 999 IF(ALLOCATED(domains)) DEALLOCATE(domains)
4213  IF(ALLOCATED(adjacent_elements)) DEALLOCATE(adjacent_elements)
4214  IF(ASSOCIATED(domain%MAPPINGS%ELEMENTS)) CALL domain_mappings_elements_finalise(domain%MAPPINGS,dummy_err,dummy_error,*998)
4215 998 errorsexits("DOMAIN_MAPPINGS_ELEMENTS_CALCULATE",err,error)
4216  RETURN 1
4217  END SUBROUTINE domain_mappings_elements_calculate
4218 
4219  !
4220  !================================================================================================================================
4221  !
4222 
4224  SUBROUTINE domain_mappings_finalise(DOMAIN,ERR,ERROR,*)
4225 
4226  !Argument variables
4227  TYPE(domain_type), POINTER :: domain
4228  INTEGER(INTG), INTENT(OUT) :: err
4229  TYPE(varying_string), INTENT(OUT) :: error
4230  !Local Variables
4231 
4232  enters("DOMAIN_MAPPINGS_FINALISE",err,error,*999)
4233 
4234  IF(ASSOCIATED(domain)) THEN
4235  CALL domain_mappings_elements_finalise(domain%MAPPINGS,err,error,*999)
4236  CALL domain_mappings_nodes_finalise(domain%MAPPINGS,err,error,*999)
4237  CALL domain_mappings_dofs_finalise(domain%MAPPINGS,err,error,*999)
4238  DEALLOCATE(domain%MAPPINGS)
4239  ELSE
4240  CALL flagerror("Domain is not associated.",err,error,*999)
4241  ENDIF
4242 
4243  exits("DOMAIN_MAPPINGS_FINALISE")
4244  RETURN
4245 999 errorsexits("DOMAIN_MAPPINGS_FINALISE",err,error)
4246  RETURN 1
4247 
4248  END SUBROUTINE domain_mappings_finalise
4249 
4250  !
4251  !================================================================================================================================
4252  !
4253 
4255  SUBROUTINE domain_mappings_elements_finalise(DOMAIN_MAPPINGS,ERR,ERROR,*)
4256 
4257  !Argument variables
4258  TYPE(domain_mappings_type), POINTER :: domain_mappings
4259  INTEGER(INTG), INTENT(OUT) :: err
4260  TYPE(varying_string), INTENT(OUT) :: error
4261  !Local Variables
4262 
4263  enters("DOMAIN_MAPPINGS_ELEMENTS_FINALISE",err,error,*999)
4264 
4265  IF(ASSOCIATED(domain_mappings)) THEN
4266  IF(ASSOCIATED(domain_mappings%ELEMENTS)) THEN
4267  CALL domain_mappings_mapping_finalise(domain_mappings%ELEMENTS,err,error,*999)
4268  ENDIF
4269  ELSE
4270  CALL flagerror("Domain mapping is not associated.",err,error,*999)
4271  ENDIF
4272 
4273  exits("DOMAIN_MAPPINGS_ELEMENTS_FINALISE")
4274  RETURN
4275 999 errorsexits("DOMAIN_MAPPINGS_ELEMENTS_FINALISE",err,error)
4276  RETURN 1
4277 
4278  END SUBROUTINE domain_mappings_elements_finalise
4279 
4280  !
4281  !================================================================================================================================
4282  !
4283 
4285  SUBROUTINE domain_mappings_elements_initialise(DOMAIN_MAPPINGS,ERR,ERROR,*)
4286 
4287  !Argument variables
4288  TYPE(domain_mappings_type), POINTER :: domain_mappings
4289  INTEGER(INTG), INTENT(OUT) :: err
4290  TYPE(varying_string), INTENT(OUT) :: error
4291  !Local Variables
4292 
4293  enters("DOMAIN_MAPPINGS_ELEMENTS_INITIALISE",err,error,*999)
4294 
4295  IF(ASSOCIATED(domain_mappings)) THEN
4296  IF(ASSOCIATED(domain_mappings%ELEMENTS)) THEN
4297  CALL flagerror("Domain elements mappings are already associated.",err,error,*999)
4298  ELSE
4299  ALLOCATE(domain_mappings%ELEMENTS,stat=err)
4300  IF(err/=0) CALL flagerror("Could not allocate domain mappings elements.",err,error,*999)
4301  CALL domain_mappings_mapping_initialise(domain_mappings%ELEMENTS,domain_mappings%DOMAIN%DECOMPOSITION%NUMBER_OF_DOMAINS, &
4302  & err,error,*999)
4303  ENDIF
4304  ELSE
4305  CALL flagerror("Domain mapping is not associated.",err,error,*999)
4306  ENDIF
4307 
4308  exits("DOMAIN_MAPPINGS_ELEMENTS_INITIALISE")
4309  RETURN
4310 999 errorsexits("DOMAIN_MAPPINGS_ELEMENTS_INITIALISE",err,error)
4311  RETURN 1
4312 
4313  END SUBROUTINE domain_mappings_elements_initialise
4314 
4315  !
4316  !================================================================================================================================
4317  !
4318 
4320  SUBROUTINE domain_mappings_initialise(DOMAIN,ERR,ERROR,*)
4321 
4322  !Argument variables
4323  TYPE(domain_type), POINTER :: domain
4324  INTEGER(INTG), INTENT(OUT) :: err
4325  TYPE(varying_string), INTENT(OUT) :: error
4326  !Local Variables
4327 
4328  enters("DOMAIN_MAPPINGS_INITIALISE",err,error,*999)
4329 
4330  IF(ASSOCIATED(domain)) THEN
4331  IF(ASSOCIATED(domain%MAPPINGS)) THEN
4332  CALL flagerror("Domain already has mappings associated.",err,error,*999)
4333  ELSE
4334  ALLOCATE(domain%MAPPINGS,stat=err)
4335  IF(err/=0) CALL flagerror("Could not allocate domain mappings.",err,error,*999)
4336  domain%MAPPINGS%DOMAIN=>domain
4337  NULLIFY(domain%MAPPINGS%ELEMENTS)
4338  NULLIFY(domain%MAPPINGS%NODES)
4339  NULLIFY(domain%MAPPINGS%DOFS)
4340  !Calculate the node and element mappings
4341  CALL domain_mappings_elements_initialise(domain%MAPPINGS,err,error,*999)
4342  CALL domain_mappings_nodes_initialise(domain%MAPPINGS,err,error,*999)
4343  CALL domain_mappings_dofs_initialise(domain%MAPPINGS,err,error,*999)
4344  CALL domain_mappings_elements_calculate(domain,err,error,*999)
4345  CALL domain_mappings_nodes_dofs_calculate(domain,err,error,*999)
4346  ENDIF
4347  ELSE
4348  CALL flagerror("Domain is not associated.",err,error,*999)
4349  ENDIF
4350 
4351  exits("DOMAIN_MAPPINGS_INITIALISE")
4352  RETURN
4353 999 errorsexits("DOMAIN_MAPPINGS_INITIALISE",err,error)
4354  RETURN 1
4355  END SUBROUTINE domain_mappings_initialise
4356 
4357  !
4358  !================================================================================================================================
4359  !
4360 
4362  SUBROUTINE domain_mappings_nodes_dofs_calculate(DOMAIN,ERR,ERROR,*)
4363 
4364  !Argument variables
4365  TYPE(domain_type), POINTER :: domain
4366  INTEGER(INTG), INTENT(OUT) :: err
4367  TYPE(varying_string), INTENT(OUT) :: error
4368  !Local Variables
4369  INTEGER(INTG) :: dummy_err,no_adjacent_element,no_computational_node,no_ghost_node,adjacent_element,ghost_node, &
4370  & NUMBER_OF_NODES_PER_DOMAIN,domain_idx,domain_idx2,domain_no,node_idx,derivative_idx,version_idx,ny,NUMBER_OF_DOMAINS, &
4371  & MAX_NUMBER_DOMAINS,NUMBER_OF_GHOST_NODES,my_computational_node_number,number_computational_nodes,component_idx
4372  INTEGER(INTG), ALLOCATABLE :: local_node_numbers(:),local_dof_numbers(:),node_count(:),number_internal_nodes(:), &
4373  & NUMBER_BOUNDARY_NODES(:)
4374  INTEGER(INTG), ALLOCATABLE :: domains(:),all_domains(:),ghost_nodes(:)
4375  LOGICAL :: boundary_domain
4376  TYPE(list_type), POINTER :: adjacent_domains_list,all_adjacent_domains_list
4377  TYPE(list_ptr_type), ALLOCATABLE :: ghost_nodes_list(:)
4378  TYPE(mesh_type), POINTER :: mesh
4379  TYPE(meshcomponenttopologytype), POINTER :: mesh_topology
4380  TYPE(decomposition_type), POINTER :: decomposition
4381  TYPE(domain_mapping_type), POINTER :: elements_mapping
4382  TYPE(domain_mapping_type), POINTER :: nodes_mapping
4383  TYPE(domain_mapping_type), POINTER :: dofs_mapping
4384  TYPE(varying_string) :: dummy_error,local_error
4385 
4386  enters("DOMAIN_MAPPINGS_NODES_DOFS_CALCULATE",err,error,*999)
4387 
4388  IF(ASSOCIATED(domain)) THEN
4389  IF(ASSOCIATED(domain%MAPPINGS)) THEN
4390  IF(ASSOCIATED(domain%MAPPINGS%NODES)) THEN
4391  nodes_mapping=>domain%MAPPINGS%NODES
4392  IF(ASSOCIATED(domain%MAPPINGS%DOFS)) THEN
4393  dofs_mapping=>domain%MAPPINGS%DOFS
4394  IF(ASSOCIATED(domain%MAPPINGS%ELEMENTS)) THEN
4395  elements_mapping=>domain%MAPPINGS%ELEMENTS
4396  IF(ASSOCIATED(domain%DECOMPOSITION)) THEN
4397  decomposition=>domain%DECOMPOSITION
4398  IF(ASSOCIATED(domain%MESH)) THEN
4399  mesh=>domain%MESH
4400  component_idx=domain%MESH_COMPONENT_NUMBER
4401  mesh_topology=>mesh%TOPOLOGY(component_idx)%PTR
4402 
4403  number_computational_nodes=computational_nodes_number_get(err,error)
4404  IF(err/=0) GOTO 999
4405  my_computational_node_number=computational_node_number_get(err,error)
4406  IF(err/=0) GOTO 999
4407 
4408  !Calculate the local and global numbers and set up the mappings
4409  ALLOCATE(nodes_mapping%GLOBAL_TO_LOCAL_MAP(mesh_topology%NODES%numberOfNodes),stat=err)
4410  IF(err/=0) CALL flagerror("Could not allocate node mapping global to local map.",err,error,*999)
4411  nodes_mapping%NUMBER_OF_GLOBAL=mesh_topology%NODES%numberOfNodes
4412  ALLOCATE(local_node_numbers(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4413  IF(err/=0) CALL flagerror("Could not allocate local node numbers.",err,error,*999)
4414  local_node_numbers=0
4415  ALLOCATE(dofs_mapping%GLOBAL_TO_LOCAL_MAP(mesh_topology%dofs%numberOfDofs),stat=err)
4416  IF(err/=0) CALL flagerror("Could not allocate dofs mapping global to local map.",err,error,*999)
4417  dofs_mapping%NUMBER_OF_GLOBAL=mesh_topology%DOFS%numberOfDofs
4418  ALLOCATE(local_dof_numbers(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4419  IF(err/=0) CALL flagerror("Could not allocate local dof numbers.",err,error,*999)
4420  local_dof_numbers=0
4421  ALLOCATE(ghost_nodes_list(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4422  IF(err/=0) CALL flagerror("Could not allocate ghost nodes list.",err,error,*999)
4423  DO domain_idx=0,decomposition%NUMBER_OF_DOMAINS-1
4424  NULLIFY(ghost_nodes_list(domain_idx)%PTR)
4425  CALL list_create_start(ghost_nodes_list(domain_idx)%PTR,err,error,*999)
4426  CALL list_data_type_set(ghost_nodes_list(domain_idx)%PTR,list_intg_type,err,error,*999)
4427  CALL list_initial_size_set(ghost_nodes_list(domain_idx)%PTR,int(mesh_topology%NODES%numberOfNodes/2), &
4428  & err,error,*999)
4429  CALL list_create_finish(ghost_nodes_list(domain_idx)%PTR,err,error,*999)
4430  ENDDO !domain_idx
4431  ALLOCATE(number_internal_nodes(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4432  IF(err/=0) CALL flagerror("Could not allocate number of internal nodes.",err,error,*999)
4433  number_internal_nodes=0
4434  ALLOCATE(number_boundary_nodes(0:decomposition%NUMBER_OF_DOMAINS-1),stat=err)
4435  IF(err/=0) CALL flagerror("Could not allocate number of boundary nodes.",err,error,*999)
4436  number_boundary_nodes=0
4437 
4438  !For the first pass just determine the internal and boundary nodes
4439  DO node_idx=1,mesh_topology%NODES%numberOfNodes
4440  NULLIFY(adjacent_domains_list)
4441  CALL list_create_start(adjacent_domains_list,err,error,*999)
4442  CALL list_data_type_set(adjacent_domains_list,list_intg_type,err,error,*999)
4443  CALL list_initial_size_set(adjacent_domains_list,decomposition%NUMBER_OF_DOMAINS,err,error,*999)
4444  CALL list_create_finish(adjacent_domains_list,err,error,*999)
4445  NULLIFY(all_adjacent_domains_list)
4446  CALL list_create_start(all_adjacent_domains_list,err,error,*999)
4447  CALL list_data_type_set(all_adjacent_domains_list,list_intg_type,err,error,*999)
4448  CALL list_initial_size_set(all_adjacent_domains_list,decomposition%NUMBER_OF_DOMAINS,err,error,*999)
4449  CALL list_create_finish(all_adjacent_domains_list,err,error,*999)
4450  DO no_adjacent_element=1,mesh_topology%NODES%NODES(node_idx)%numberOfSurroundingElements
4451  adjacent_element=mesh_topology%NODES%NODES(node_idx)%surroundingElements(no_adjacent_element)
4452  domain_no=decomposition%ELEMENT_DOMAIN(adjacent_element)
4453  CALL list_item_add(adjacent_domains_list,domain_no,err,error,*999)
4454  DO domain_idx=1,elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)%NUMBER_OF_DOMAINS
4455  CALL list_item_add(all_adjacent_domains_list,elements_mapping%GLOBAL_TO_LOCAL_MAP(adjacent_element)% &
4456  & domain_number(domain_idx),err,error,*999)
4457  ENDDO !domain_idx
4458  ENDDO !no_adjacent_element
4459  CALL list_remove_duplicates(adjacent_domains_list,err,error,*999)
4460  CALL list_detach_and_destroy(adjacent_domains_list,number_of_domains,domains,err,error,*999)
4461  CALL list_remove_duplicates(all_adjacent_domains_list,err,error,*999)
4462  CALL list_detach_and_destroy(all_adjacent_domains_list,max_number_domains,all_domains,err,error,*999)
4463  IF(number_of_domains/=max_number_domains) THEN !Ghost node
4464  DO domain_idx=1,max_number_domains
4465  domain_no=all_domains(domain_idx)
4466  boundary_domain=.false.
4467  DO domain_idx2=1,number_of_domains
4468  IF(domain_no==domains(domain_idx2)) THEN
4469  boundary_domain=.true.
4470  EXIT
4471  ENDIF
4472  ENDDO !domain_idx2
4473  IF(.NOT.boundary_domain) CALL list_item_add(ghost_nodes_list(domain_no)%PTR,node_idx,err,error,*999)
4474  ENDDO !domain_idx
4475  ENDIF
4476  ALLOCATE(nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(max_number_domains),stat=err)
4477  IF(err/=0) CALL flagerror("Could not allocate node global to local map local number.",err,error,*999)
4478  ALLOCATE(nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER(max_number_domains),stat=err)
4479  IF(err/=0) CALL flagerror("Could not allocate node global to local map domain number.",err,error,*999)
4480  ALLOCATE(nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_TYPE(max_number_domains),stat=err)
4481  IF(err/=0) CALL flagerror("Could not allocate node global to local map local type.",err,error,*999)
4482  DO derivative_idx=1,mesh_topology%NODES%NODES(node_idx)%numberOfDerivatives
4483  DO version_idx=1,mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
4484  ny=mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4485  ALLOCATE(dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER(max_number_domains),stat=err)
4486  IF(err/=0) CALL flagerror("Could not allocate dof global to local map local number.",err,error,*999)
4487  ALLOCATE(dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%DOMAIN_NUMBER(max_number_domains),stat=err)
4488  IF(err/=0) CALL flagerror("Could not allocate dof global to local map domain number.",err,error,*999)
4489  ALLOCATE(dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_TYPE(max_number_domains),stat=err)
4490  IF(err/=0) CALL flagerror("Could not allocate dof global to local map local type.",err,error,*999)
4491  ENDDO !version_idx
4492  ENDDO !derivative_idx
4493  IF(number_of_domains==1) THEN
4494  !Node is an internal node
4495  domain_no=domains(1)
4496  number_internal_nodes(domain_no)=number_internal_nodes(domain_no)+1
4497  !LOCAL_NODE_NUMBERS(domain_no)=LOCAL_NODE_NUMBERS(domain_no)+1
4498  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS=1
4499  !NODES_MAPPING%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(1)=LOCAL_NODE_NUMBERS(DOMAINS(1))
4500  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(1)=-1
4501  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER(1)=domains(1)
4502  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_TYPE(1)=domain_local_internal
4503  DO derivative_idx=1,mesh_topology%NODES%NODES(node_idx)%numberOfDerivatives
4504  DO version_idx=1,mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
4505  ny=mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4506  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS=1
4507  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER(1)=-1
4508  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%DOMAIN_NUMBER(1)=domain_no
4509  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_TYPE(1)=domain_local_internal
4510  ENDDO !version_idx
4511  ENDDO !derivative_idx
4512  ELSE
4513  !Node is on the boundary of computational domains
4514  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS=number_of_domains
4515  DO derivative_idx=1,mesh_topology%NODES%NODES(node_idx)%numberOfDerivatives
4516  DO version_idx=1,mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
4517  ny=mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4518  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS=number_of_domains
4519  ENDDO !version_idx
4520  ENDDO !derivative_idx
4521  DO domain_idx=1,number_of_domains
4522  domain_no=domains(domain_idx)
4523  !LOCAL_NODE_NUMBERS(domain_no)=LOCAL_NODE_NUMBERS(domain_no)+1
4524  !NODES_MAPPING%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(domain_idx)=LOCAL_NODE_NUMBERS(domain_no)
4525  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(domain_idx)=-1
4526  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER(domain_idx)=domain_no
4527  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_TYPE(domain_idx)=domain_local_boundary
4528  DO derivative_idx=1,mesh_topology%NODES%NODES(node_idx)%numberOfDerivatives
4529  DO version_idx=1,mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
4530  ny=mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4531  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER(domain_idx)=-1
4532  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%DOMAIN_NUMBER(domain_idx)=domain_no
4533  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_TYPE(domain_idx)=domain_local_boundary
4534  ENDDO !version_idx
4535  ENDDO !derivative_idx
4536  ENDDO !domain_idx
4537  ENDIF
4538  DEALLOCATE(domains)
4539  DEALLOCATE(all_domains)
4540  ENDDO !node_idx
4541 
4542  !For the second pass assign boundary nodes to one domain on the boundary and set local node numbers.
4543  number_of_nodes_per_domain=floor(REAL(mesh_topology%nodes%numberofnodes,dp)/ &
4544  & REAL(DECOMPOSITION%NUMBER_OF_DOMAINS,DP))
4545  allocate(domain%node_domain(mesh_topology%nodes%numberofnodes),stat=err)
4546  IF(err/=0) CALL flagerror("Could not allocate node domain",err,error,*999)
4547  domain%NODE_DOMAIN=-1
4548  DO node_idx=1,mesh_topology%NODES%numberOfNodes
4549  IF(nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS==1) THEN !Internal node
4550  domain_no=nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER(1)
4551  domain%NODE_DOMAIN(node_idx)=domain_no
4552  local_node_numbers(domain_no)=local_node_numbers(domain_no)+1
4553  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(1)=local_node_numbers(domain_no)
4554  DO derivative_idx=1,mesh_topology%NODES%NODES(node_idx)%numberOfDerivatives
4555  DO version_idx=1,mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
4556  ny=mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4557  local_dof_numbers(domain_no)=local_dof_numbers(domain_no)+1
4558  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER(1)=local_dof_numbers(domain_no)
4559  ENDDO !version_idx
4560  ENDDO !derivative_idx
4561  ELSE !Boundary node
4562  number_of_domains=nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS
4563  DO domain_idx=1,number_of_domains
4564  domain_no=nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER(domain_idx)
4565  IF(domain%NODE_DOMAIN(node_idx)<0) THEN
4566  IF((number_internal_nodes(domain_no)+number_boundary_nodes(domain_no)<number_of_nodes_per_domain).OR. &
4567  & (domain_idx==nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS)) THEN
4568  !Allocate the node to this domain
4569  domain%NODE_DOMAIN(node_idx)=domain_no
4570  number_boundary_nodes(domain_no)=number_boundary_nodes(domain_no)+1
4571  local_node_numbers(domain_no)=local_node_numbers(domain_no)+1
4572  !Reset the boundary information to be in the first domain index. The remaining domain indicies will
4573  !be overwritten when the ghost nodes are calculated below.
4574  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS=1
4575  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER(1)=local_node_numbers(domain_no)
4576  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER(1)=domain_no
4577  nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_TYPE(1)=domain_local_boundary
4578  DO derivative_idx=1,mesh_topology%NODES%NODES(node_idx)%numberOfDerivatives
4579  DO version_idx=1,mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
4580  ny=mesh_topology%NODES%NODES(node_idx)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4581  local_dof_numbers(domain_no)=local_dof_numbers(domain_no)+1
4582  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS=1
4583  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER(1)=local_dof_numbers(domain_no)
4584  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%DOMAIN_NUMBER(1)=domain_no
4585  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_TYPE(1)=domain_local_boundary
4586  ENDDO !version_idx
4587  ENDDO !derivative_idx
4588  ELSE
4589  !The node as already been assigned to a domain so it must be a ghost node in this domain
4590  CALL list_item_add(ghost_nodes_list(domain_no)%PTR,node_idx,err,error,*999)
4591  ENDIF
4592  ELSE
4593  !The node as already been assigned to a domain so it must be a ghost node in this domain
4594  CALL list_item_add(ghost_nodes_list(domain_no)%PTR,node_idx,err,error,*999)
4595  ENDIF
4596  ENDDO !domain_idx
4597  ENDIF
4598  ENDDO !node_idx
4599  DEALLOCATE(number_internal_nodes)
4600 
4601  !Calculate ghost node and dof mappings
4602  DO domain_idx=0,decomposition%NUMBER_OF_DOMAINS-1
4603  CALL list_remove_duplicates(ghost_nodes_list(domain_idx)%PTR,err,error,*999)
4604  CALL list_detach_and_destroy(ghost_nodes_list(domain_idx)%PTR,number_of_ghost_nodes,ghost_nodes,err,error,*999)
4605  DO no_ghost_node=1,number_of_ghost_nodes
4606  ghost_node=ghost_nodes(no_ghost_node)
4607  local_node_numbers(domain_idx)=local_node_numbers(domain_idx)+1
4608  nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%NUMBER_OF_DOMAINS= &
4609  & nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%NUMBER_OF_DOMAINS+1
4610  nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%LOCAL_NUMBER( &
4611  & nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%NUMBER_OF_DOMAINS)= &
4612  & local_node_numbers(domain_idx)
4613  nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%DOMAIN_NUMBER( &
4614  & nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%NUMBER_OF_DOMAINS)=domain_idx
4615  nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%LOCAL_TYPE( &
4616  & nodes_mapping%GLOBAL_TO_LOCAL_MAP(ghost_node)%NUMBER_OF_DOMAINS)= &
4617  & domain_local_ghost
4618  DO derivative_idx=1,mesh_topology%NODES%NODES(ghost_node)%numberOfDerivatives
4619  DO version_idx=1,mesh_topology%NODES%NODES(ghost_node)%DERIVATIVES(derivative_idx)%numberOfVersions
4620  ny=mesh_topology%NODES%NODES(ghost_node)%DERIVATIVES(derivative_idx)%dofIndex(version_idx)
4621  local_dof_numbers(domain_idx)=local_dof_numbers(domain_idx)+1
4622  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS= &
4623  & dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS+1
4624  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER( &
4625  & dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS)= &
4626  & local_dof_numbers(domain_idx)
4627  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%DOMAIN_NUMBER( &
4628  & dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS)=domain_idx
4629  dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_TYPE( &
4630  & dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS)= &
4631  & domain_local_ghost
4632  ENDDO !version_idx
4633  ENDDO !derivative_idx
4634  ENDDO !no_ghost_node
4635  DEALLOCATE(ghost_nodes)
4636  ENDDO !domain_idx
4637 
4638  !Check decomposition and check that each domain has a node in it.
4639  ALLOCATE(node_count(0:number_computational_nodes-1),stat=err)
4640  IF(err/=0) CALL flagerror("Could not allocate node count.",err,error,*999)
4641  node_count=0
4642  DO node_idx=1,mesh_topology%NODES%numberOfNodes
4643  no_computational_node=domain%NODE_DOMAIN(node_idx)
4644  IF(no_computational_node>=0.AND.no_computational_node<number_computational_nodes) THEN
4645  node_count(no_computational_node)=node_count(no_computational_node)+1
4646  ELSE
4647  local_error="The computational node number of "// &
4648  & trim(number_to_vstring(no_computational_node,"*",err,error))// &
4649  & " for node number "//trim(number_to_vstring(node_idx,"*",err,error))// &
4650  & " is invalid. The computational node number must be between 0 and "// &
4651  & trim(number_to_vstring(number_computational_nodes-1,"*",err,error))//"."
4652  CALL flagerror(local_error,err,error,*999)
4653  ENDIF
4654  ENDDO !node_idx
4655  DO no_computational_node=0,number_computational_nodes-1
4656  IF(node_count(no_computational_node)==0) THEN
4657  local_error="Invalid decomposition. There are no nodes in computational node "// &
4658  & trim(number_to_vstring(no_computational_node,"*",err,error))//"."
4659  CALL flagerror(local_error,err,error,*999)
4660  ENDIF
4661  ENDDO !no_computational_node
4662  DEALLOCATE(node_count)
4663 
4664  DEALLOCATE(ghost_nodes_list)
4665  DEALLOCATE(local_node_numbers)
4666 
4667  !Calculate node and dof local to global maps from global to local map
4668  CALL domain_mappings_local_from_global_calculate(nodes_mapping,err,error,*999)
4669  CALL domain_mappings_local_from_global_calculate(dofs_mapping,err,error,*999)
4670 
4671  ELSE
4672  CALL flagerror("Domain mesh is not associated.",err,error,*999)
4673  ENDIF
4674  ELSE
4675  CALL flagerror("Domain decomposition is not associated.",err,error,*999)
4676  ENDIF
4677  ELSE
4678  CALL flagerror("Domain mappings elements is not associated.",err,error,*999)
4679  ENDIF
4680  ELSE
4681  CALL flagerror("Domain mappings dofs is not associated.",err,error,*999)
4682  ENDIF
4683  ELSE
4684  CALL flagerror("Domain mappings nodes is not associated.",err,error,*999)
4685  ENDIF
4686  ELSE
4687  CALL flagerror("Domain mappings is not associated.",err,error,*999)
4688  ENDIF
4689  ELSE
4690  CALL flagerror("Domain is not associated.",err,error,*998)
4691  ENDIF
4692 
4693  IF(diagnostics1) THEN
4694  CALL write_string(diagnostic_output_type,"Node decomposition :",err,error,*999)
4695  DO node_idx=1,mesh_topology%NODES%numberOfNodes
4696  CALL write_string_value(diagnostic_output_type," Node = ",node_idx,err,error,*999)
4697  CALL write_string_value(diagnostic_output_type," Domain = ",domain%NODE_DOMAIN(node_idx),err,error,*999)
4698  ENDDO !node_idx
4699  CALL write_string(diagnostic_output_type,"Node mappings :",err,error,*999)
4700  CALL write_string(diagnostic_output_type," Global to local map :",err,error,*999)
4701  DO node_idx=1,mesh_topology%NODES%numberOfNodes
4702  CALL write_string_value(diagnostic_output_type," Global node = ",node_idx,err,error,*999)
4703  CALL write_string_value(diagnostic_output_type," Number of domains = ", &
4704  & nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%NUMBER_OF_DOMAINS,err,error,*999)
4705  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)% &
4706  & number_of_domains,8,8,nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_NUMBER, &
4707  & '(" Local number :",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4708  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)% &
4709  & number_of_domains,8,8,nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%DOMAIN_NUMBER, &
4710  & '(" Domain number:",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4711  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)% &
4712  & number_of_domains,8,8,nodes_mapping%GLOBAL_TO_LOCAL_MAP(node_idx)%LOCAL_TYPE, &
4713  & '(" Local type :",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4714  ENDDO !node_idx
4715  CALL write_string(diagnostic_output_type," Local to global map :",err,error,*999)
4716  DO node_idx=1,nodes_mapping%TOTAL_NUMBER_OF_LOCAL
4717  CALL write_string_value(diagnostic_output_type," Local node = ",node_idx,err,error,*999)
4718  CALL write_string_value(diagnostic_output_type," Global node = ", &
4719  & nodes_mapping%LOCAL_TO_GLOBAL_MAP(node_idx),err,error,*999)
4720  ENDDO !node_idx
4721  IF(diagnostics2) THEN
4722  CALL write_string(diagnostic_output_type," Internal nodes :",err,error,*999)
4723  CALL write_string_value(diagnostic_output_type," Number of internal nodes = ", &
4724  & nodes_mapping%NUMBER_OF_INTERNAL,err,error,*999)
4725  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%NUMBER_OF_INTERNAL,8,8, &
4726  & nodes_mapping%DOMAIN_LIST(nodes_mapping%INTERNAL_START:nodes_mapping%INTERNAL_FINISH), &
4727  & '(" Internal nodes:",8(X,I7))','(19X,8(X,I7))',err,error,*999)
4728  CALL write_string(diagnostic_output_type," Boundary nodes :",err,error,*999)
4729  CALL write_string_value(diagnostic_output_type," Number of boundary nodes = ", &
4730  & nodes_mapping%NUMBER_OF_BOUNDARY,err,error,*999)
4731  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%NUMBER_OF_BOUNDARY,8,8, &
4732  & nodes_mapping%DOMAIN_LIST(nodes_mapping%BOUNDARY_START:nodes_mapping%BOUNDARY_FINISH), &
4733  & '(" Boundary nodes:",8(X,I7))','(19X,8(X,I7))',err,error,*999)
4734  CALL write_string(diagnostic_output_type," Ghost nodes :",err,error,*999)
4735  CALL write_string_value(diagnostic_output_type," Number of ghost nodes = ", &
4736  & nodes_mapping%NUMBER_OF_GHOST,err,error,*999)
4737  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%NUMBER_OF_GHOST,8,8, &
4738  & nodes_mapping%DOMAIN_LIST(nodes_mapping%GHOST_START:nodes_mapping%GHOST_FINISH), &
4739  & '(" Ghost nodes :",8(X,I7))','(19X,8(X,I7))',err,error,*999)
4740  ENDIF
4741  CALL write_string(diagnostic_output_type," Adjacent domains :",err,error,*999)
4742  CALL write_string_value(diagnostic_output_type," Number of adjacent domains = ", &
4743  & nodes_mapping%NUMBER_OF_ADJACENT_DOMAINS,err,error,*999)
4744  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%NUMBER_OF_DOMAINS+1,8,8, &
4745  & nodes_mapping%ADJACENT_DOMAINS_PTR,'(" Adjacent domains ptr :",8(X,I7))','(27X,8(X,I7))',err,error,*999)
4746  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%ADJACENT_DOMAINS_PTR( &
4747  & nodes_mapping%NUMBER_OF_DOMAINS)-1,8,8,nodes_mapping%ADJACENT_DOMAINS_LIST, &
4748  '(" Adjacent domains list :",8(X,I7))','(27X,8(X,I7))',err,error,*999)
4749  DO domain_idx=1,nodes_mapping%NUMBER_OF_ADJACENT_DOMAINS
4750  CALL write_string_value(diagnostic_output_type," Adjacent domain idx : ",domain_idx,err,error,*999)
4751  CALL write_string_value(diagnostic_output_type," Domain number = ", &
4752  & nodes_mapping%ADJACENT_DOMAINS(domain_idx)%DOMAIN_NUMBER,err,error,*999)
4753  CALL write_string_value(diagnostic_output_type," Number of send ghosts = ", &
4754  & nodes_mapping%ADJACENT_DOMAINS(domain_idx)%NUMBER_OF_SEND_GHOSTS,err,error,*999)
4755  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%ADJACENT_DOMAINS(domain_idx)% &
4756  & number_of_send_ghosts,6,6,nodes_mapping%ADJACENT_DOMAINS(domain_idx)%LOCAL_GHOST_SEND_INDICES, &
4757  & '(" Local send ghost indicies :",6(X,I7))','(39X,6(X,I7))',err,error,*999)
4758  CALL write_string_value(diagnostic_output_type," Number of recieve ghosts = ", &
4759  & nodes_mapping%ADJACENT_DOMAINS(domain_idx)%NUMBER_OF_RECEIVE_GHOSTS,err,error,*999)
4760  CALL write_string_vector(diagnostic_output_type,1,1,nodes_mapping%ADJACENT_DOMAINS(domain_idx)% &
4761  & number_of_receive_ghosts,6,6,nodes_mapping%ADJACENT_DOMAINS(domain_idx)%LOCAL_GHOST_RECEIVE_INDICES, &
4762  & '(" Local receive ghost indicies :",6(X,I7))','(39X,6(X,I7))',err,error,*999)
4763  ENDDO !domain_idx
4764  CALL write_string(diagnostic_output_type,"Dofs mappings :",err,error,*999)
4765  CALL write_string(diagnostic_output_type," Global to local map :",err,error,*999)
4766  DO ny=1,mesh_topology%DOFS%numberOfDofs
4767  CALL write_string_value(diagnostic_output_type," Global dof = ",ny,err,error,*999)
4768  CALL write_string_value(diagnostic_output_type," Number of domains = ", &
4769  & dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%NUMBER_OF_DOMAINS,err,error,*999)
4770  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)% &
4771  & number_of_domains,8,8,dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_NUMBER, &
4772  & '(" Local number :",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4773  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)% &
4774  & number_of_domains,8,8,dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%DOMAIN_NUMBER, &
4775  & '(" Domain number:",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4776  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)% &
4777  & number_of_domains,8,8,dofs_mapping%GLOBAL_TO_LOCAL_MAP(ny)%LOCAL_TYPE, &
4778  & '(" Local type :",8(X,I7))','(20X,8(X,I7))',err,error,*999)
4779  ENDDO !ny
4780  CALL write_string(diagnostic_output_type," Local to global map :",err,error,*999)
4781  DO ny=1,dofs_mapping%TOTAL_NUMBER_OF_LOCAL
4782  CALL write_string_value(diagnostic_output_type," Local dof = ",ny,err,error,*999)
4783  CALL write_string_value(diagnostic_output_type," Global dof = ", &
4784  & dofs_mapping%LOCAL_TO_GLOBAL_MAP(ny),err,error,*999)
4785  ENDDO !node_idx
4786  IF(diagnostics2) THEN
4787  CALL write_string(diagnostic_output_type," Internal dofs :",err,error,*999)
4788  CALL write_string_value(diagnostic_output_type," Number of internal dofs = ", &
4789  & dofs_mapping%NUMBER_OF_INTERNAL,err,error,*999)
4790  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%NUMBER_OF_INTERNAL,8,8, &
4791  & dofs_mapping%DOMAIN_LIST(dofs_mapping%INTERNAL_START:dofs_mapping%INTERNAL_FINISH), &
4792  & '(" Internal dofs:",8(X,I7))','(18X,8(X,I7))',err,error,*999)
4793  CALL write_string(diagnostic_output_type," Boundary dofs :",err,error,*999)
4794  CALL write_string_value(diagnostic_output_type," Number of boundary dofs = ", &
4795  & dofs_mapping%NUMBER_OF_BOUNDARY,err,error,*999)
4796  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%NUMBER_OF_BOUNDARY,8,8, &
4797  & dofs_mapping%DOMAIN_LIST(dofs_mapping%BOUNDARY_START:dofs_mapping%BOUNDARY_FINISH), &
4798  & '(" Boundary dofs:",8(X,I7))','(18X,8(X,I7))',err,error,*999)
4799  CALL write_string(diagnostic_output_type," Ghost dofs :",err,error,*999)
4800  CALL write_string_value(diagnostic_output_type," Number of ghost dofs = ", &
4801  & dofs_mapping%NUMBER_OF_GHOST,err,error,*999)
4802  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%NUMBER_OF_GHOST,8,8, &
4803  & dofs_mapping%DOMAIN_LIST(dofs_mapping%GHOST_START:dofs_mapping%GHOST_FINISH), &
4804  & '(" Ghost dofs :",8(X,I7))','(18X,8(X,I7))',err,error,*999)
4805  ENDIF
4806  CALL write_string(diagnostic_output_type," Adjacent domains :",err,error,*999)
4807  CALL write_string_value(diagnostic_output_type," Number of adjacent domains = ", &
4808  & dofs_mapping%NUMBER_OF_ADJACENT_DOMAINS,err,error,*999)
4809  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%NUMBER_OF_DOMAINS+1,8,8, &
4810  & dofs_mapping%ADJACENT_DOMAINS_PTR,'(" Adjacent domains ptr :",8(X,I7))','(27X,8(X,I7))',err,error,*999)
4811  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%ADJACENT_DOMAINS_PTR( &
4812  & dofs_mapping%NUMBER_OF_DOMAINS)-1,8,8,dofs_mapping%ADJACENT_DOMAINS_LIST, &
4813  '(" Adjacent domains list :",8(X,I7))','(27X,8(X,I7))',err,error,*999)
4814  DO domain_idx=1,dofs_mapping%NUMBER_OF_ADJACENT_DOMAINS
4815  CALL write_string_value(diagnostic_output_type," Adjacent domain idx : ",domain_idx,err,error,*999)
4816  CALL write_string_value(diagnostic_output_type," Domain number = ", &
4817  & dofs_mapping%ADJACENT_DOMAINS(domain_idx)%DOMAIN_NUMBER,err,error,*999)
4818  CALL write_string_value(diagnostic_output_type," Number of send ghosts = ", &
4819  & dofs_mapping%ADJACENT_DOMAINS(domain_idx)%NUMBER_OF_SEND_GHOSTS,err,error,*999)
4820  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%ADJACENT_DOMAINS(domain_idx)% &
4821  & number_of_send_ghosts,6,6,dofs_mapping%ADJACENT_DOMAINS(domain_idx)%LOCAL_GHOST_SEND_INDICES, &
4822  & '(" Local send ghost indicies :",6(X,I7))','(39X,6(X,I7))',err,error,*999)
4823  CALL write_string_value(diagnostic_output_type," Number of recieve ghosts = ", &
4824  & dofs_mapping%ADJACENT_DOMAINS(domain_idx)%NUMBER_OF_RECEIVE_GHOSTS,err,error,*999)
4825  CALL write_string_vector(diagnostic_output_type,1,1,dofs_mapping%ADJACENT_DOMAINS(domain_idx)% &
4826  & number_of_receive_ghosts,6,6,dofs_mapping%ADJACENT_DOMAINS(domain_idx)%LOCAL_GHOST_RECEIVE_INDICES, &
4827  & '(" Local receive ghost indicies :",6(X,I7))','(39X,6(X,I7))',err,error,*999)
4828  ENDDO !domain_idx
4829  ENDIF
4830 
4831  exits("DOMAIN_MAPPINGS_NODES_DOFS_CALCULATE")
4832  RETURN
4833 999 IF(ALLOCATED(domains)) DEALLOCATE(domains)
4834  IF(ALLOCATED(all_domains)) DEALLOCATE(all_domains)
4835  IF(ALLOCATED(ghost_nodes)) DEALLOCATE(ghost_nodes)
4836  IF(ALLOCATED(number_internal_nodes)) DEALLOCATE(number_internal_nodes)
4837  IF(ALLOCATED(number_boundary_nodes)) DEALLOCATE(number_boundary_nodes)
4838  IF(ASSOCIATED(domain%MAPPINGS%NODES)) CALL domain_mappings_nodes_finalise(domain%MAPPINGS,dummy_err,dummy_error,*998)
4839 998 IF(ASSOCIATED(domain%MAPPINGS%DOFS)) CALL domain_mappings_dofs_finalise(domain%MAPPINGS,dummy_err,dummy_error,*997)
4840 997 errorsexits("DOMAIN_MAPPINGS_NODES_DOFS_CALCULATE",err,error)
4841  RETURN 1
4842  END SUBROUTINE domain_mappings_nodes_dofs_calculate
4843 
4844  !
4845  !================================================================================================================================
4846  !
4847 
4849  SUBROUTINE domain_mappings_nodes_finalise(DOMAIN_MAPPINGS,ERR,ERROR,*)
4850 
4851  !Argument variables
4852  TYPE(domain_mappings_type), POINTER :: domain_mappings
4853  INTEGER(INTG), INTENT(OUT) :: err
4854  TYPE(varying_string), INTENT(OUT) :: error
4855  !Local Variables
4856 
4857  enters("DOMAIN_MAPPINGS_NODES_FINALISE",err,error,*999)
4858 
4859  IF(ASSOCIATED(domain_mappings)) THEN
4860  IF(ASSOCIATED(domain_mappings%NODES)) THEN
4861  CALL domain_mappings_mapping_finalise(domain_mappings%NODES,err,error,*999)
4862  ENDIF
4863  ELSE
4864  CALL flagerror("Domain mapping is not associated.",err,error,*999)
4865  ENDIF
4866 
4867  exits("DOMAIN_MAPPINGS_NODES_FINALISE")
4868  RETURN
4869 999 errorsexits("DOMAIN_MAPPINGS_NODES_FINALISE",err,error)
4870  RETURN 1
4871 
4872  END SUBROUTINE domain_mappings_nodes_finalise
4873 
4874  !
4875  !================================================================================================================================
4876  !
4877 
4879  SUBROUTINE domain_mappings_nodes_initialise(DOMAIN_MAPPINGS,ERR,ERROR,*)
4880 
4881  !Argument variables
4882  TYPE(domain_mappings_type), POINTER :: domain_mappings
4883  INTEGER(INTG), INTENT(OUT) :: err
4884  TYPE(varying_string), INTENT(OUT) :: error
4885  !Local Variables
4886 
4887  enters("DOMAIN_MAPPINGS_NODES_INITIALISE",err,error,*999)
4888 
4889  IF(ASSOCIATED(domain_mappings)) THEN
4890  IF(ASSOCIATED(domain_mappings%NODES)) THEN
4891  CALL flagerror("Domain nodes mappings are already associated.",err,error,*999)
4892  ELSE
4893  ALLOCATE(domain_mappings%NODES,stat=err)
4894  IF(err/=0) CALL flagerror("Could not allocate domain mappings nodes.",err,error,*999)
4895  CALL domain_mappings_mapping_initialise(domain_mappings%NODES,domain_mappings%DOMAIN%DECOMPOSITION%NUMBER_OF_DOMAINS, &
4896  & err,error,*999)
4897  ENDIF
4898  ELSE
4899  CALL flagerror("Domain mapping is not associated.",err,error,*999)
4900  ENDIF
4901 
4902  exits("DOMAIN_MAPPINGS_NODES_INITIALISE")
4903  RETURN
4904 999 errorsexits("DOMAIN_MAPPINGS_NODES_INITIALISE",err,error)
4905  RETURN 1
4906 
4907  END SUBROUTINE domain_mappings_nodes_initialise
4908 
4909  !
4910  !================================================================================================================================
4911  !
4912 
4914  SUBROUTINE domain_topology_calculate(TOPOLOGY,ERR,ERROR,*)
4915 
4916  !Argument variables
4917  TYPE(domain_topology_type), POINTER :: topology
4918  INTEGER(INTG), INTENT(OUT) :: err
4919  TYPE(varying_string), INTENT(OUT) :: error
4920  !Local Variables
4921  INTEGER(INTG) :: ne,np
4922  TYPE(basis_type), POINTER :: basis
4923 
4924  enters("DOMAIN_TOPOLOGY_CALCULATE",err,error,*999)
4925 
4926  IF(ASSOCIATED(topology)) THEN
4927  !Find maximum number of element parameters for all elements in the domain toplogy
4928  topology%ELEMENTS%MAXIMUM_NUMBER_OF_ELEMENT_PARAMETERS=-1
4929  DO ne=1,topology%ELEMENTS%TOTAL_NUMBER_OF_ELEMENTS
4930  basis=>topology%ELEMENTS%ELEMENTS(ne)%BASIS
4931  IF(ASSOCIATED(basis)) THEN
4932  IF(basis%NUMBER_OF_ELEMENT_PARAMETERS>topology%ELEMENTS%MAXIMUM_NUMBER_OF_ELEMENT_PARAMETERS) &
4933  & topology%ELEMENTS%MAXIMUM_NUMBER_OF_ELEMENT_PARAMETERS=basis%NUMBER_OF_ELEMENT_PARAMETERS
4934  ELSE
4935  CALL flagerror("Basis is not associated.",err,error,*999)
4936  ENDIF
4937  ENDDO !ne
4938  !Find maximum number of derivatives for all nodes in the domain toplogy
4939  topology%NODES%MAXIMUM_NUMBER_OF_DERIVATIVES=-1
4940  DO np=1,topology%NODES%TOTAL_NUMBER_OF_NODES
4941  IF(topology%NODES%NODES(np)%NUMBER_OF_DERIVATIVES>topology%NODES%MAXIMUM_NUMBER_OF_DERIVATIVES) &
4942  & topology%NODES%MAXIMUM_NUMBER_OF_DERIVATIVES=topology%NODES%NODES(np)%NUMBER_OF_DERIVATIVES
4943  ENDDO !np
4944  !Calculate the elements surrounding the nodes in the domain topology
4945  CALL domaintopology_nodessurroundingelementscalculate(topology,err,error,*999)
4946  ELSE
4947  CALL flagerror("Topology is not associated.",err,error,*999)
4948  ENDIF
4949 
4950  exits("DOMAIN_TOPOLOGY_CALCULATE")
4951  RETURN
4952 999 errorsexits("DOMAIN_TOPOLOGY_CALCULATE",err,error)
4953  RETURN 1
4954  END SUBROUTINE domain_topology_calculate
4955 
4956  !
4957  !================================================================================================================================
4958  !
4959 
4961  SUBROUTINE domain_topology_initialise_from_mesh(DOMAIN,ERR,ERROR,*)
4962 
4963  !Argument variables
4964  TYPE(domain_type), POINTER :: domain
4965  INTEGER(INTG), INTENT(OUT) :: err
4966  TYPE(varying_string), INTENT(OUT) :: error
4967  !Local Variables
4968  INTEGER(INTG) :: local_element,global_element,local_node,global_node,version_idx,derivative_idx,node_idx,dof_idx, &
4969  & component_idx
4970  INTEGER(INTG) :: ne,nn,nkk,insert_status
4971  LOGICAL :: found
4972  TYPE(basis_type), POINTER :: basis
4973  TYPE(mesh_type), POINTER :: mesh
4974  TYPE(domain_elements_type), POINTER :: domain_elements
4975  TYPE(meshelementstype), POINTER :: mesh_elements
4976  TYPE(domain_nodes_type), POINTER :: domain_nodes
4977  TYPE(meshnodestype), POINTER :: mesh_nodes
4978  TYPE(domain_dofs_type), POINTER :: domain_dofs
4979 
4980  enters("DOMAIN_TOPOLOGY_INITIALISE_FROM_MESH",err,error,*999)
4981 
4982  IF(ASSOCIATED(domain)) THEN
4983  IF(ASSOCIATED(domain%TOPOLOGY)) THEN
4984  IF(ASSOCIATED(domain%MAPPINGS)) THEN
4985  IF(ASSOCIATED(domain%MESH)) THEN
4986  mesh=>domain%MESH
4987  component_idx=domain%MESH_COMPONENT_NUMBER
4988  IF(ASSOCIATED(mesh%TOPOLOGY(component_idx)%PTR)) THEN
4989  mesh_elements=>mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS
4990  domain_elements=>domain%TOPOLOGY%ELEMENTS
4991  mesh_nodes=>mesh%TOPOLOGY(component_idx)%PTR%NODES
4992  domain_nodes=>domain%TOPOLOGY%NODES
4993  domain_dofs=>domain%TOPOLOGY%DOFS
4994  ALLOCATE(domain_elements%ELEMENTS(domain%MAPPINGS%ELEMENTS%TOTAL_NUMBER_OF_LOCAL),stat=err)
4995  IF(err/=0) CALL flagerror("Could not allocate domain elements elements.",err,error,*999)
4996  domain_elements%NUMBER_OF_ELEMENTS=domain%MAPPINGS%ELEMENTS%NUMBER_OF_LOCAL
4997  domain_elements%TOTAL_NUMBER_OF_ELEMENTS=domain%MAPPINGS%ELEMENTS%TOTAL_NUMBER_OF_LOCAL
4998  domain_elements%NUMBER_OF_GLOBAL_ELEMENTS=domain%MAPPINGS%ELEMENTS%NUMBER_OF_GLOBAL
4999  ALLOCATE(domain_nodes%NODES(domain%MAPPINGS%NODES%TOTAL_NUMBER_OF_LOCAL),stat=err)
5000  IF(err/=0) CALL flagerror("Could not allocate domain nodes nodes.",err,error,*999)
5001  domain_nodes%NUMBER_OF_NODES=domain%MAPPINGS%NODES%NUMBER_OF_LOCAL
5002  domain_nodes%TOTAL_NUMBER_OF_NODES=domain%MAPPINGS%NODES%TOTAL_NUMBER_OF_LOCAL
5003  domain_nodes%NUMBER_OF_GLOBAL_NODES=domain%MAPPINGS%NODES%NUMBER_OF_GLOBAL
5004  ALLOCATE(domain_dofs%DOF_INDEX(3,domain%MAPPINGS%DOFS%TOTAL_NUMBER_OF_LOCAL),stat=err)
5005  IF(err/=0) CALL flagerror("Could not allocate domain dofs dof index.",err,error,*999)
5006  domain_dofs%NUMBER_OF_DOFS=domain%MAPPINGS%DOFS%NUMBER_OF_LOCAL
5007  domain_dofs%TOTAL_NUMBER_OF_DOFS=domain%MAPPINGS%DOFS%TOTAL_NUMBER_OF_LOCAL
5008  domain_dofs%NUMBER_OF_GLOBAL_DOFS=domain%MAPPINGS%DOFS%NUMBER_OF_GLOBAL
5009  !Loop over the domain nodes and calculate the parameters from the mesh nodes
5010  CALL tree_create_start(domain_nodes%NODES_TREE,err,error,*999)
5011  CALL tree_insert_type_set(domain_nodes%NODES_TREE,tree_no_duplicates_allowed,err,error,*999)
5012  CALL tree_create_finish(domain_nodes%NODES_TREE,err,error,*999)
5013  dof_idx=0
5014  DO local_node=1,domain_nodes%TOTAL_NUMBER_OF_NODES
5015  CALL domain_topology_node_initialise(domain_nodes%NODES(local_node),err,error,*999)
5016  global_node=domain%MAPPINGS%NODES%LOCAL_TO_GLOBAL_MAP(local_node)
5017  domain_nodes%NODES(local_node)%LOCAL_NUMBER=local_node
5018  domain_nodes%NODES(local_node)%MESH_NUMBER=global_node
5019  domain_nodes%NODES(local_node)%GLOBAL_NUMBER=mesh_nodes%NODES(global_node)%globalNumber
5020  domain_nodes%NODES(local_node)%USER_NUMBER=mesh_nodes%NODES(global_node)%userNumber
5021  CALL tree_item_insert(domain_nodes%NODES_TREE,domain_nodes%NODES(local_node)%USER_NUMBER,local_node, &
5022  & insert_status,err,error,*999)
5023  domain_nodes%NODES(local_node)%NUMBER_OF_SURROUNDING_ELEMENTS=0
5024  NULLIFY(domain_nodes%NODES(local_node)%SURROUNDING_ELEMENTS)
5025  domain_nodes%NODES(local_node)%NUMBER_OF_DERIVATIVES=mesh_nodes%NODES(global_node)%numberOfDerivatives
5026  ALLOCATE(domain_nodes%NODES(local_node)%DERIVATIVES(mesh_nodes%NODES(global_node)%numberOfDerivatives),stat=err)
5027  IF(err/=0) CALL flagerror("Could not allocate domain node derivatives.",err,error,*999)
5028  DO derivative_idx=1,domain_nodes%NODES(local_node)%NUMBER_OF_DERIVATIVES
5029  CALL domain_topology_node_derivative_initialise( &
5030  & domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx),err,error,*999)
5031  domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%GLOBAL_DERIVATIVE_INDEX= &
5032  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%globalDerivativeIndex
5033  domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%PARTIAL_DERIVATIVE_INDEX= &
5034  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%partialDerivativeIndex
5035  domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%numberOfVersions= &
5036  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%numberOfVersions
5037  ALLOCATE(domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%userVersionNumbers( &
5038  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%numberOfVersions),stat=err)
5039  IF(err/=0) CALL flagerror("Could not allocate node derivative version numbers.",err,error,*999)
5040  domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%userVersionNumbers(1: &
5041  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%numberOfVersions)= &
5042  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%userVersionNumbers(1: &
5043  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%numberOfVersions)
5044  ALLOCATE(domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%DOF_INDEX( &
5045  & mesh_nodes%NODES(global_node)%DERIVATIVES(derivative_idx)%numberOfVersions),stat=err)
5046  IF(err/=0) CALL flagerror("Could not allocate node dervative versions dof index.",err,error,*999)
5047  DO version_idx=1,domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%numberOfVersions
5048  dof_idx=dof_idx+1
5049  domain_nodes%NODES(local_node)%DERIVATIVES(derivative_idx)%DOF_INDEX(version_idx)=dof_idx
5050  domain_dofs%DOF_INDEX(1,dof_idx)=version_idx
5051  domain_dofs%DOF_INDEX(2,dof_idx)=derivative_idx
5052  domain_dofs%DOF_INDEX(3,dof_idx)=local_node
5053  ENDDO !version_idx
5054  ENDDO !derivative_idx
5055  domain_nodes%NODES(local_node)%BOUNDARY_NODE=mesh_nodes%NODES(global_node)%boundaryNode
5056  ENDDO !local_node
5057  !Loop over the domain elements and renumber from the mesh elements
5058  DO local_element=1,domain_elements%TOTAL_NUMBER_OF_ELEMENTS
5059  CALL domain_topology_element_initialise(domain_elements%ELEMENTS(local_element),err,error,*999)
5060  global_element=domain%MAPPINGS%ELEMENTS%LOCAL_TO_GLOBAL_MAP(local_element)
5061  basis=>mesh_elements%ELEMENTS(global_element)%BASIS
5062  domain_elements%ELEMENTS(local_element)%NUMBER=local_element
5063  domain_elements%ELEMENTS(local_element)%BASIS=>basis
5064  ALLOCATE(domain_elements%ELEMENTS(local_element)%ELEMENT_NODES(basis%NUMBER_OF_NODES),stat=err)
5065  IF(err/=0) CALL flagerror("Could not allocate domain elements element nodes.",err,error,*999)
5066  ALLOCATE(domain_elements%ELEMENTS(local_element)%ELEMENT_DERIVATIVES(basis%MAXIMUM_NUMBER_OF_DERIVATIVES, &
5067  & basis%NUMBER_OF_NODES),stat=err)
5068  IF(err/=0) CALL flagerror("Could not allocate domain elements element derivatives.",err,error,*999)
5069  ALLOCATE(domain_elements%ELEMENTS(local_element)%elementVersions(basis%MAXIMUM_NUMBER_OF_DERIVATIVES, &
5070  & basis%NUMBER_OF_NODES),stat=err)
5071  IF(err/=0) CALL flagerror("Could not allocate domain elements element versions.",err,error,*999)
5072  DO nn=1,basis%NUMBER_OF_NODES
5073  global_node=mesh_elements%ELEMENTS(global_element)%MESH_ELEMENT_NODES(nn)
5074  local_node=domain%MAPPINGS%NODES%GLOBAL_TO_LOCAL_MAP(global_node)%LOCAL_NUMBER(1)
5075  domain_elements%ELEMENTS(local_element)%ELEMENT_NODES(nn)=local_node
5076  DO derivative_idx=1,basis%NUMBER_OF_DERIVATIVES(nn)
5077  !Find equivalent node derivative by matching partial derivative index
5078  !/todo Take a look at this - is it needed any more?
5079  found=.false.
5080  DO nkk=1,domain_nodes%NODES(local_node)%NUMBER_OF_DERIVATIVES
5081  IF(domain_nodes%NODES(local_node)%DERIVATIVES(nkk)%PARTIAL_DERIVATIVE_INDEX == &
5082  & basis%PARTIAL_DERIVATIVE_INDEX(derivative_idx,nn)) THEN
5083  found=.true.
5084  EXIT
5085  ENDIF
5086  ENDDO !nkk
5087  IF(found) THEN
5088  domain_elements%ELEMENTS(local_element)%ELEMENT_DERIVATIVES(derivative_idx,nn)=nkk
5089  domain_elements%ELEMENTS(local_element)%elementVersions(derivative_idx,nn) = &
5090  & mesh_elements%ELEMENTS(global_element)%USER_ELEMENT_NODE_VERSIONS(derivative_idx,nn)
5091  ELSE
5092  CALL flagerror("Could not find equivalent node derivative",err,error,*999)
5093  ENDIF
5094  ENDDO !derivative_idx
5095  ENDDO !nn
5096  ENDDO !local_element
5097  ELSE
5098  CALL flagerror("Mesh topology is not associated",err,error,*999)
5099  ENDIF
5100  ELSE
5101  CALL flagerror("Mesh is not associated",err,error,*999)
5102 
5103  ENDIF
5104  ELSE
5105  CALL flagerror("Domain mapping is not associated",err,error,*999)
5106  ENDIF
5107  ELSE
5108  CALL flagerror("Domain topology is not associated",err,error,*999)
5109  ENDIF
5110  ELSE
5111  CALL flagerror("Domain is not associated",err,error,*999)
5112  ENDIF
5113 
5114  IF(diagnostics1) THEN
5115  CALL write_string(diagnostic_output_type,"Initialised domain topology :",err,error,*999)
5116  CALL write_string_value(diagnostic_output_type," Total number of domain nodes = ",domain_nodes%TOTAL_NUMBER_OF_NODES, &
5117  & err,error,*999)
5118  DO node_idx=1,domain_nodes%TOTAL_NUMBER_OF_NODES
5119  CALL write_string_value(diagnostic_output_type," Node number = ",domain_nodes%NODES(node_idx)%LOCAL_NUMBER, &
5120  & err,error,*999)
5121  CALL write_string_value(diagnostic_output_type," Node mesh number = ",domain_nodes%NODES(node_idx)%MESH_NUMBER, &
5122  & err,error,*999)
5123  CALL write_string_value(diagnostic_output_type," Node global number = ",domain_nodes%NODES(node_idx)%GLOBAL_NUMBER, &
5124  & err,error,*999)
5125  CALL write_string_value(diagnostic_output_type," Node user number = ",domain_nodes%NODES(node_idx)%USER_NUMBER, &
5126  & err,error,*999)
5127  CALL write_string_value(diagnostic_output_type," Number of derivatives = ", &
5128  & domain_nodes%NODES(node_idx)%NUMBER_OF_DERIVATIVES,err,error,*999)
5129  DO derivative_idx=1,domain_nodes%NODES(local_node)%NUMBER_OF_DERIVATIVES
5130  CALL write_string_value(diagnostic_output_type," Node local derivative number = ",derivative_idx,err,error,*999)
5131  CALL write_string_value(diagnostic_output_type," Global derivative index = ", &
5132  & domain_nodes%NODES(node_idx)%DERIVATIVES(derivative_idx)%GLOBAL_DERIVATIVE_INDEX,err,error,*999)
5133  CALL write_string_value(diagnostic_output_type," Partial derivative index = ", &
5134  & domain_nodes%NODES(node_idx)%DERIVATIVES(derivative_idx)%PARTIAL_DERIVATIVE_INDEX,err,error,*999)
5135  CALL write_string_vector(diagnostic_output_type,1,1, &
5136  & domain_nodes%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions,4,4, &
5137  & domain_nodes%NODES(node_idx)%DERIVATIVES(derivative_idx)%DOF_INDEX, &
5138  & '(" Degree-of-freedom index(version_idx) :",4(X,I9))','(36X,4(X,I9))',err,error,*999)
5139  ENDDO !derivative_idx
5140  CALL write_string_value(diagnostic_output_type," Boundary node = ", &
5141  & domain_nodes%NODES(node_idx)%BOUNDARY_NODE,err,error,*999)
5142  ENDDO !node_idx
5143  CALL write_string_value(diagnostic_output_type," Total Number of domain dofs = ",domain_dofs%TOTAL_NUMBER_OF_DOFS, &
5144  & err,error,*999)
5145  DO dof_idx=1,domain_dofs%TOTAL_NUMBER_OF_DOFS
5146  CALL write_string_value(diagnostic_output_type," Dof number = ",dof_idx,err,error,*999)
5147  CALL write_string_vector(diagnostic_output_type,1,1,3,3,3, &
5148  & domain_dofs%DOF_INDEX(:,dof_idx),'(" Degree-of-freedom index :",3(X,I9))','(29X,3(X,I9))', &
5149  & err,error,*999)
5150  ENDDO !dof_idx
5151  CALL write_string_value(diagnostic_output_type," Total number of domain elements = ", &
5152  & domain_elements%TOTAL_NUMBER_OF_ELEMENTS,err,error,*999)
5153  DO ne=1,domain_elements%TOTAL_NUMBER_OF_ELEMENTS
5154  CALL write_string_value(diagnostic_output_type," Element number = ",domain_elements%ELEMENTS(ne)%NUMBER,err,error,*999)
5155  CALL write_string_value(diagnostic_output_type," Basis user number = ", &
5156  & domain_elements%ELEMENTS(ne)%BASIS%USER_NUMBER,err,error,*999)
5157  CALL write_string_value(diagnostic_output_type," Number of local nodes = ", &
5158  & domain_elements%ELEMENTS(ne)%BASIS%NUMBER_OF_NODES,err,error,*999)
5159  CALL write_string_vector(diagnostic_output_type,1,1,domain_elements%ELEMENTS(ne)%BASIS%NUMBER_OF_NODES,8,8, &
5160  & domain_elements%ELEMENTS(ne)%ELEMENT_NODES,'(" Element nodes(nn) :",8(X,I9))','(23X,8(X,I9))', &
5161  & err,error,*999)
5162  DO nn=1,domain_elements%ELEMENTS(ne)%BASIS%NUMBER_OF_NODES
5163  CALL write_string_value(diagnostic_output_type," Local node number : ",nn,err,error,*999)
5164  CALL write_string_vector(diagnostic_output_type,1,1,domain_elements%ELEMENTS(ne)%BASIS%NUMBER_OF_DERIVATIVES(nn),8,8, &
5165  & domain_elements%ELEMENTS(ne)%ELEMENT_DERIVATIVES(:,nn), &
5166  & '(" Element derivatives :",8(X,I2))','(29X,8(X,I2))',err,error,*999)
5167  CALL write_string_vector(diagnostic_output_type,1,1,domain_elements%ELEMENTS(ne)%BASIS%NUMBER_OF_DERIVATIVES(nn),8,8, &
5168  & domain_elements%ELEMENTS(ne)%elementVersions(:,nn), &
5169  & '(" Element versions :",8(X,I2))','(29X,8(X,I2))',err,error,*999)
5170  ENDDO !nn
5171  ENDDO !ne
5172  ENDIF
5173 
5174  exits("DOMAIN_TOPOLOGY_INITIALISE_FROM_MESH")
5175  RETURN
5176 999 errorsexits("DOMAIN_TOPOLOGY_INITIALISE_FROM_MESH",err,error)
5177  RETURN 1
5178  END SUBROUTINE domain_topology_initialise_from_mesh
5179 
5180  !
5181  !================================================================================================================================
5182  !
5183 
5185  SUBROUTINE domain_topology_dofs_finalise(TOPOLOGY,ERR,ERROR,*)
5186 
5187  !Argument variables
5188  TYPE(domain_topology_type), POINTER :: topology
5189  INTEGER(INTG), INTENT(OUT) :: err
5190  TYPE(varying_string), INTENT(OUT) :: error
5191  !Local Variables
5192 
5193  enters("DOMAIN_TOPOLOGY_DOFS_FINALISE",err,error,*999)
5194 
5195  IF(ASSOCIATED(topology)) THEN
5196  IF(ASSOCIATED(topology%DOFS)) THEN
5197  IF(ALLOCATED(topology%DOFS%DOF_INDEX)) DEALLOCATE(topology%DOFS%DOF_INDEX)
5198  DEALLOCATE(topology%DOFS)
5199  ENDIF
5200  ELSE
5201  CALL flagerror("Topology is not associated",err,error,*999)
5202  ENDIF
5203 
5204  exits("DOMAIN_TOPOLOGY_DOFS_FINALISE")
5205  RETURN
5206 999 errorsexits("DOMAIN_TOPOLOGY_DOFS_FINALISE",err,error)
5207  RETURN 1
5208 
5209  END SUBROUTINE domain_topology_dofs_finalise
5210 
5211  !
5212  !================================================================================================================================
5213  !
5214 
5216  SUBROUTINE domain_topology_dofs_initialise(TOPOLOGY,ERR,ERROR,*)
5217 
5218  !Argument variables
5219  TYPE(domain_topology_type), POINTER :: topology
5220  INTEGER(INTG), INTENT(OUT) :: err
5221  TYPE(varying_string), INTENT(OUT) :: error
5222  !Local Variables
5223 
5224  enters("DOMAIN_TOPOLOGY_DOFS_INITIALISE",err,error,*999)
5225 
5226  IF(ASSOCIATED(topology)) THEN
5227  IF(ASSOCIATED(topology%DOFS)) THEN
5228  CALL flagerror("Decomposition already has topology dofs associated",err,error,*999)
5229  ELSE
5230  ALLOCATE(topology%DOFS,stat=err)
5231  IF(err/=0) CALL flagerror("Could not allocate topology dofs",err,error,*999)
5232  topology%DOFS%NUMBER_OF_DOFS=0
5233  topology%DOFS%TOTAL_NUMBER_OF_DOFS=0
5234  topology%DOFS%NUMBER_OF_GLOBAL_DOFS=0
5235  topology%DOFS%DOMAIN=>topology%DOMAIN
5236  ENDIF
5237  ELSE
5238  CALL flagerror("Topology is not associated",err,error,*999)
5239  ENDIF
5240 
5241  exits("DOMAIN_TOPOLOGY_DOFS_INITIALISE")
5242  RETURN
5243 999 errorsexits("DOMAIN_TOPOLOGY_DOFS_INITIALISE",err,error)
5244  RETURN 1
5245  END SUBROUTINE domain_topology_dofs_initialise
5246 
5247  !
5248  !================================================================================================================================
5249  !
5250 
5252  SUBROUTINE domain_topology_element_finalise(ELEMENT,ERR,ERROR,*)
5253 
5254  !Argument variables
5255  TYPE(domain_element_type) :: element
5256  INTEGER(INTG), INTENT(OUT) :: err
5257  TYPE(varying_string), INTENT(OUT) :: error
5258  !Local Variables
5259 
5260  enters("DOMAIN_TOPOLOGY_ELEMENT_FINALISE",err,error,*999)
5261 
5262  IF(ALLOCATED(element%ELEMENT_NODES)) DEALLOCATE(element%ELEMENT_NODES)
5263  IF(ALLOCATED(element%ELEMENT_DERIVATIVES)) DEALLOCATE(element%ELEMENT_DERIVATIVES)
5264  IF(ALLOCATED(element%elementVersions)) DEALLOCATE(element%elementVersions)
5265 
5266  exits("DOMAIN_TOPOLOGY_ELEMENT_FINALISE")
5267  RETURN
5268 999 errorsexits("DOMAIN_TOPOLOGY_ELEMENT_FINALISE",err,error)
5269  RETURN 1
5270 
5271  END SUBROUTINE domain_topology_element_finalise
5272 
5273  !
5274  !================================================================================================================================
5275  !
5276 
5278  SUBROUTINE domain_topology_element_initialise(ELEMENT,ERR,ERROR,*)
5279 
5280  !Argument variables
5281  TYPE(domain_element_type) :: element
5282  INTEGER(INTG), INTENT(OUT) :: err
5283  TYPE(varying_string), INTENT(OUT) :: error
5284  !Local Variables
5285 
5286  enters("DOMAIN_TOPOLOGY_ELEMENT_INITIALISE",err,error,*999)
5287 
5288  element%NUMBER=0
5289  NULLIFY(element%BASIS)
5290 
5291  exits("DOMAIN_TOPOLOGY_ELEMENT_INITALISE")
5292  RETURN
5293 999 errorsexits("DOMAIN_TOPOLOGY_ELEMENT_INITALISE",err,error)
5294  RETURN 1
5295 
5296  END SUBROUTINE domain_topology_element_initialise
5297 
5298  !
5299  !================================================================================================================================
5300  !
5301 
5303  SUBROUTINE domain_topology_elements_finalise(TOPOLOGY,ERR,ERROR,*)
5304 
5305  !Argument variables
5306  TYPE(domain_topology_type), POINTER :: topology
5307  INTEGER(INTG), INTENT(OUT) :: err
5308  TYPE(varying_string), INTENT(OUT) :: error
5309  !Local Variables
5310  INTEGER(INTG) :: ne
5311 
5312  enters("DOMAIN_TOPOLOGY_ELEMENTS_FINALISE",err,error,*999)
5313 
5314  IF(ASSOCIATED(topology)) THEN
5315  IF(ASSOCIATED(topology%ELEMENTS)) THEN
5316  DO ne=1,topology%ELEMENTS%TOTAL_NUMBER_OF_ELEMENTS
5317  CALL domain_topology_element_finalise(topology%ELEMENTS%ELEMENTS(ne),err,error,*999)
5318  ENDDO !ne
5319  IF(ASSOCIATED(topology%ELEMENTS%ELEMENTS)) DEALLOCATE(topology%ELEMENTS%ELEMENTS)
5320  DEALLOCATE(topology%ELEMENTS)
5321  ENDIF
5322  ELSE
5323  CALL flagerror("Topology is not associated",err,error,*999)
5324  ENDIF
5325 
5326  exits("DOMAIN_TOPOLOGY_ELEMENTS_FINALISE")
5327  RETURN
5328 999 errorsexits("DOMAIN_TOPOLOGY_ELEMENTS_FINALISE",err,error)
5329  RETURN 1
5330 
5331  END SUBROUTINE domain_topology_elements_finalise
5332 
5333  !
5334  !================================================================================================================================
5335  !
5336 
5338  SUBROUTINE domain_topology_elements_initialise(TOPOLOGY,ERR,ERROR,*)
5339 
5340  !Argument variables
5341  TYPE(domain_topology_type), POINTER :: topology
5342  INTEGER(INTG), INTENT(OUT) :: err
5343  TYPE(varying_string), INTENT(OUT) :: error
5344  !Local Variables
5345 
5346  enters("DOMAIN_TOPOLOGY_ELEMENTS_INITIALISE",err,error,*999)
5347 
5348  IF(ASSOCIATED(topology)) THEN
5349  IF(ASSOCIATED(topology%ELEMENTS)) THEN
5350  CALL flagerror("Decomposition already has topology elements associated",err,error,*999)
5351  ELSE
5352  ALLOCATE(topology%ELEMENTS,stat=err)
5353  IF(err/=0) CALL flagerror("Could not allocate topology elements",err,error,*999)
5354  topology%ELEMENTS%NUMBER_OF_ELEMENTS=0
5355  topology%ELEMENTS%TOTAL_NUMBER_OF_ELEMENTS=0
5356  topology%ELEMENTS%NUMBER_OF_GLOBAL_ELEMENTS=0
5357  topology%ELEMENTS%DOMAIN=>topology%DOMAIN
5358  NULLIFY(topology%ELEMENTS%ELEMENTS)
5359  topology%ELEMENTS%MAXIMUM_NUMBER_OF_ELEMENT_PARAMETERS=0
5360  ENDIF
5361  ELSE
5362  CALL flagerror("Topology is not associated",err,error,*999)
5363  ENDIF
5364 
5365  exits("DOMAIN_TOPOLOGY_ELEMENTS_INITIALISE")
5366  RETURN
5367 999 errorsexits("DOMAIN_TOPOLOGY_ELEMENTS_INITIALISE",err,error)
5368  RETURN 1
5369  END SUBROUTINE domain_topology_elements_initialise
5370 
5371 
5372  !
5373  !================================================================================================================================
5374  !
5375 
5377  SUBROUTINE domain_topology_finalise(DOMAIN,ERR,ERROR,*)
5378 
5379  !Argument variables
5380  TYPE(domain_type), POINTER :: domain
5381  INTEGER(INTG), INTENT(OUT) :: err
5382  TYPE(varying_string), INTENT(OUT) :: error
5383  !Local Variables
5384 
5385  enters("DOMAIN_TOPOLOGY_FINALISE",err,error,*999)
5386 
5387  IF(ASSOCIATED(domain)) THEN
5388  CALL domain_topology_nodes_finalise(domain%TOPOLOGY,err,error,*999)
5389  CALL domain_topology_dofs_finalise(domain%TOPOLOGY,err,error,*999)
5390  CALL domain_topology_elements_finalise(domain%TOPOLOGY,err,error,*999)
5391  CALL domain_topology_lines_finalise(domain%TOPOLOGY,err,error,*999)
5392  CALL domain_topology_faces_finalise(domain%TOPOLOGY,err,error,*999)
5393  DEALLOCATE(domain%TOPOLOGY)
5394  ELSE
5395  CALL flagerror("Domain is not associated",err,error,*999)
5396  ENDIF
5397 
5398  exits("DOMAIN_TOPOLOGY_FINALISE")
5399  RETURN
5400 999 errorsexits("DOMAIN_TOPOLOGY_FINALISE",err,error)
5401  RETURN 1
5402 
5403  END SUBROUTINE domain_topology_finalise
5404 
5405  !
5406  !================================================================================================================================
5407  !
5408 
5410  SUBROUTINE domain_topology_initialise(DOMAIN,ERR,ERROR,*)
5411 
5412  !Argument variables
5413  TYPE(domain_type), POINTER :: domain !A pointer to the domain to initialise the topology for
5414  INTEGER(INTG), INTENT(OUT) :: err
5415  TYPE(varying_string), INTENT(OUT) :: error
5416  !Local Variables
5417 
5418  enters("DOMAIN_TOPOLOGY_INITIALISE",err,error,*999)
5419 
5420  IF(ASSOCIATED(domain)) THEN
5421  IF(ASSOCIATED(domain%TOPOLOGY)) THEN
5422  CALL flagerror("Domain already has topology associated",err,error,*999)
5423  ELSE
5424  !Allocate domain topology
5425  ALLOCATE(domain%TOPOLOGY,stat=err)
5426  IF(err/=0) CALL flagerror("Domain topology could not be allocated",err,error,*999)
5427  domain%TOPOLOGY%DOMAIN=>domain
5428  NULLIFY(domain%TOPOLOGY%ELEMENTS)
5429  NULLIFY(domain%TOPOLOGY%NODES)
5430  NULLIFY(domain%TOPOLOGY%DOFS)
5431  NULLIFY(domain%TOPOLOGY%LINES)
5432  NULLIFY(domain%TOPOLOGY%FACES)
5433  !Initialise the topology components
5434  CALL domain_topology_elements_initialise(domain%TOPOLOGY,err,error,*999)
5435  CALL domain_topology_nodes_initialise(domain%TOPOLOGY,err,error,*999)
5436  CALL domain_topology_dofs_initialise(domain%TOPOLOGY,err,error,*999)
5437  CALL domain_topology_lines_initialise(domain%TOPOLOGY,err,error,*999)
5438  CALL domain_topology_faces_initialise(domain%TOPOLOGY,err,error,*999)
5439  !Initialise the domain topology from the domain mappings and the mesh it came from
5440  CALL domain_topology_initialise_from_mesh(domain,err,error,*999)
5441  !Calculate the topological information.
5442  CALL domain_topology_calculate(domain%TOPOLOGY,err,error,*999)
5443  ENDIF
5444  ELSE
5445  CALL flagerror("Domain is not associated",err,error,*999)
5446  ENDIF
5447 
5448  exits("DOMAIN_TOPOLOGY_INITIALISE")
5449  RETURN
5450 999 errorsexits("DOMAIN_TOPOLOGY_INITIALISE",err,error)
5451  RETURN 1
5452  END SUBROUTINE domain_topology_initialise
5453 
5454  !
5455  !================================================================================================================================
5456  !
5457 
5459  SUBROUTINE domain_topology_line_finalise(LINE,ERR,ERROR,*)
5460 
5461  !Argument variables
5462  TYPE(domain_line_type) :: line
5463  INTEGER(INTG), INTENT(OUT) :: err
5464  TYPE(varying_string), INTENT(OUT) :: error
5465  !Local Variables
5466 
5467  enters("DOMAIN_TOPOLOGY_LINE_FINALISE",err,error,*999)
5468 
5469  line%NUMBER=0
5470  NULLIFY(line%BASIS)
5471  IF(ALLOCATED(line%NODES_IN_LINE)) DEALLOCATE(line%NODES_IN_LINE)
5472  IF(ALLOCATED(line%DERIVATIVES_IN_LINE)) DEALLOCATE(line%DERIVATIVES_IN_LINE)
5473 
5474  exits("DOMAIN_TOPOLOGY_LINE_FINALISE")
5475  RETURN
5476 999 errorsexits("DOMAIN_TOPOLOGY_LINE_FINALISE",err,error)
5477  RETURN 1
5478 
5479  END SUBROUTINE domain_topology_line_finalise
5480 
5481  !
5482  !================================================================================================================================
5483  !
5484 
5486  SUBROUTINE domain_topology_line_initialise(LINE,ERR,ERROR,*)
5487 
5488  !Argument variables
5489  TYPE(domain_line_type) :: line
5490  INTEGER(INTG), INTENT(OUT) :: err
5491  TYPE(varying_string), INTENT(OUT) :: error
5492  !Local Variables
5493 
5494  enters("DOMAIN_TOPOLOGY_LINE_INITIALISE",err,error,*999)
5495 
5496  line%NUMBER=0
5497  NULLIFY(line%BASIS)
5498  line%BOUNDARY_LINE=.false.
5499 
5500  exits("DOMAIN_TOPOLOGY_LINE_INITIALISE")
5501  RETURN
5502 999 errorsexits("DOMAIN_TOPOLOGY_LINE_INITIALISE",err,error)
5503  RETURN 1
5504  END SUBROUTINE domain_topology_line_initialise
5505 
5506  !
5507  !================================================================================================================================
5508  !
5509 
5511  SUBROUTINE domain_topology_lines_finalise(TOPOLOGY,ERR,ERROR,*)
5512 
5513  !Argument variables
5514  TYPE(domain_topology_type), POINTER :: topology
5515  INTEGER(INTG), INTENT(OUT) :: err
5516  TYPE(varying_string), INTENT(OUT) :: error
5517  !Local Variables
5518  INTEGER(INTG) :: nl
5519 
5520  enters("DOMAIN_TOPOLOGY_LINES_FINALISE",err,error,*999)
5521 
5522  IF(ASSOCIATED(topology)) THEN
5523  IF(ASSOCIATED(topology%LINES)) THEN
5524  DO nl=1,topology%LINES%NUMBER_OF_LINES
5525  CALL domain_topology_line_finalise(topology%LINES%LINES(nl),err,error,*999)
5526  ENDDO !nl
5527  IF(ALLOCATED(topology%LINES%LINES)) DEALLOCATE(topology%LINES%LINES)
5528  DEALLOCATE(topology%LINES)
5529  ENDIF
5530  ELSE
5531  CALL flagerror("Topology is not associated",err,error,*999)
5532  ENDIF
5533 
5534  exits("DOMAIN_TOPOLOGY_LINES_FINALISE")
5535  RETURN
5536 999 errorsexits("DOMAIN_TOPOLOGY_LINES_FINALISE",err,error)
5537  RETURN 1
5538 
5539  END SUBROUTINE domain_topology_lines_finalise
5540 
5541  !
5542  !================================================================================================================================
5543  !
5544 
5546  SUBROUTINE domain_topology_lines_initialise(TOPOLOGY,ERR,ERROR,*)
5547 
5548  !Argument variables
5549  TYPE(domain_topology_type), POINTER :: topology
5550  INTEGER(INTG), INTENT(OUT) :: err
5551  TYPE(varying_string), INTENT(OUT) :: error
5552  !Local Variables
5553 
5554  enters("DOMAIN_TOPOLOGY_LINES_INITIALISE",err,error,*999)
5555 
5556  IF(ASSOCIATED(topology)) THEN
5557  IF(ASSOCIATED(topology%LINES)) THEN
5558  CALL flagerror("Decomposition already has topology lines associated",err,error,*999)
5559  ELSE
5560  ALLOCATE(topology%LINES,stat=err)
5561  IF(err/=0) CALL flagerror("Could not allocate topology lines",err,error,*999)
5562  topology%LINES%NUMBER_OF_LINES=0
5563  topology%LINES%DOMAIN=>topology%DOMAIN
5564  ENDIF
5565  ELSE
5566  CALL flagerror("Topology is not associated",err,error,*999)
5567  ENDIF
5568 
5569  exits("DOMAIN_TOPOLOGY_LINES_INITIALISE")
5570  RETURN
5571 999 errorsexits("DOMAIN_TOPOLOGY_LINES_INITIALISE",err,error)
5572  RETURN 1
5573  END SUBROUTINE domain_topology_lines_initialise
5574 
5575  !
5576  !================================================================================================================================
5577  !
5579  SUBROUTINE domain_topology_face_finalise(FACE,ERR,ERROR,*)
5580 
5581  !Argument variables
5582  TYPE(domain_face_type) :: face
5583  INTEGER(INTG), INTENT(OUT) :: err
5584  TYPE(varying_string), INTENT(OUT) :: error
5585  !Local Variables
5586 
5587  enters("DOMAIN_TOPOLOGY_FACE_FINALISE",err,error,*999)
5588 
5589  face%NUMBER=0
5590  NULLIFY(face%BASIS)
5591  IF(ALLOCATED(face%NODES_IN_FACE)) DEALLOCATE(face%NODES_IN_FACE)
5592  IF(ALLOCATED(face%DERIVATIVES_IN_FACE)) DEALLOCATE(face%DERIVATIVES_IN_FACE)
5593 
5594  exits("DOMAIN_TOPOLOGY_FACE_FINALISE")
5595  RETURN
5596 999 errorsexits("DOMAIN_TOPOLOGY_FACE_FINALISE",err,error)
5597  RETURN 1
5598 
5599  END SUBROUTINE domain_topology_face_finalise
5600 
5601  !
5602  !================================================================================================================================
5603  !
5604 
5606  SUBROUTINE domain_topology_face_initialise(FACE,ERR,ERROR,*)
5607 
5608  !Argument variables
5609  TYPE(domain_face_type) :: face
5610  INTEGER(INTG), INTENT(OUT) :: err
5611  TYPE(varying_string), INTENT(OUT) :: error
5612  !Local Variables
5613 
5614  enters("DOMAIN_TOPOLOGY_FACE_INITIALISE",err,error,*999)
5615 
5616  face%NUMBER=0
5617  NULLIFY(face%BASIS)
5618  face%BOUNDARY_FACE=.false.
5619 
5620  exits("DOMAIN_TOPOLOGY_FACE_INITIALISE")
5621  RETURN
5622 999 errorsexits("DOMAIN_TOPOLOGY_FACE_INITIALISE",err,error)
5623  RETURN 1
5624  END SUBROUTINE domain_topology_face_initialise
5625 
5626  !
5627  !================================================================================================================================
5628  !
5629 
5631  SUBROUTINE domain_topology_faces_finalise(TOPOLOGY,ERR,ERROR,*)
5632 
5633  !Argument variables
5634  TYPE(domain_topology_type), POINTER :: topology
5635  INTEGER(INTG), INTENT(OUT) :: err
5636  TYPE(varying_string), INTENT(OUT) :: error
5637  !Local Variables
5638  INTEGER(INTG) :: nf
5639 
5640  enters("DOMAIN_TOPOLOGY_FACES_FINALISE",err,error,*999)
5641 
5642  IF(ASSOCIATED(topology)) THEN
5643  IF(ASSOCIATED(topology%FACES)) THEN
5644  DO nf=1,topology%FACES%NUMBER_OF_FACES
5645  CALL domain_topology_face_finalise(topology%FACES%FACES(nf),err,error,*999)
5646  ENDDO !nf
5647  IF(ALLOCATED(topology%FACES%FACES)) DEALLOCATE(topology%FACES%FACES)
5648  DEALLOCATE(topology%FACES)
5649  ENDIF
5650  ELSE
5651  CALL flagerror("Topology is not associated",err,error,*999)
5652  ENDIF
5653 
5654  exits("DOMAIN_TOPOLOGY_FACES_FINALISE")
5655  RETURN
5656 999 errorsexits("DOMAIN_TOPOLOGY_FACES_FINALISE",err,error)
5657  RETURN 1
5658 
5659  END SUBROUTINE domain_topology_faces_finalise
5660 
5661  !
5662  !================================================================================================================================
5663  !
5664 
5666  SUBROUTINE domain_topology_faces_initialise(TOPOLOGY,ERR,ERROR,*)
5667 
5668  !Argument variables
5669  TYPE(domain_topology_type), POINTER :: topology
5670  INTEGER(INTG), INTENT(OUT) :: err
5671  TYPE(varying_string), INTENT(OUT) :: error
5672  !Local Variables
5673 
5674  enters("DOMAIN_TOPOLOGY_FACES_INITIALISE",err,error,*999)
5675 
5676  IF(ASSOCIATED(topology)) THEN
5677  IF(ASSOCIATED(topology%FACES)) THEN
5678  CALL flagerror("Decomposition already has topology faces associated",err,error,*999)
5679  ELSE
5680  ALLOCATE(topology%FACES,stat=err)
5681  IF(err/=0) CALL flagerror("Could not allocate topology faces",err,error,*999)
5682  topology%FACES%NUMBER_OF_FACES=0
5683  topology%FACES%DOMAIN=>topology%DOMAIN
5684  ENDIF
5685  ELSE
5686  CALL flagerror("Topology is not associated",err,error,*999)
5687  ENDIF
5688 
5689  exits("DOMAIN_TOPOLOGY_FACES_INITIALISE")
5690  RETURN
5691 999 errorsexits("DOMAIN_TOPOLOGY_FACES_INITIALISE",err,error)
5692  RETURN 1
5693  END SUBROUTINE domain_topology_faces_initialise
5694 
5695  !
5696  !================================================================================================================================
5697  !
5698 
5700  SUBROUTINE domain_topology_node_check_exists(DOMAIN_TOPOLOGY,USER_NODE_NUMBER,NODE_EXISTS,DOMAIN_LOCAL_NODE_NUMBER, &
5701  & ghost_node,err,error,*)
5702 
5703  !Argument variables
5704  TYPE(domain_topology_type), POINTER :: domain_topology
5705  INTEGER(INTG), INTENT(IN) :: user_node_number
5706  LOGICAL, INTENT(OUT) :: node_exists
5707  INTEGER(INTG), INTENT(OUT) :: domain_local_node_number
5708  LOGICAL, INTENT(OUT) :: ghost_node
5709  INTEGER(INTG), INTENT(OUT) :: err
5710  TYPE(varying_string), INTENT(OUT) :: error
5711  !Local Variables
5712  TYPE(domain_nodes_type), POINTER :: domain_nodes
5713  TYPE(tree_node_type), POINTER :: tree_node
5714 
5715  enters("DOMAIN_TOPOLOGY_NODE_CHECK_EXISTS",err,error,*999)
5716 
5717  node_exists=.false.
5718  domain_local_node_number=0
5719  ghost_node=.false.
5720  IF(ASSOCIATED(domain_topology)) THEN
5721  domain_nodes=>domain_topology%NODES
5722  IF(ASSOCIATED(domain_nodes)) THEN
5723  NULLIFY(tree_node)
5724  CALL tree_search(domain_nodes%NODES_TREE,user_node_number,tree_node,err,error,*999)
5725  IF(ASSOCIATED(tree_node)) THEN
5726  CALL tree_node_value_get(domain_nodes%NODES_TREE,tree_node,domain_local_node_number,err,error,*999)
5727  node_exists=.true.
5728  ghost_node=domain_local_node_number>domain_nodes%NUMBER_OF_NODES
5729  ENDIF
5730  ELSE
5731  CALL flagerror("Domain topology nodes is not associated.",err,error,*999)
5732  ENDIF
5733  ELSE
5734  CALL flagerror("Domain topology is not associated.",err,error,*999)
5735  ENDIF
5736 
5737  exits("DOMAIN_TOPOLOGY_NODE_CHECK_EXISTS")
5738  RETURN
5739 999 errorsexits("DOMAIN_TOPOLOGY_NODE_CHECK_EXISTS",err,error)
5740  RETURN 1
5741 
5742  END SUBROUTINE domain_topology_node_check_exists
5743 
5744  !
5745  !================================================================================================================================
5746  !
5747 
5749  SUBROUTINE domain_topology_node_derivative_finalise(NODE_DERIVATIVE,ERR,ERROR,*)
5750 
5751  !Argument variables
5752  TYPE(domain_node_derivative_type) :: node_derivative
5753  INTEGER(INTG), INTENT(OUT) :: err
5754  TYPE(varying_string), INTENT(OUT) :: error
5755  !Local Variables
5756 
5757  enters("DOMAIN_TOPOLOGY_NODE_DERIVATIVE_FINALISE",err,error,*999)
5758 
5759  IF(ALLOCATED(node_derivative%userVersionNumbers)) DEALLOCATE(node_derivative%userVersionNumbers)
5760  IF(ALLOCATED(node_derivative%DOF_INDEX)) DEALLOCATE(node_derivative%DOF_INDEX)
5761 
5762  exits("DOMAIN_TOPOLOGY_NODE_DERIVATIVE_FINALISE")
5763  RETURN
5764 999 errorsexits("DOMAIN_TOPOLOGY_NODE_DERIVATIVE_FINALISE",err,error)
5765  RETURN 1
5766  END SUBROUTINE domain_topology_node_derivative_finalise
5767 
5768  !
5769  !================================================================================================================================
5770  !
5771 
5773  SUBROUTINE domain_topology_node_derivative_initialise(NODE_DERIVATIVE,ERR,ERROR,*)
5774 
5775  !Argument variables
5776  TYPE(domain_node_derivative_type) :: node_derivative
5777  INTEGER(INTG), INTENT(OUT) :: err
5778  TYPE(varying_string), INTENT(OUT) :: error
5779  !Local Variables
5780 
5781  enters("DOMAIN_TOPOLOGY_NODE_DERIVATIVE_INITIALISE",err,error,*999)
5782 
5783  node_derivative%numberOfVersions=0
5784  node_derivative%GLOBAL_DERIVATIVE_INDEX=0
5785  node_derivative%PARTIAL_DERIVATIVE_INDEX=0
5786 
5787  exits("DOMAIN_TOPOLOGY_NODE_DERIVATIVE_INITIALISE")
5788  RETURN
5789 999 errorsexits("DOMAIN_TOPOLOGY_NODE_DERIVATIVE_INITIALISE",err,error)
5790  RETURN 1
5791  END SUBROUTINE domain_topology_node_derivative_initialise
5792 
5793  !
5794  !================================================================================================================================
5795  !
5796 
5798  SUBROUTINE domain_topology_node_finalise(NODE,ERR,ERROR,*)
5799 
5800  !Argument variables
5801  TYPE(domain_node_type) :: node
5802  INTEGER(INTG), INTENT(OUT) :: err
5803  TYPE(varying_string), INTENT(OUT) :: error
5804  !Local Variables
5805  INTEGER(INTG) :: derivative_idx
5806 
5807  enters("DOMAIN_TOPOLOGY_NODE_FINALISE",err,error,*999)
5808 
5809  IF(ALLOCATED(node%DERIVATIVES)) THEN
5810  DO derivative_idx=1,node%NUMBER_OF_DERIVATIVES
5811  CALL domain_topology_node_derivative_finalise(node%DERIVATIVES(derivative_idx),err,error,*999)
5812  ENDDO !derivative_idx
5813  DEALLOCATE(node%DERIVATIVES)
5814  ENDIF
5815  IF(ASSOCIATED(node%SURROUNDING_ELEMENTS)) DEALLOCATE(node%SURROUNDING_ELEMENTS)
5816  IF(ALLOCATED(node%NODE_LINES)) DEALLOCATE(node%NODE_LINES)
5817 
5818  exits("DOMAIN_TOPOLOGY_NODE_FINALISE")
5819  RETURN
5820 999 errorsexits("DOMAIN_TOPOLOGY_NODE_FINALISE",err,error)
5821  RETURN 1
5822 
5823  END SUBROUTINE domain_topology_node_finalise
5824 
5825  !
5826  !================================================================================================================================
5827  !
5828 
5830  SUBROUTINE domain_topology_node_initialise(NODE,ERR,ERROR,*)
5831 
5832  !Argument variables
5833  TYPE(domain_node_type) :: node
5834  INTEGER(INTG), INTENT(OUT) :: err
5835  TYPE(varying_string), INTENT(OUT) :: error
5836  !Local Variables
5837 
5838  enters("DOMAIN_TOPOLOGY_NODE_INITIALISE",err,error,*999)
5839 
5840  node%LOCAL_NUMBER=0
5841  node%MESH_NUMBER=0
5842  node%GLOBAL_NUMBER=0
5843  node%USER_NUMBER=0
5844  node%NUMBER_OF_SURROUNDING_ELEMENTS=0
5845  node%NUMBER_OF_NODE_LINES=0
5846  node%BOUNDARY_NODE=.false.
5847 
5848  exits("DOMAIN_TOPOLOGY_NODE_INITIALISE")
5849  RETURN
5850 999 errorsexits("DOMAIN_TOPOLOGY_NODE_INITIALISE",err,error)
5851  RETURN 1
5852 
5853  END SUBROUTINE domain_topology_node_initialise
5854 
5855  !
5856  !================================================================================================================================
5857  !
5858 
5860  SUBROUTINE domain_topology_nodes_finalise(TOPOLOGY,ERR,ERROR,*)
5861 
5862  !Argument variables
5863  TYPE(domain_topology_type), POINTER :: topology
5864  INTEGER(INTG), INTENT(OUT) :: err
5865  TYPE(varying_string), INTENT(OUT) :: error
5866  !Local Variables
5867  INTEGER(INTG) :: np
5868 
5869  enters("DOMAIN_TOPOLOGY_NODES_FINALISE",err,error,*999)
5870 
5871  IF(ASSOCIATED(topology)) THEN
5872  IF(ASSOCIATED(topology%NODES)) THEN
5873  DO np=1,topology%NODES%TOTAL_NUMBER_OF_NODES
5874  CALL domain_topology_node_finalise(topology%NODES%NODES(np),err,error,*999)
5875  ENDDO !np
5876  IF(ASSOCIATED(topology%NODES%NODES)) DEALLOCATE(topology%NODES%NODES)
5877  IF(ASSOCIATED(topology%NODES%NODES_TREE)) CALL tree_destroy(topology%NODES%NODES_TREE,err,error,*999)
5878  DEALLOCATE(topology%NODES)
5879  ENDIF
5880  ELSE
5881  CALL flagerror("Topology is not associated",err,error,*999)
5882  ENDIF
5883 
5884  exits("DOMAIN_TOPOLOGY_NODES_FINALISE")
5885  RETURN
5886 999 errorsexits("DOMAIN_TOPOLOGY_NODES_FINALISE",err,error)
5887  RETURN 1
5888 
5889  END SUBROUTINE domain_topology_nodes_finalise
5890 
5891  !
5892  !================================================================================================================================
5893  !
5894 
5896  SUBROUTINE domain_topology_nodes_initialise(TOPOLOGY,ERR,ERROR,*)
5897 
5898  !Argument variables
5899  TYPE(domain_topology_type), POINTER :: topology
5900  INTEGER(INTG), INTENT(OUT) :: err
5901  TYPE(varying_string), INTENT(OUT) :: error
5902  !Local Variables
5903 
5904  enters("DOMAIN_TOPOLOGY_NODES_INITIALISE",err,error,*999)
5905 
5906  IF(ASSOCIATED(topology)) THEN
5907  IF(ASSOCIATED(topology%NODES)) THEN
5908  CALL flagerror("Decomposition already has topology nodes associated",err,error,*999)
5909  ELSE
5910  ALLOCATE(topology%NODES,stat=err)
5911  IF(err/=0) CALL flagerror("Could not allocate topology nodes",err,error,*999)
5912  topology%NODES%NUMBER_OF_NODES=0
5913  topology%NODES%TOTAL_NUMBER_OF_NODES=0
5914  topology%NODES%NUMBER_OF_GLOBAL_NODES=0
5915  topology%NODES%MAXIMUM_NUMBER_OF_DERIVATIVES=0
5916  topology%NODES%DOMAIN=>topology%DOMAIN
5917  NULLIFY(topology%NODES%NODES)
5918  NULLIFY(topology%NODES%NODES_TREE)
5919  ENDIF
5920  ELSE
5921  CALL flagerror("Topology is not associated",err,error,*999)
5922  ENDIF
5923 
5924  exits("DOMAIN_TOPOLOGY_NODES_INITIALISE")
5925  RETURN
5926 999 errorsexits("DOMAIN_TOPOLOGY_NODES_INITIALISE",err,error)
5927  RETURN 1
5928  END SUBROUTINE domain_topology_nodes_initialise
5929 
5930  !
5931  !================================================================================================================================
5932  !
5933 
5935  SUBROUTINE domaintopology_nodessurroundingelementscalculate(TOPOLOGY,ERR,ERROR,*)
5936 
5937  !Argument variables
5938  TYPE(domain_topology_type), POINTER :: topology
5939  INTEGER(INTG), INTENT(OUT) :: err
5940  TYPE(varying_string), INTENT(OUT) :: error
5941  !Local Variables
5942  INTEGER(INTG) :: element_no,insert_position,ne,nn,np,surrounding_elem_no
5943  INTEGER(INTG), POINTER :: new_surrounding_elements(:)
5944  LOGICAL :: found_element
5945  TYPE(basis_type), POINTER :: basis
5946 
5947  NULLIFY(new_surrounding_elements)
5948 
5949  enters("DomainTopology_NodesSurroundingElementsCalculate",err,error,*999)
5950 
5951  IF(ASSOCIATED(topology)) THEN
5952  IF(ASSOCIATED(topology%ELEMENTS)) THEN
5953  IF(ASSOCIATED(topology%NODES)) THEN
5954  IF(ASSOCIATED(topology%NODES%NODES)) THEN
5955  DO np=1,topology%NODES%TOTAL_NUMBER_OF_NODES
5956  topology%NODES%NODES(np)%NUMBER_OF_SURROUNDING_ELEMENTS=0
5957  IF(ASSOCIATED(topology%NODES%NODES(np)%SURROUNDING_ELEMENTS)) &
5958  & DEALLOCATE(topology%NODES%NODES(np)%SURROUNDING_ELEMENTS)
5959  ENDDO !np
5960  DO ne=1,topology%ELEMENTS%TOTAL_NUMBER_OF_ELEMENTS
5961  basis=>topology%ELEMENTS%ELEMENTS(ne)%BASIS
5962  DO nn=1,basis%NUMBER_OF_NODES
5963  np=topology%ELEMENTS%ELEMENTS(ne)%ELEMENT_NODES(nn)
5964  found_element=.false.
5965  element_no=1
5966  insert_position=1
5967  DO WHILE(element_no<=topology%NODES%NODES(np)%NUMBER_OF_SURROUNDING_ELEMENTS.AND..NOT.found_element)
5968  surrounding_elem_no=topology%NODES%NODES(np)%SURROUNDING_ELEMENTS(element_no)
5969  IF(surrounding_elem_no==ne) THEN
5970  found_element=.true.
5971  ENDIF
5972  element_no=element_no+1
5973  IF(ne>=surrounding_elem_no) THEN
5974  insert_position=element_no
5975  ENDIF
5976  ENDDO
5977  IF(.NOT.found_element) THEN
5978  !Insert element into surrounding elements
5979  ALLOCATE(new_surrounding_elements(topology%NODES%NODES(np)%NUMBER_OF_SURROUNDING_ELEMENTS+1),stat=err)
5980  IF(err/=0) CALL flagerror("Could not allocate new surrounding elements",err,error,*999)
5981  IF(ASSOCIATED(topology%NODES%NODES(np)%SURROUNDING_ELEMENTS)) THEN
5982  new_surrounding_elements(1:insert_position-1)=topology%NODES%NODES(np)% &
5983  & surrounding_elements(1:insert_position-1)
5984  new_surrounding_elements(insert_position)=ne
5985  new_surrounding_elements(insert_position+1:topology%NODES%NODES(np)% &
5986  & number_of_surrounding_elements+1)=topology%NODES%NODES(np)%SURROUNDING_ELEMENTS(insert_position: &
5987  & topology%NODES%NODES(np)%NUMBER_OF_SURROUNDING_ELEMENTS)
5988  DEALLOCATE(topology%NODES%NODES(np)%SURROUNDING_ELEMENTS)
5989  ELSE
5990  new_surrounding_elements(1)=ne
5991  ENDIF
5992  topology%NODES%NODES(np)%SURROUNDING_ELEMENTS=>new_surrounding_elements
5993  topology%NODES%NODES(np)%NUMBER_OF_SURROUNDING_ELEMENTS= &
5994  & topology%NODES%NODES(np)%NUMBER_OF_SURROUNDING_ELEMENTS+1
5995  ENDIF
5996  ENDDO !nn
5997  ENDDO !ne
5998  ELSE
5999  CALL flagerror("Domain topology nodes nodes are not associated",err,error,*999)
6000  ENDIF
6001  ELSE
6002  CALL flagerror("Domain topology nodes are not associated",err,error,*999)
6003  ENDIF
6004  ELSE
6005  CALL flagerror("Domain topology elements is not associated",err,error,*999)
6006  ENDIF
6007  ELSE
6008  CALL flagerror("Domain topology is not associated",err,error,*999)
6009  ENDIF
6010 
6011  exits("DomainTopology_NodesSurroundingElementsCalculate")
6012  RETURN
6013 999 IF(ASSOCIATED(new_surrounding_elements)) DEALLOCATE(new_surrounding_elements)
6014  errors("DomainTopology_NodesSurroundingElementsCalculate",err,error)
6015  exits("DomainTopology_NodesSurroundingElementsCalculate")
6016  RETURN 1
6017  END SUBROUTINE domaintopology_nodessurroundingelementscalculate
6018 
6019  !
6020  !================================================================================================================================
6021  !
6022 
6024  SUBROUTINE mesh_adjacent_element_finalise(MESH_ADJACENT_ELEMENT,ERR,ERROR,*)
6025 
6026  !Argument variables
6027  TYPE(mesh_adjacent_element_type) :: mesh_adjacent_element
6028  INTEGER(INTG), INTENT(OUT) :: err
6029  TYPE(varying_string), INTENT(OUT) :: error
6030  !Local Variables
6031 
6032  enters("MESH_ADJACENT_ELEMENT_FINALISE",err,error,*999)
6033 
6034  mesh_adjacent_element%NUMBER_OF_ADJACENT_ELEMENTS=0
6035  IF(ALLOCATED(mesh_adjacent_element%ADJACENT_ELEMENTS)) DEALLOCATE(mesh_adjacent_element%ADJACENT_ELEMENTS)
6036 
6037  exits("MESH_ADJACENT_ELEMENT_FINALISE")
6038  RETURN
6039 999 errorsexits("MESH_ADJACENT_ELEMENT_FINALISE",err,error)
6040  RETURN 1
6041 
6042  END SUBROUTINE mesh_adjacent_element_finalise
6043 
6044  !
6045  !================================================================================================================================
6046  !
6048  SUBROUTINE mesh_adjacent_element_initialise(MESH_ADJACENT_ELEMENT,ERR,ERROR,*)
6049 
6050  !Argument variables
6051  TYPE(mesh_adjacent_element_type) :: mesh_adjacent_element
6052  INTEGER(INTG), INTENT(OUT) :: err
6053  TYPE(varying_string), INTENT(OUT) :: error
6054  !Local Variables
6055 
6056  enters("MESH_ADJACENT_ELEMENT_INITIALISE",err,error,*999)
6057 
6058  mesh_adjacent_element%NUMBER_OF_ADJACENT_ELEMENTS=0
6059 
6060  exits("MESH_ADJACENT_ELEMENT_INITIALISE")
6061  RETURN
6062 999 errorsexits("MESH_ADJACENT_ELEMENT_INITIALISE",err,error)
6063  RETURN 1
6064 
6065  END SUBROUTINE mesh_adjacent_element_initialise
6066 
6067  !
6068  !================================================================================================================================
6069  !
6070 
6072  SUBROUTINE mesh_create_finish(MESH,ERR,ERROR,*)
6073 
6074  !Argument variables
6075  TYPE(mesh_type), POINTER :: mesh
6076  INTEGER(INTG), INTENT(OUT) :: err
6077  TYPE(varying_string), INTENT(OUT) :: error
6078  !Local Variables
6079  INTEGER(INTG) :: component_idx
6080  LOGICAL :: finished
6081  TYPE(varying_string) :: local_error
6082 
6083  enters("MESH_CREATE_FINISH",err,error,*999)
6084 
6085  IF(ASSOCIATED(mesh)) THEN
6086  IF(ASSOCIATED(mesh%TOPOLOGY)) THEN
6087  !Check that the mesh component elements have been finished
6088  finished=.true.
6089  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
6090  IF(ASSOCIATED(mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS)) THEN
6091  IF(.NOT.mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%ELEMENTS_FINISHED) THEN
6092  local_error="The elements for mesh component "//trim(number_to_vstring(component_idx,"*",err,error))// &
6093  & " have not been finished"
6094  finished=.false.
6095  EXIT
6096  ENDIF
6097  ELSE
6098  local_error="The elements for mesh topology component "//trim(number_to_vstring(component_idx,"*",err,error))// &
6099  & " are not associated"
6100  finished=.false.
6101  EXIT
6102  ENDIF
6103  ENDDO !component_idx
6104  IF(.NOT.finished) CALL flagerror(local_error,err,error,*999)
6105  mesh%MESH_FINISHED=.true.
6106  !Calulcate the mesh topology
6107  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
6108  CALL meshtopologycalculate(mesh%TOPOLOGY(component_idx)%PTR,err,error,*999)
6109  ENDDO !component_idx
6110  ELSE
6111  CALL flagerror("Mesh topology is not associated",err,error,*999)
6112  ENDIF
6113  ELSE
6114  CALL flagerror("Mesh is not associated",err,error,*999)
6115  ENDIF
6116 
6117  IF(diagnostics1) THEN
6118  CALL write_string_value(diagnostic_output_type," Mesh user number = ",mesh%USER_NUMBER,err,error,*999)
6119  CALL write_string_value(diagnostic_output_type," Global number = ",mesh%GLOBAL_NUMBER,err,error,*999)
6120  CALL write_string_value(diagnostic_output_type," Number of dimensions = ",mesh%NUMBER_OF_DIMENSIONS,err,error,*999)
6121  ENDIF
6122 
6123  exits("MESH_CREATE_FINISH")
6124  RETURN
6125 999 errorsexits("MESH_CREATE_FINISH",err,error)
6126  RETURN 1
6127 
6128  END SUBROUTINE mesh_create_finish
6129 
6130  !
6131  !================================================================================================================================
6132  !
6133 
6135  SUBROUTINE mesh_create_start_generic(MESHES,USER_NUMBER,NUMBER_OF_DIMENSIONS,MESH,ERR,ERROR,*)
6136 
6137  !Argument variables
6138  TYPE(meshes_type), POINTER :: meshes
6139  INTEGER(INTG), INTENT(IN) :: user_number
6140  INTEGER(INTG), INTENT(IN) :: number_of_dimensions
6141  TYPE(mesh_type), POINTER :: mesh
6142  INTEGER(INTG), INTENT(OUT) :: err
6143  TYPE(varying_string), INTENT(OUT) :: error
6144  !Local Variables
6145  INTEGER(INTG) :: dummy_err,mesh_idx
6146  TYPE(mesh_type), POINTER :: new_mesh
6147  TYPE(mesh_ptr_type), POINTER :: new_meshes(:)
6148  TYPE(varying_string) :: dummy_error
6149 
6150  NULLIFY(new_mesh)
6151  NULLIFY(new_meshes)
6152 
6153  enters("MESH_CREATE_START_GENERIC",err,error,*997)
6154 
6155  IF(ASSOCIATED(meshes)) THEN
6156  IF(ASSOCIATED(mesh)) THEN
6157  CALL flagerror("Mesh is already associated.",err,error,*997)
6158  ELSE
6159  CALL mesh_initialise(new_mesh,err,error,*999)
6160  !Set default mesh values
6161  new_mesh%USER_NUMBER=user_number
6162  new_mesh%GLOBAL_NUMBER=meshes%NUMBER_OF_MESHES+1
6163  new_mesh%MESHES=>meshes
6164  new_mesh%NUMBER_OF_DIMENSIONS=number_of_dimensions
6165  new_mesh%NUMBER_OF_COMPONENTS=1
6166  new_mesh%SURROUNDING_ELEMENTS_CALCULATE=.true. !default true
6167  !Initialise mesh topology and decompositions
6168  CALL meshtopologyinitialise(new_mesh,err,error,*999)
6169  CALL decompositions_initialise(new_mesh,err,error,*999)
6170  !Add new mesh into list of meshes
6171  ALLOCATE(new_meshes(meshes%NUMBER_OF_MESHES+1),stat=err)
6172  IF(err/=0) CALL flagerror("Could not allocate new meshes",err,error,*999)
6173  DO mesh_idx=1,meshes%NUMBER_OF_MESHES
6174  new_meshes(mesh_idx)%PTR=>meshes%MESHES(mesh_idx)%PTR
6175  ENDDO !mesh_idx
6176  new_meshes(meshes%NUMBER_OF_MESHES+1)%PTR=>new_mesh
6177  IF(ASSOCIATED(meshes%MESHES)) DEALLOCATE(meshes%MESHES)
6178  meshes%MESHES=>new_meshes
6179  meshes%NUMBER_OF_MESHES=meshes%NUMBER_OF_MESHES+1
6180  mesh=>new_mesh
6181  ENDIF
6182  ELSE
6183  CALL flagerror("Meshes is not associated.",err,error,*997)
6184  ENDIF
6185 
6186  exits("MESH_CREATE_START_GENERIC")
6187  RETURN
6188 999 CALL mesh_finalise(new_mesh,dummy_err,dummy_error,*998)
6189 998 IF(ASSOCIATED(new_meshes)) DEALLOCATE(new_meshes)
6190  NULLIFY(mesh)
6191 997 errorsexits("MESH_CREATE_START_GENERIC",err,error)
6192  RETURN 1
6193 
6194  END SUBROUTINE mesh_create_start_generic
6195 
6196  !
6197  !================================================================================================================================
6198  !
6199 
6203  SUBROUTINE mesh_create_start_interface(USER_NUMBER,INTERFACE,NUMBER_OF_DIMENSIONS,MESH,ERR,ERROR,*)
6204 
6205  !Argument variables
6206  INTEGER(INTG), INTENT(IN) :: user_number
6207  TYPE(interface_type), POINTER :: interface
6208  INTEGER(INTG), INTENT(IN) :: number_of_dimensions
6209  TYPE(mesh_type), POINTER :: mesh
6210  INTEGER(INTG), INTENT(OUT) :: err
6211  TYPE(varying_string), INTENT(OUT) :: error
6212  !Local Variables
6213  TYPE(region_type), POINTER :: parent_region
6214  TYPE(varying_string) :: local_error
6215 
6216  enters("MESH_CREATE_START_INTERFACE",err,error,*999)
6217 
6218  IF(ASSOCIATED(interface)) THEN
6219  IF(ASSOCIATED(mesh)) THEN
6220  CALL flagerror("Mesh is already associated.",err,error,*999)
6221  ELSE
6222  NULLIFY(mesh)
6223  IF(ASSOCIATED(interface%MESHES)) THEN
6224  CALL mesh_user_number_find_generic(user_number,interface%MESHES,mesh,err,error,*999)
6225  IF(ASSOCIATED(mesh)) THEN
6226  local_error="Mesh number "//trim(number_to_vstring(user_number,"*",err,error))// &
6227  & " has already been created on interface number "// &
6228  & trim(number_to_vstring(interface%USER_NUMBER,"*",err,error))//"."
6229  CALL flagerror(local_error,err,error,*999)
6230  ELSE
6231  IF(ASSOCIATED(interface%INTERFACES)) THEN
6232  parent_region=>interface%INTERFACES%PARENT_REGION
6233  IF(ASSOCIATED(parent_region)) THEN
6234  IF(ASSOCIATED(parent_region%COORDINATE_SYSTEM)) THEN
6235  IF(number_of_dimensions>0) THEN
6236  IF(number_of_dimensions<=parent_region%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS) THEN
6237  CALL mesh_create_start_generic(interface%MESHES,user_number,number_of_dimensions,mesh,err,error,*999)
6238  mesh%INTERFACE=>INTERFACE
6239  ELSE
6240  local_error="Number of mesh dimensions ("//trim(number_to_vstring(number_of_dimensions,"*",err,error))// &
6241  & ") must be <= number of parent region dimensions ("// &
6242  & trim(number_to_vstring(parent_region%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS,"*",err,error))//")."
6243  CALL flagerror(local_error,err,error,*999)
6244  ENDIF
6245  ELSE
6246  CALL flagerror("Number of mesh dimensions must be > 0.",err,error,*999)
6247  ENDIF
6248  ELSE
6249  CALL flagerror("Parent region coordinate system is not associated.",err,error,*999)
6250  ENDIF
6251  ELSE
6252  CALL flagerror("Interfaces parent region is not associated.",err,error,*999)
6253  ENDIF
6254  ELSE
6255  CALL flagerror("Interface interfaces is not associated.",err,error,*999)
6256  ENDIF
6257  ENDIF
6258  ELSE
6259  local_error="The meshes on interface number "//trim(number_to_vstring(interface%USER_NUMBER,"*",err,error))// &
6260  & " are not associated."
6261  CALL flagerror(local_error,err,error,*999)
6262  ENDIF
6263  ENDIF
6264  ELSE
6265  CALL flagerror("Interface is not associated.",err,error,*999)
6266  ENDIF
6267 
6268  exits("MESH_CREATE_START_INTERFACE")
6269  RETURN
6270 999 errorsexits("MESH_CREATE_START_INTERFACE",err,error)
6271  RETURN 1
6272 
6273  END SUBROUTINE mesh_create_start_interface
6274 
6275  !
6276  !================================================================================================================================
6277  !
6278 
6282  SUBROUTINE mesh_create_start_region(USER_NUMBER,REGION,NUMBER_OF_DIMENSIONS,MESH,ERR,ERROR,*)
6283 
6284  !Argument variables
6285  INTEGER(INTG), INTENT(IN) :: user_number
6286  TYPE(region_type), POINTER :: region
6287  INTEGER(INTG), INTENT(IN) :: number_of_dimensions
6288  TYPE(mesh_type), POINTER :: mesh
6289  INTEGER(INTG), INTENT(OUT) :: err
6290  TYPE(varying_string), INTENT(OUT) :: error
6291  !Local Variables
6292  TYPE(varying_string) :: local_error
6293 
6294  enters("MESH_CREATE_START_REGION",err,error,*999)
6295 
6296  IF(ASSOCIATED(region)) THEN
6297  IF(ASSOCIATED(mesh)) THEN
6298  CALL flagerror("Mesh is already associated.",err,error,*999)
6299  ELSE
6300  NULLIFY(mesh)
6301  IF(ASSOCIATED(region%MESHES)) THEN
6302  CALL mesh_user_number_find_generic(user_number,region%MESHES,mesh,err,error,*999)
6303  IF(ASSOCIATED(mesh)) THEN
6304  local_error="Mesh number "//trim(number_to_vstring(user_number,"*",err,error))// &
6305  & " has already been created on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
6306  CALL flagerror(local_error,err,error,*999)
6307  ELSE
6308  IF(ASSOCIATED(region%COORDINATE_SYSTEM)) THEN
6309  IF(number_of_dimensions>0) THEN
6310  IF(number_of_dimensions<=region%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS) THEN
6311  CALL mesh_create_start_generic(region%MESHES,user_number,number_of_dimensions,mesh,err,error,*999)
6312  mesh%REGION=>region
6313  ELSE
6314  local_error="Number of mesh dimensions ("//trim(number_to_vstring(number_of_dimensions,"*",err,error))// &
6315  & ") must be <= number of region dimensions ("// &
6316  & trim(number_to_vstring(region%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS,"*",err,error))//")."
6317  CALL flagerror(local_error,err,error,*999)
6318  ENDIF
6319  ELSE
6320  CALL flagerror("Number of mesh dimensions must be > 0.",err,error,*999)
6321  ENDIF
6322  ELSE
6323  local_error="The coordinate system on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))// &
6324  & " are not associated."
6325  CALL flagerror(local_error,err,error,*999)
6326  ENDIF
6327  ENDIF
6328  ELSE
6329  local_error="The meshes on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))// &
6330  & " are not associated."
6331  CALL flagerror(local_error,err,error,*999)
6332  ENDIF
6333  ENDIF
6334  ELSE
6335  CALL flagerror("Region is not associated.",err,error,*999)
6336  ENDIF
6337 
6338  exits("MESH_CREATE_START_REGION")
6339  RETURN
6340 999 errorsexits("MESH_CREATE_START_REGION",err,error)
6341  RETURN 1
6342 
6343  END SUBROUTINE mesh_create_start_region
6344 
6345  !
6346  !================================================================================================================================
6347  !
6348 
6350  SUBROUTINE mesh_destroy_number(USER_NUMBER,REGION,ERR,ERROR,*)
6351 
6352  !Argument variables
6353  INTEGER(INTG), INTENT(IN) :: user_number
6354  TYPE(region_type), POINTER :: region
6355  INTEGER(INTG), INTENT(OUT) :: err
6356  TYPE(varying_string), INTENT(OUT) :: error
6357  !Local Variables
6358  INTEGER(INTG) :: mesh_idx,mesh_position
6359  LOGICAL :: found
6360  TYPE(varying_string) :: local_error
6361  TYPE(mesh_type), POINTER :: mesh
6362  TYPE(mesh_ptr_type), POINTER :: new_meshes(:)
6363 
6364  NULLIFY(new_meshes)
6365 
6366  enters("MESH_DESTROY_NUMBER",err,error,*999)
6367 
6368  IF(ASSOCIATED(region)) THEN
6369  IF(ASSOCIATED(region%MESHES)) THEN
6370 
6371 !!TODO: have a mesh_destory_ptr and mesh_destroy_number
6372 
6373  !Find the problem identified by the user number
6374  found=.false.
6375  mesh_position=0
6376  DO WHILE(mesh_position<region%MESHES%NUMBER_OF_MESHES.AND..NOT.found)
6377  mesh_position=mesh_position+1
6378  IF(region%MESHES%MESHES(mesh_position)%PTR%USER_NUMBER==user_number) found=.true.
6379  ENDDO
6380 
6381  IF(found) THEN
6382 
6383  mesh=>region%MESHES%MESHES(mesh_position)%PTR
6384 
6385  CALL mesh_finalise(mesh,err,error,*999)
6386 
6387  !Remove the mesh from the list of meshes
6388  IF(region%MESHES%NUMBER_OF_MESHES>1) THEN
6389  ALLOCATE(new_meshes(region%MESHES%NUMBER_OF_MESHES-1),stat=err)
6390  IF(err/=0) CALL flagerror("Could not allocate new meshes",err,error,*999)
6391  DO mesh_idx=1,region%MESHES%NUMBER_OF_MESHES
6392  IF(mesh_idx<mesh_position) THEN
6393  new_meshes(mesh_idx)%PTR=>region%MESHES%MESHES(mesh_idx)%PTR
6394  ELSE IF(mesh_idx>mesh_position) THEN
6395  region%MESHES%MESHES(mesh_idx)%PTR%GLOBAL_NUMBER=region%MESHES%MESHES(mesh_idx)%PTR%GLOBAL_NUMBER-1
6396  new_meshes(mesh_idx-1)%PTR=>region%MESHES%MESHES(mesh_idx)%PTR
6397  ENDIF
6398  ENDDO !mesh_idx
6399  DEALLOCATE(region%MESHES%MESHES)
6400  region%MESHES%MESHES=>new_meshes
6401  region%MESHES%NUMBER_OF_MESHES=region%MESHES%NUMBER_OF_MESHES-1
6402  ELSE
6403  DEALLOCATE(region%MESHES%MESHES)
6404  region%MESHES%NUMBER_OF_MESHES=0
6405  ENDIF
6406 
6407  ELSE
6408  local_error="Mesh number "//trim(number_to_vstring(user_number,"*",err,error))// &
6409  & " has not been created on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))
6410  CALL flagerror(local_error,err,error,*999)
6411  ENDIF
6412  ELSE
6413  local_error="The meshes on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))// &
6414  & " are not associated"
6415  CALL flagerror(local_error,err,error,*999)
6416  ENDIF
6417  ELSE
6418  CALL flagerror("Region is not associated",err,error,*999)
6419  ENDIF
6420 
6421  exits("MESH_DESTROY_NUMBER")
6422  RETURN
6423 999 IF(ASSOCIATED(new_meshes)) DEALLOCATE(new_meshes)
6424  errorsexits("MESH_DESTROY_NUMBER",err,error)
6425  RETURN 1
6426  END SUBROUTINE mesh_destroy_number
6427 
6428  !
6429  !================================================================================================================================
6430  !
6431 
6433  SUBROUTINE mesh_destroy(MESH,ERR,ERROR,*)
6434 
6435  !Argument variables
6436  TYPE(mesh_type), POINTER :: mesh
6437  INTEGER(INTG), INTENT(OUT) :: err
6438  TYPE(varying_string), INTENT(OUT) :: error
6439  !Local Variables
6440  INTEGER(INTG) :: mesh_idx,mesh_position
6441  TYPE(meshes_type), POINTER :: meshes
6442  TYPE(mesh_ptr_type), POINTER :: new_meshes(:)
6443 
6444  NULLIFY(new_meshes)
6445 
6446  enters("MESH_DESTROY",err,error,*999)
6447 
6448  IF(ASSOCIATED(mesh)) THEN
6449  meshes=>mesh%MESHES
6450  IF(ASSOCIATED(meshes)) THEN
6451  mesh_position=mesh%GLOBAL_NUMBER
6452 
6453  CALL mesh_finalise(mesh,err,error,*999)
6454 
6455  !Remove the mesh from the list of meshes
6456  IF(meshes%NUMBER_OF_MESHES>1) THEN
6457  ALLOCATE(new_meshes(meshes%NUMBER_OF_MESHES-1),stat=err)
6458  IF(err/=0) CALL flagerror("Could not allocate new meshes.",err,error,*999)
6459  DO mesh_idx=1,meshes%NUMBER_OF_MESHES
6460  IF(mesh_idx<mesh_position) THEN
6461  new_meshes(mesh_idx)%PTR=>meshes%MESHES(mesh_idx)%PTR
6462  ELSE IF(mesh_idx>mesh_position) THEN
6463  meshes%MESHES(mesh_idx)%PTR%GLOBAL_NUMBER=meshes%MESHES(mesh_idx)%PTR%GLOBAL_NUMBER-1
6464  new_meshes(mesh_idx-1)%PTR=>meshes%MESHES(mesh_idx)%PTR
6465  ENDIF
6466  ENDDO !mesh_idx
6467  DEALLOCATE(meshes%MESHES)
6468  meshes%MESHES=>new_meshes
6469  meshes%NUMBER_OF_MESHES=meshes%NUMBER_OF_MESHES-1
6470  ELSE
6471  DEALLOCATE(meshes%MESHES)
6472  meshes%NUMBER_OF_MESHES=0
6473  ENDIF
6474  ELSE
6475  CALL flagerror("The mesh meshes is not associated.",err,error,*999)
6476  ENDIF
6477  ELSE
6478  CALL flagerror("Mesh is not associated.",err,error,*999)
6479  ENDIF
6480 
6481  exits("MESH_DESTROY")
6482  RETURN
6483 999 IF(ASSOCIATED(new_meshes)) DEALLOCATE(new_meshes)
6484  errorsexits("MESH_DESTROY",err,error)
6485  RETURN 1
6486  END SUBROUTINE mesh_destroy
6487 
6488  !
6489  !================================================================================================================================
6490  !
6491 
6493  SUBROUTINE mesh_finalise(MESH,ERR,ERROR,*)
6494 
6495  !Argument variables
6496  TYPE(mesh_type), POINTER :: mesh
6497  INTEGER(INTG), INTENT(OUT) :: err
6498  TYPE(varying_string), INTENT(OUT) :: error
6499  !Local Variables
6500 
6501  enters("MESH_FINALISE",err,error,*999)
6502 
6503  IF(ASSOCIATED(mesh)) THEN
6504  CALL meshtopologyfinalise(mesh,err,error,*999)
6505  CALL decompositions_finalise(mesh,err,error,*999)
6506 ! IF(ASSOCIATED(MESH%INTF)) CALL INTERFACE_MESH_FINALISE(MESH,ERR,ERROR,*999) ! <<??>>
6507  DEALLOCATE(mesh)
6508  ENDIF
6509 
6510  exits("MESH_FINALISE")
6511  RETURN
6512 999 errorsexits("MESH_FINALISE",err,error)
6513  RETURN 1
6514 
6515  END SUBROUTINE mesh_finalise
6516 
6517  !
6518  !================================================================================================================================
6519  !
6520 
6522  SUBROUTINE meshglobalnodesget(mesh,nodes,err,error,*)
6523 
6524  !Argument variables
6525  TYPE(mesh_type), POINTER :: mesh
6526  TYPE(nodes_type), POINTER :: nodes
6527  INTEGER(INTG), INTENT(OUT) :: err
6528  TYPE(varying_string), INTENT(OUT) :: error
6529  !Local Variables
6530  TYPE(interface_type), POINTER :: interface
6531  TYPE(region_type), POINTER :: region
6532  TYPE(varying_string) :: localerror
6533 
6534  enters("MeshGlobalNodesGet",err,error,*999)
6535 
6536  IF(ASSOCIATED(mesh)) THEN
6537  IF(ASSOCIATED(nodes)) THEN
6538  CALL flagerror("Nodes is already associated.",err,error,*999)
6539  ELSE
6540  NULLIFY(nodes)
6541  region=>mesh%region
6542  IF(ASSOCIATED(region)) THEN
6543  nodes=>region%nodes
6544  ELSE
6545  interface=>mesh%INTERFACE
6546  IF(ASSOCIATED(interface)) THEN
6547  nodes=>interface%nodes
6548  ELSE
6549  localerror="Mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))// &
6550  & " does not have an associated region or interface."
6551  CALL flagerror(localerror,err,error,*999)
6552  ENDIF
6553  ENDIF
6554  IF(.NOT.ASSOCIATED(nodes)) THEN
6555  IF(ASSOCIATED(region)) THEN
6556  localerror="Mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))// &
6557  & " does not have any nodes associated with the mesh region."
6558  ELSE
6559  localerror="Mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))// &
6560  & " does not have any nodes associated with the mesh interface."
6561  ENDIF
6562  CALL flagerror(localerror,err,error,*999)
6563  ENDIF
6564  ENDIF
6565  ELSE
6566  CALL flagerror("Mesh is not associated.",err,error,*999)
6567  ENDIF
6568 
6569  exits("MeshGlobalNodesGet")
6570  RETURN
6571 999 errorsexits("MeshGlobalNodesGet",err,error)
6572  RETURN 1
6573 
6574  END SUBROUTINE meshglobalnodesget
6575 
6576  !
6577  !================================================================================================================================
6578  !
6579 
6581  SUBROUTINE mesh_initialise(MESH,ERR,ERROR,*)
6582 
6583  !Argument variables
6584  TYPE(mesh_type), POINTER :: mesh
6585  INTEGER(INTG), INTENT(OUT) :: err
6586  TYPE(varying_string), INTENT(OUT) :: error
6587  !Local Variables
6588 
6589  enters("MESH_INITIALISE",err,error,*999)
6590 
6591  IF(ASSOCIATED(mesh)) THEN
6592  CALL flagerror("Mesh is already associated.",err,error,*999)
6593  ELSE
6594  ALLOCATE(mesh,stat=err)
6595  IF(err/=0) CALL flagerror("Could not allocate new mesh.",err,error,*999)
6596  mesh%USER_NUMBER=0
6597  mesh%GLOBAL_NUMBER=0
6598  mesh%MESH_FINISHED=.false.
6599  NULLIFY(mesh%MESHES)
6600  NULLIFY(mesh%REGION)
6601  NULLIFY(mesh%INTERFACE)
6602  NULLIFY(mesh%GENERATED_MESH)
6603  mesh%NUMBER_OF_DIMENSIONS=0
6604  mesh%NUMBER_OF_COMPONENTS=0
6605  mesh%MESH_EMBEDDED=.false.
6606  NULLIFY(mesh%EMBEDDING_MESH)
6607  mesh%NUMBER_OF_EMBEDDED_MESHES=0
6608  NULLIFY(mesh%EMBEDDED_MESHES)
6609  mesh%NUMBER_OF_ELEMENTS=0
6610  NULLIFY(mesh%TOPOLOGY)
6611  NULLIFY(mesh%DECOMPOSITIONS)
6612  ENDIF
6613 
6614  exits("MESH_INITIALISE")
6615  RETURN
6616 999 errorsexits("MESH_INITIALISE",err,error)
6617  RETURN 1
6618  END SUBROUTINE mesh_initialise
6619 
6620  !
6621  !================================================================================================================================
6622  !
6623 
6625  SUBROUTINE mesh_number_of_components_get(MESH,NUMBER_OF_COMPONENTS,ERR,ERROR,*)
6626 
6627  !Argument variables
6628  TYPE(mesh_type), POINTER :: mesh
6629  INTEGER(INTG), INTENT(OUT) :: number_of_components
6630  INTEGER(INTG), INTENT(OUT) :: err
6631  TYPE(varying_string), INTENT(OUT) :: error
6632  !Local Variables
6633 
6634  enters("MESH_NUMBER_OF_COMPONENTS_GET",err,error,*999)
6635 
6636  IF(ASSOCIATED(mesh)) THEN
6637  IF(mesh%MESH_FINISHED) THEN
6638  number_of_components=mesh%NUMBER_OF_COMPONENTS
6639  ELSE
6640  CALL flagerror("Mesh has not finished",err,error,*999)
6641  ENDIF
6642  ELSE
6643  CALL flagerror("Mesh is not associated",err,error,*999)
6644  ENDIF
6645 
6646  exits("MESH_NUMBER_OF_COMPONENTS_GET")
6647  RETURN
6648 999 errorsexits("MESH_NUMBER_OF_COMPONENTS_GET",err,error)
6649  RETURN
6650  END SUBROUTINE mesh_number_of_components_get
6651 
6652  !
6653  !================================================================================================================================
6654  !
6655 
6657  SUBROUTINE mesh_number_of_components_set(MESH,NUMBER_OF_COMPONENTS,ERR,ERROR,*)
6658 
6659  !Argument variables
6660  TYPE(mesh_type), POINTER :: mesh
6661  INTEGER(INTG), INTENT(IN) :: number_of_components
6662  INTEGER(INTG), INTENT(OUT) :: err
6663  TYPE(varying_string), INTENT(OUT) :: error
6664  !Local Variables
6665  INTEGER(INTG) :: component_idx
6666  TYPE(varying_string) :: local_error
6667  TYPE(meshcomponenttopologyptrtype), POINTER :: new_topology(:)
6668 
6669  NULLIFY(new_topology)
6670 
6671  enters("MESH_NUMBER_OF_COMPONENTS_SET",err,error,*999)
6672 
6673  IF(ASSOCIATED(mesh)) THEN
6674  IF(number_of_components>0) THEN
6675  IF(mesh%MESH_FINISHED) THEN
6676  CALL flagerror("Mesh has been finished",err,error,*999)
6677  ELSE
6678  IF(number_of_components/=mesh%NUMBER_OF_COMPONENTS) THEN
6679  ALLOCATE(new_topology(number_of_components),stat=err)
6680  IF(err/=0) CALL flagerror("Could not allocate new topology",err,error,*999)
6681  IF(number_of_components<mesh%NUMBER_OF_COMPONENTS) THEN
6682  DO component_idx=1,number_of_components
6683  new_topology(component_idx)%PTR=>mesh%TOPOLOGY(component_idx)%PTR
6684  ENDDO !component_idx
6685  ELSE !NUMBER_OF_COMPONENTS>MESH%NUMBER_OF_COMPONENTS
6686  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
6687  new_topology(component_idx)%PTR=>mesh%TOPOLOGY(component_idx)%PTR
6688  ENDDO !component_idx
6689 !!TODO \todo sort out mesh_topology initialise/finalise so that they allocate and deal with this below then call that routine
6690  DO component_idx=mesh%NUMBER_OF_COMPONENTS+1,number_of_components
6691  ALLOCATE(new_topology(component_idx)%PTR,stat=err)
6692  IF(err/=0) CALL flagerror("Could not allocate new topology component",err,error,*999)
6693  new_topology(component_idx)%PTR%mesh=>mesh
6694  new_topology(component_idx)%PTR%meshComponentNumber=component_idx
6695  NULLIFY(new_topology(component_idx)%PTR%elements)
6696  NULLIFY(new_topology(component_idx)%PTR%nodes)
6697  NULLIFY(new_topology(component_idx)%PTR%dofs)
6698  NULLIFY(new_topology(component_idx)%PTR%dataPoints)
6699  !Initialise the topology components
6700  CALL mesh_topology_elements_initialise(new_topology(component_idx)%PTR,err,error,*999)
6701  CALL meshtopologynodesinitialise(new_topology(component_idx)%PTR,err,error,*999)
6702  CALL meshtopologydofsinitialise(new_topology(component_idx)%PTR,err,error,*999)
6703  CALL mesh_topology_data_points_initialise(new_topology(component_idx)%PTR,err,error,*999)
6704  ENDDO !component_idx
6705  ENDIF
6706  IF(ASSOCIATED(mesh%TOPOLOGY)) DEALLOCATE(mesh%TOPOLOGY)
6707  mesh%TOPOLOGY=>new_topology
6708  mesh%NUMBER_OF_COMPONENTS=number_of_components
6709  ENDIF
6710  ENDIF
6711  ELSE
6712  local_error="The specified number of mesh components ("//trim(number_to_vstring(number_of_components,"*",err,error))// &
6713  & ") is illegal. You must have >0 mesh components"
6714  CALL flagerror(local_error,err,error,*999)
6715  ENDIF
6716  ELSE
6717  CALL flagerror("Mesh is not associated",err,error,*999)
6718  ENDIF
6719 
6720  exits("MESH_NUMBER_OF_COMPONENTS_SET")
6721  RETURN
6722 !!TODO: tidy up memory deallocation on error
6723 999 errorsexits("MESH_NUMBER_OF_COMPONENTS_SET",err,error)
6724  RETURN 1
6725 
6726  END SUBROUTINE mesh_number_of_components_set
6727 
6728  !
6729  !================================================================================================================================
6730  !
6731 
6733  SUBROUTINE mesh_number_of_elements_get(MESH,NUMBER_OF_ELEMENTS,ERR,ERROR,*)
6734 
6735  !Argument variables
6736  TYPE(mesh_type), POINTER :: mesh
6737  INTEGER(INTG), INTENT(OUT) :: number_of_elements
6738  INTEGER(INTG), INTENT(OUT) :: err
6739  TYPE(varying_string), INTENT(OUT) :: error
6740  !Local Variables
6741 
6742  enters("MESH_NUMBER_OF_ELEMENTS_GET",err,error,*999)
6743 
6744  IF(ASSOCIATED(mesh)) THEN
6745  IF(mesh%MESH_FINISHED) THEN
6746  number_of_elements=mesh%NUMBER_OF_ELEMENTS
6747  ELSE
6748  CALL flagerror("Mesh has not been finished",err,error,*999)
6749  ENDIF
6750  ELSE
6751  CALL flagerror("Mesh is not associated",err,error,*999)
6752  ENDIF
6753 
6754  exits("MESH_NUMBER_OF_ELEMENTS_GET")
6755  RETURN
6756 999 errorsexits("MESH_NUMBER_OF_ELEMENTS_GET",err,error)
6757  RETURN
6758  END SUBROUTINE mesh_number_of_elements_get
6759 
6760  !
6761  !================================================================================================================================
6762  !
6763 
6765  SUBROUTINE mesh_number_of_elements_set(MESH,NUMBER_OF_ELEMENTS,ERR,ERROR,*)
6766 
6767  !Argument variables
6768  TYPE(mesh_type), POINTER :: mesh
6769  INTEGER(INTG), INTENT(IN) :: number_of_elements
6770  INTEGER(INTG), INTENT(OUT) :: err
6771  TYPE(varying_string), INTENT(OUT) :: error
6772  !Local Variables
6773  INTEGER(INTG) :: component_idx
6774  TYPE(varying_string) :: local_error
6775 
6776  enters("MESH_NUMBER_OF_ELEMENTS_SET",err,error,*999)
6777 
6778  IF(ASSOCIATED(mesh)) THEN
6779  IF(number_of_elements>0) THEN
6780  IF(mesh%MESH_FINISHED) THEN
6781  CALL flagerror("Mesh has been finished.",err,error,*999)
6782  ELSE
6783  IF(number_of_elements/=mesh%NUMBER_OF_ELEMENTS) THEN
6784  IF(ASSOCIATED(mesh%TOPOLOGY)) THEN
6785  DO component_idx=1,mesh%NUMBER_OF_COMPONENTS
6786  IF(ASSOCIATED(mesh%TOPOLOGY(component_idx)%PTR)) THEN
6787  IF(ASSOCIATED(mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS)) THEN
6788  IF(mesh%TOPOLOGY(component_idx)%PTR%ELEMENTS%NUMBER_OF_ELEMENTS>0) THEN
6789 !!TODO: Reallocate the elements and copy information.
6790  CALL flagerror("Not implemented.",err,error,*999)
6791  ENDIF
6792  ENDIF
6793  ELSE
6794  CALL flagerror("Mesh topology component pointer is not associated.",err,error,*999)
6795  ENDIF
6796  ENDDO !component_idx
6797  ELSE
6798  CALL flagerror("Mesh topology is not associated.",err,error,*999)
6799  ENDIF
6800  mesh%NUMBER_OF_ELEMENTS=number_of_elements
6801  ENDIF
6802  ENDIF
6803  ELSE
6804  local_error="The specified number of elements ("//trim(number_to_vstring(number_of_elements,"*",err,error))// &
6805  & ") is invalid. You must have > 0 elements."
6806  CALL flagerror(local_error,err,error,*999)
6807  ENDIF
6808  ELSE
6809  CALL flagerror("Mesh is not associated.",err,error,*999)
6810  ENDIF
6811 
6812  exits("MESH_NUMBER_OF_ELEMENTS_SET")
6813  RETURN
6814 999 errorsexits("MESH_NUMBER_OF_ELEMENTS_SET",err,error)
6815  RETURN 1
6816 
6817  END SUBROUTINE mesh_number_of_elements_set
6818 
6819  !
6820  !================================================================================================================================
6821  !
6822 
6824  SUBROUTINE meshregionget(mesh,region,err,error,*)
6825 
6826  !Argument variables
6827  TYPE(mesh_type), POINTER :: mesh
6828  TYPE(region_type), POINTER :: region
6829  INTEGER(INTG), INTENT(OUT) :: err
6830  TYPE(varying_string), INTENT(OUT) :: error
6831  !Local Variables
6832  TYPE(interface_type), POINTER :: interface
6833  TYPE(region_type), POINTER :: parentregion
6834  TYPE(varying_string) :: localerror
6835 
6836  enters("MeshRegionGet",err,error,*999)
6837 
6838  IF(ASSOCIATED(mesh)) THEN
6839  IF(ASSOCIATED(region)) THEN
6840  CALL flagerror("Region is already associated.",err,error,*999)
6841  ELSE
6842  NULLIFY(region)
6843  NULLIFY(interface)
6844  region=>mesh%region
6845  IF(.NOT.ASSOCIATED(region)) THEN
6846  interface=>mesh%interface
6847  IF(ASSOCIATED(interface)) THEN
6848  parentregion=>interface%PARENT_REGION
6849  IF(ASSOCIATED(parentregion)) THEN
6850  region=>parentregion
6851  ELSE
6852  localerror="The parent region not associated for mesh number "// &
6853  & trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))//" of interface number "// &
6854  & trim(numbertovstring(interface%USER_NUMBER,"*",err,error))//"."
6855  CALL flagerror(localerror,err,error,*999)
6856  ENDIF
6857  ELSE
6858  localerror="The region or interface is not associated for mesh number "// &
6859  & trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))//"."
6860  CALL flagerror(localerror,err,error,*999)
6861  ENDIF
6862  ENDIF
6863  ENDIF
6864  ELSE
6865  CALL flagerror("Mesh is not associated.",err,error,*999)
6866  ENDIF
6867 
6868  exits("MeshRegionGet")
6869  RETURN
6870 999 errorsexits("MeshRegionGet",err,error)
6871  RETURN 1
6872 
6873  END SUBROUTINE meshregionget
6874 
6875  !
6876  !================================================================================================================================
6877  !
6878 
6880  SUBROUTINE mesh_surrounding_elements_calculate_set(MESH,SURROUNDING_ELEMENTS_CALCULATE_FLAG,ERR,ERROR,*)
6881 
6882  !Argument variables
6883  TYPE(mesh_type), POINTER :: mesh
6884  LOGICAL, INTENT(IN) :: surrounding_elements_calculate_flag
6885  INTEGER(INTG), INTENT(OUT) :: err
6886  TYPE(varying_string), INTENT(OUT) :: error
6887 
6888  enters("MESH_SURROUNDING_ELEMENTS_CALCULATE_SET",err,error,*999)
6889 
6890  IF(ASSOCIATED(mesh)) THEN
6891  IF(mesh%MESH_FINISHED) THEN
6892  CALL flagerror("Mesh has been finished.",err,error,*999)
6893  ELSE
6894  mesh%SURROUNDING_ELEMENTS_CALCULATE=surrounding_elements_calculate_flag
6895  ENDIF
6896  ELSE
6897  CALL flagerror("Mesh is not associated.",err,error,*999)
6898  ENDIF
6899 
6900  exits("MESH_SURROUNDING_ELEMENTS_CALCULATE_SET")
6901  RETURN
6902 999 errorsexits("MESH_SURROUNDING_ELEMENTS_CALCULATE_SET",err,error)
6903  RETURN 1
6904 
6905  END SUBROUTINE mesh_surrounding_elements_calculate_set
6906 
6907  !
6908  !================================================================================================================================
6909  !
6910 
6912  SUBROUTINE meshtopologycalculate(topology,err,error,*)
6913 
6914  !Argument variables
6915  TYPE(meshcomponenttopologytype), POINTER :: topology
6916  INTEGER(INTG), INTENT(OUT) :: err
6917  TYPE(varying_string), INTENT(OUT) :: error
6918  !Local Variables
6919 
6920  enters("MeshTopologyCalculate",err,error,*999)
6921 
6922  IF(ASSOCIATED(topology)) THEN
6923  !Calculate the nodes used in the mesh
6924  CALL meshtopologynodescalculate(topology,err,error,*999)
6925  !Calculate the elements surrounding the nodes in a mesh
6926  CALL meshtopologysurroundingelementscalculate(topology,err,error,*999)
6927  !Calculate the number of derivatives at each node in a mesh
6928  CALL meshtopologynodesderivativescalculate(topology,err,error,*999)
6929  !Calculate the number of versions for each derivative at each node in a mesh
6930  CALL meshtopologynodesversioncalculate(topology,err,error,*999)
6931  !Calculate the elements surrounding the elements in the mesh
6932  CALL meshtopology_elementsadjacentelementscalculate(topology,err,error,*999)
6933  !Calculate the boundary nodes and elements in the mesh
6934  CALL meshtopologyboundarycalculate(topology,err,error,*999)
6935  !Calculate the elements surrounding the elements in the mesh
6936  CALL meshtopologydofscalculate(topology,err,error,*999)
6937  ELSE
6938  CALL flagerror("Topology is not associated",err,error,*999)
6939  ENDIF
6940 
6941  exits("MeshTopologyCalculate")
6942  RETURN
6943 999 errorsexits("MeshTopologyCalculate",err,error)
6944  RETURN 1
6945 
6946  END SUBROUTINE meshtopologycalculate
6947 
6948  !
6949  !===============================================================================================================================
6950  !
6951 
6953  SUBROUTINE meshtopologyboundarycalculate(topology,err,error,*)
6954 
6955  !Argument variables
6956  TYPE(meshcomponenttopologytype), POINTER :: topology
6957  INTEGER(INTG), INTENT(OUT) :: err
6958  TYPE(varying_string), INTENT(OUT) :: error
6959  !Local Variables
6960  INTEGER(INTG) :: elementidx,localnodeidx,matchindex,nodeidx,xicoordidx,xidirection
6961  TYPE(basis_type), POINTER :: basis
6962  TYPE(meshelementstype), POINTER :: elements
6963  TYPE(meshnodestype), POINTER :: nodes
6964  TYPE(varying_string) :: localerror
6965 
6966  enters("MeshTopologyBoundaryCalculate",err,error,*999)
6967 
6968  IF(ASSOCIATED(topology)) THEN
6969  nodes=>topology%nodes
6970  IF(ASSOCIATED(nodes)) THEN
6971  elements=>topology%elements
6972  IF(ASSOCIATED(elements)) THEN
6973  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
6974  basis=>elements%elements(elementidx)%basis
6975  SELECT CASE(basis%type)
6976  CASE(basis_lagrange_hermite_tp_type)
6977  DO xicoordidx=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
6978  IF(xicoordidx/=0) THEN
6979  IF(elements%elements(elementidx)%ADJACENT_ELEMENTS(xicoordidx)%NUMBER_OF_ADJACENT_ELEMENTS==0) THEN
6980  elements%elements(elementidx)%BOUNDARY_ELEMENT=.true.
6981  IF(xicoordidx<0) THEN
6982  xidirection=-xicoordidx
6983  matchindex=1
6984  ELSE
6985  xidirection=xicoordidx
6986  matchindex=basis%NUMBER_OF_NODES_XIC(xicoordidx)
6987  ENDIF
6988  DO localnodeidx=1,basis%NUMBER_OF_NODES
6989  IF(basis%NODE_POSITION_INDEX(localnodeidx,xidirection)==matchindex) THEN
6990  nodeidx=elements%elements(elementidx)%MESH_ELEMENT_NODES(localnodeidx)
6991  nodes%nodes(nodeidx)%boundaryNode=.true.
6992  ENDIF
6993  ENDDO !nn
6994  ENDIF
6995  ENDIF
6996  ENDDO !xiCoordIdx
6997  CASE(basis_simplex_type)
6998  elements%elements(elementidx)%BOUNDARY_ELEMENT=.false.
6999  DO xicoordidx=1,basis%NUMBER_OF_XI_COORDINATES
7000  elements%elements(elementidx)%BOUNDARY_ELEMENT=elements%elements(elementidx)%BOUNDARY_ELEMENT.OR. &
7001  & elements%elements(elementidx)%ADJACENT_ELEMENTS(xicoordidx)%NUMBER_OF_ADJACENT_ELEMENTS==0
7002  IF(elements%elements(elementidx)%ADJACENT_ELEMENTS(xicoordidx)%NUMBER_OF_ADJACENT_ELEMENTS==0) THEN
7003  DO localnodeidx=1,basis%NUMBER_OF_NODES
7004  IF(basis%NODE_POSITION_INDEX(localnodeidx,xicoordidx)==1) THEN
7005  nodeidx=elements%elements(elementidx)%MESH_ELEMENT_NODES(localnodeidx)
7006  nodes%nodes(nodeidx)%boundaryNode=.true.
7007  ENDIF
7008  ENDDO !localNodeIdx
7009  ENDIF
7010  ENDDO !xiCoordIdx
7011  CASE(basis_serendipity_type)
7012  CALL flagerror("Not implemented.",err,error,*999)
7013  CASE(basis_auxilliary_type)
7014  CALL flagerror("Not implemented.",err,error,*999)
7015  CASE(basis_b_spline_tp_type)
7016  CALL flagerror("Not implemented.",err,error,*999)
7017  CASE(basis_fourier_lagrange_hermite_tp_type)
7018  CALL flagerror("Not implemented.",err,error,*999)
7019  CASE(basis_extended_lagrange_tp_type)
7020  CALL flagerror("Not implemented.",err,error,*999)
7021  CASE DEFAULT
7022  localerror="The basis type of "//trim(numbertovstring(basis%TYPE,"*",err,error))//" is invalid."
7023  CALL flagerror(localerror,err,error,*999)
7024  END SELECT
7025  ENDDO !elementIdx
7026  ELSE
7027  CALL flagerror("Topology elements is not associated.",err,error,*999)
7028  ENDIF
7029  ELSE
7030  CALL flagerror("Topology nodes is not associated.",err,error,*999)
7031  ENDIF
7032  ELSE
7033  CALL flagerror("Topology is not associated.",err,error,*999)
7034  ENDIF
7035 
7036  IF(diagnostics1) THEN
7037  CALL writestring(diagnostic_output_type,"Boundary elements:",err,error,*999)
7038  CALL writestringvalue(diagnostic_output_type,"Number of elements = ",elements%NUMBER_OF_ELEMENTS,err,error,*999)
7039  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
7040  CALL writestringvalue(diagnostic_output_type,"Element : ",elementidx,err,error,*999)
7041  CALL writestringvalue(diagnostic_output_type," Boundary element = ",elements%elements(elementidx)%BOUNDARY_ELEMENT, &
7042  & err,error,*999)
7043  ENDDO !elementIdx
7044  CALL writestring(diagnostic_output_type,"Boundary nodes:",err,error,*999)
7045  CALL writestringvalue(diagnostic_output_type,"Number of nodes = ",nodes%numberOfNodes,err,error,*999)
7046  DO nodeidx=1,nodes%numberOfNodes
7047  CALL writestringvalue(diagnostic_output_type,"Node : ",nodeidx,err,error,*999)
7048  CALL writestringvalue(diagnostic_output_type," Boundary node = ",nodes%nodes(nodeidx)%boundaryNode,err,error,*999)
7049  ENDDO !elementIdx
7050  ENDIF
7051 
7052  exits("MeshTopologyBoundaryCalculate")
7053  RETURN
7054 999 errorsexits("MeshTopologyBoundaryCalculate",err,error)
7055  RETURN 1
7056  END SUBROUTINE meshtopologyboundarycalculate
7057 
7058  !
7059  !===============================================================================================================================
7060  !
7061 
7063  SUBROUTINE meshtopologydofscalculate(topology,err,error,*)
7064 
7065  !Argument variables
7066  TYPE(meshcomponenttopologytype), POINTER :: topology
7067  INTEGER(INTG), INTENT(OUT) :: err
7068  TYPE(varying_string), INTENT(OUT) :: error
7069  !Local Variables
7070  INTEGER(INTG) :: derivativeidx,nodeidx,numberofdofs,versionidx
7071  TYPE(meshdofstype), POINTER :: dofs
7072  TYPE(meshnodestype), POINTER :: nodes
7073 
7074  enters("MeshTopologyDofsCalculate",err,error,*999)
7075 
7076  IF(ASSOCIATED(topology)) THEN
7077  nodes=>topology%nodes
7078  IF(ASSOCIATED(nodes)) THEN
7079  dofs=>topology%dofs
7080  IF(ASSOCIATED(dofs)) THEN
7081  numberofdofs=0
7082  DO nodeidx=1,nodes%numberOfNodes
7083  DO derivativeidx=1,nodes%nodes(nodeidx)%numberOfDerivatives
7084  ALLOCATE(nodes%nodes(nodeidx)%derivatives(derivativeidx)%dofIndex( &
7085  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%numberOfVersions),stat=err)
7086  IF(err/=0) CALL flagerror("Could not allocate mesh topology node derivative version dof index.",err,error,*999)
7087  DO versionidx=1,nodes%nodes(nodeidx)%derivatives(derivativeidx)%numberOfVersions
7088  numberofdofs=numberofdofs+1
7089  nodes%nodes(nodeidx)%derivatives(derivativeidx)%dofIndex(versionidx)=numberofdofs
7090  ENDDO !versionIdx
7091  ENDDO !derivativeIdx
7092  ENDDO !nodeIdx
7093  dofs%numberOfDofs=numberofdofs
7094  ELSE
7095  CALL flagerror("Topology dofs is not associated.",err,error,*999)
7096  ENDIF
7097  ELSE
7098  CALL flagerror("Topology nodes is not associated.",err,error,*999)
7099  ENDIF
7100  ELSE
7101  CALL flagerror("Topology is not associated.",err,error,*999)
7102  ENDIF
7103 
7104  exits("MeshTopologyDofsCalculate")
7105  RETURN
7106 999 errorsexits("MeshTopologyDofsCalculate",err,error)
7107  RETURN 1
7108 
7109  END SUBROUTINE meshtopologydofscalculate
7110 
7111  !
7112  !===============================================================================================================================
7113  !
7114 
7116  SUBROUTINE meshtopologydofsfinalise(dofs,err,error,*)
7117 
7118  !Argument variables
7119  TYPE(meshdofstype), POINTER :: dofs
7120  INTEGER(INTG), INTENT(OUT) :: err
7121  TYPE(varying_string), INTENT(OUT) :: error
7122  !Local Variables
7123 
7124  enters("MeshTopologyDofsFinalise",err,error,*999)
7125 
7126  IF(ASSOCIATED(dofs)) THEN
7127  DEALLOCATE(dofs)
7128  ENDIF
7129 
7130  exits("MeshTopologyDofsFinalise")
7131  RETURN
7132 999 errorsexits("MeshTopologyDofsFinalise",err,error)
7133  RETURN 1
7134 
7135  END SUBROUTINE meshtopologydofsfinalise
7136 
7137  !
7138  !================================================================================================================================
7139  !
7140 
7142  SUBROUTINE meshtopologydofsinitialise(topology,err,error,*)
7143 
7144  !Argument variables
7145  TYPE(meshcomponenttopologytype), POINTER :: topology
7146  INTEGER(INTG), INTENT(OUT) :: err
7147  TYPE(varying_string), INTENT(OUT) :: error
7148  !Local Variables
7149  INTEGER(INTG) :: dummyerr
7150  TYPE(varying_string) :: dummyerror
7151 
7152  enters("MeshTopologyDofsInitialise",err,error,*998)
7153 
7154  IF(ASSOCIATED(topology)) THEN
7155  IF(ASSOCIATED(topology%dofs)) THEN
7156  CALL flagerror("Mesh already has topology dofs associated",err,error,*998)
7157  ELSE
7158  ALLOCATE(topology%dofs,stat=err)
7159  IF(err/=0) CALL flagerror("Could not allocate topology dofs",err,error,*999)
7160  topology%dofs%numberOfDofs=0
7161  topology%dofs%meshComponentTopology=>topology
7162  ENDIF
7163  ELSE
7164  CALL flagerror("Topology is not associated",err,error,*998)
7165  ENDIF
7166 
7167  exits("MeshTopologyDofsInitialise")
7168  RETURN
7169 999 CALL meshtopologydofsfinalise(topology%dofs,dummyerr,dummyerror,*998)
7170 998 errorsexits("MeshTopologyDofsInitialise",err,error)
7171  RETURN 1
7172 
7173  END SUBROUTINE meshtopologydofsinitialise
7174 
7175  !
7176  !================================================================================================================================
7177  !
7178 
7180  SUBROUTINE mesh_topology_elements_create_finish(ELEMENTS,ERR,ERROR,*)
7181 
7182  !Argument variables
7183  TYPE(meshelementstype), POINTER :: elements
7184  INTEGER(INTG), INTENT(OUT) :: err
7185  TYPE(varying_string), INTENT(OUT) :: error
7186  !Local Variables
7187  INTEGER(INTG) :: ne
7188  TYPE(mesh_type), POINTER :: mesh
7189  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
7190 
7191  enters("MESH_TOPOLOGY_ELEMENTS_CREATE_FINISH",err,error,*999)
7192 
7193  IF(ASSOCIATED(elements)) THEN
7194  IF(elements%ELEMENTS_FINISHED) THEN
7195  CALL flagerror("Mesh elements have already been finished.",err,error,*999)
7196  ELSE
7197  elements%ELEMENTS_FINISHED=.true.
7198  ENDIF
7199  ELSE
7200  CALL flagerror("Mesh elements is not associated.",err,error,*999)
7201  ENDIF
7202 
7203  IF(diagnostics1) THEN
7204  meshcomponenttopology=>elements%meshComponentTopology
7205  IF(ASSOCIATED(meshcomponenttopology)) THEN
7206  mesh=>meshcomponenttopology%mesh
7207  IF(ASSOCIATED(mesh)) THEN
7208  CALL write_string_value(diagnostic_output_type,"Number of global elements = ",mesh%NUMBER_OF_ELEMENTS, &
7209  & err,error,*999)
7210  DO ne=1,mesh%NUMBER_OF_ELEMENTS
7211  CALL write_string_value(diagnostic_output_type," Element = ",ne,err,error,*999)
7212  CALL write_string_value(diagnostic_output_type," Global number = ",elements%ELEMENTS(ne)%GLOBAL_NUMBER, &
7213  & err,error,*999)
7214  CALL write_string_value(diagnostic_output_type," User number = ",elements%ELEMENTS(ne)%USER_NUMBER, &
7215  & err,error,*999)
7216  IF(ASSOCIATED(elements%ELEMENTS(ne)%BASIS)) THEN
7217  CALL write_string_value(diagnostic_output_type," Basis number = ",elements%ELEMENTS(ne)%BASIS% &
7218  & user_number,err,error,*999)
7219  ELSE
7220  CALL flagerror("Basis is not associated.",err,error,*999)
7221  ENDIF
7222  IF(ALLOCATED(elements%ELEMENTS(ne)%USER_ELEMENT_NODES)) THEN
7223  CALL write_string_vector(diagnostic_output_type,1,1,elements%ELEMENTS(ne)% BASIS%NUMBER_OF_NODES,8,8, &
7224  & elements%ELEMENTS(ne)%USER_ELEMENT_NODES,'(" User element nodes =",8(X,I6))','(26X,8(X,I6))', &
7225  & err,error,*999)
7226  ELSE
7227  CALL flagerror("User element nodes are not associated.",err,error,*999)
7228  ENDIF
7229  IF(ALLOCATED(elements%ELEMENTS(ne)%GLOBAL_ELEMENT_NODES)) THEN
7230  CALL write_string_vector(diagnostic_output_type,1,1,elements%ELEMENTS(ne)%BASIS%NUMBER_OF_NODES,8,8, &
7231  & elements%ELEMENTS(ne)%GLOBAL_ELEMENT_NODES,'(" Global element nodes =",8(X,I6))','(26X,8(X,I6))', &
7232  & err,error,*999)
7233  ELSE
7234  CALL flagerror("Global element nodes are not associated.",err,error,*999)
7235  ENDIF
7236  ENDDO !ne
7237  ELSE
7238  CALL flagerror("Mesh component topology mesh is not associated.",err,error,*999)
7239  ENDIF
7240  ELSE
7241  CALL flagerror("Mesh elements mesh component topology is not associated.",err,error,*999)
7242  ENDIF
7243  ENDIF
7244 
7245  exits("MESH_TOPOLOGY_ELEMENTS_CREATE_FINISH")
7246  RETURN
7247 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_CREATE_FINISH",err,error)
7248  RETURN 1
7249 
7250  END SUBROUTINE mesh_topology_elements_create_finish
7251 
7252  !
7253  !================================================================================================================================
7254  !
7255 
7257  SUBROUTINE mesh_topology_elements_create_start(MESH,MESH_COMPONENT_NUMBER,BASIS,ELEMENTS,ERR,ERROR,*)
7258 
7259  !Argument variables
7260  TYPE(mesh_type), POINTER :: mesh
7261  INTEGER(INTG), INTENT(IN) :: mesh_component_number
7262  TYPE(basis_type), POINTER :: basis
7263  TYPE(meshelementstype), POINTER :: elements
7264  INTEGER(INTG), INTENT(OUT) :: err
7265  TYPE(varying_string), INTENT(OUT) :: error
7266  !Local Variables
7267  INTEGER(INTG) :: dummy_err,insert_status,ne
7268  TYPE(varying_string) :: dummy_error,local_error
7269 
7270  enters("MESH_TOPOLOGY_ELEMENTS_CREATE_START",err,error,*999)
7271 
7272  IF(ASSOCIATED(mesh)) THEN
7273  IF(mesh_component_number>0.AND.mesh_component_number<=mesh%NUMBER_OF_COMPONENTS) THEN
7274  IF(ASSOCIATED(elements)) THEN
7275  CALL flagerror("Elements is already associated.",err,error,*999)
7276  ELSE
7277  IF(ASSOCIATED(mesh%TOPOLOGY(mesh_component_number)%PTR)) THEN
7278  IF(ASSOCIATED(mesh%TOPOLOGY(mesh_component_number)%PTR%ELEMENTS)) THEN
7279  elements=>mesh%TOPOLOGY(mesh_component_number)%PTR%ELEMENTS
7280  IF(ASSOCIATED(elements%ELEMENTS)) THEN
7281  CALL flagerror("Mesh topology already has elements associated",err,error,*998)
7282  ELSE
7283  IF(ASSOCIATED(basis)) THEN
7284  mesh%TOPOLOGY(mesh_component_number)%PTR%meshComponentNumber=mesh_component_number
7285  ALLOCATE(elements%ELEMENTS(mesh%NUMBER_OF_ELEMENTS),stat=err)
7286  IF(err/=0) CALL flagerror("Could not allocate individual elements",err,error,*999)
7287  elements%NUMBER_OF_ELEMENTS=mesh%NUMBER_OF_ELEMENTS !Psuedo inheritance of the number of elements
7288  CALL tree_create_start(elements%ELEMENTS_TREE,err,error,*999)
7289  CALL tree_insert_type_set(elements%ELEMENTS_TREE,tree_no_duplicates_allowed,err,error,*999)
7290  CALL tree_create_finish(elements%ELEMENTS_TREE,err,error,*999)
7291  elements%ELEMENTS_FINISHED=.false.
7292  !Set up the default values and allocate element structures
7293  DO ne=1,elements%NUMBER_OF_ELEMENTS
7294  CALL mesh_topology_element_initialise(elements%ELEMENTS(ne),err,error,*999)
7295  elements%ELEMENTS(ne)%GLOBAL_NUMBER=ne
7296  elements%ELEMENTS(ne)%USER_NUMBER=ne
7297  CALL tree_item_insert(elements%ELEMENTS_TREE,ne,ne,insert_status,err,error,*999)
7298  elements%ELEMENTS(ne)%BASIS=>basis
7299  ALLOCATE(elements%ELEMENTS(ne)%USER_ELEMENT_NODES(basis%NUMBER_OF_NODES),stat=err)
7300  IF(err/=0) CALL flagerror("Could not allocate user element nodes",err,error,*999)
7301  ALLOCATE(elements%ELEMENTS(ne)%GLOBAL_ELEMENT_NODES(basis%NUMBER_OF_NODES),stat=err)
7302  IF(err/=0) CALL flagerror("Could not allocate global element nodes",err,error,*999)
7303  elements%ELEMENTS(ne)%USER_ELEMENT_NODES=1
7304  elements%ELEMENTS(ne)%GLOBAL_ELEMENT_NODES=1
7305  ALLOCATE(elements%ELEMENTS(ne)%USER_ELEMENT_NODE_VERSIONS(basis%MAXIMUM_NUMBER_OF_DERIVATIVES, &
7306  & basis%NUMBER_OF_NODES),stat=err)
7307  IF(err/=0) CALL flagerror("Could not allocate global element nodes versions",err,error,*999)
7308  elements%ELEMENTS(ne)%USER_ELEMENT_NODE_VERSIONS = 1
7309  ENDDO !ne
7310  ELSE
7311  CALL flagerror("Basis is not associated",err,error,*999)
7312  ENDIF
7313  ENDIF
7314  ELSE
7315  CALL flagerror("Mesh topology elements is not associated",err,error,*998)
7316  ENDIF
7317  ELSE
7318  CALL flagerror("Mesh topology is not associated",err,error,*998)
7319  ENDIF
7320  ENDIF
7321  ELSE
7322  local_error="The specified mesh component number of "//trim(number_to_vstring(mesh_component_number,"*",err,error))// &
7323  & " is invalid. The component number must be between 1 and "// &
7324  & trim(number_to_vstring(mesh%NUMBER_OF_COMPONENTS,"*",err,error))
7325  CALL flagerror(local_error,err,error,*998)
7326  ENDIF
7327  ELSE
7328  CALL flagerror("Mesh is not associated",err,error,*998)
7329  ENDIF
7330 
7331  exits("MESH_TOPOLOGY_ELEMENTS_CREATE_START")
7332  RETURN
7333 999 CALL mesh_topology_elements_finalise(elements,dummy_err,dummy_error,*998)
7334 998 NULLIFY(elements)
7335  errorsexits("MESH_TOPOLOGY_ELEMENTS_CREATE_START",err,error)
7336  RETURN 1
7337 
7338  END SUBROUTINE mesh_topology_elements_create_start
7339 
7340  !
7341  !================================================================================================================================
7342  !
7343 
7345  SUBROUTINE mesh_topology_elements_destroy(ELEMENTS,ERR,ERROR,*)
7346 
7347  !Argument variables
7348  TYPE(meshelementstype), POINTER :: elements
7349  INTEGER(INTG), INTENT(OUT) :: err
7350  TYPE(varying_string), INTENT(OUT) :: error
7351  !Local Variables
7352 
7353  enters("MESH_TOPOLOGY_ELEMENTS_DESTROY",err,error,*999)
7354 
7355  IF(ASSOCIATED(elements)) THEN
7356  CALL mesh_topology_elements_finalise(elements,err,error,*999)
7357  ELSE
7358  CALL flagerror("Mesh topology is not associated",err,error,*999)
7359  ENDIF
7360 
7361  exits("MESH_TOPOLOGY_ELEMENTS_DESTROY")
7362  RETURN
7363 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_DESTROY",err,error)
7364  RETURN 1
7365  END SUBROUTINE mesh_topology_elements_destroy
7366 
7367  !
7368  !================================================================================================================================
7369  !
7370 
7372  SUBROUTINE mesh_topology_element_finalise(ELEMENT,ERR,ERROR,*)
7373 
7374  !Argument variables
7375  TYPE(mesh_element_type) :: element
7376  INTEGER(INTG), INTENT(OUT) :: err
7377  TYPE(varying_string), INTENT(OUT) :: error
7378  !Local Variables
7379  INTEGER(INTG) :: nic
7380 
7381  enters("MESH_TOPOLOGY_ELEMENT_FINALISE",err,error,*999)
7382 
7383  IF(ALLOCATED(element%USER_ELEMENT_NODE_VERSIONS)) DEALLOCATE(element%USER_ELEMENT_NODE_VERSIONS)
7384  IF(ALLOCATED(element%USER_ELEMENT_NODES)) DEALLOCATE(element%USER_ELEMENT_NODES)
7385  IF(ALLOCATED(element%GLOBAL_ELEMENT_NODES)) DEALLOCATE(element%GLOBAL_ELEMENT_NODES)
7386  IF(ALLOCATED(element%MESH_ELEMENT_NODES)) DEALLOCATE(element%MESH_ELEMENT_NODES)
7387  IF(ALLOCATED(element%ADJACENT_ELEMENTS)) THEN
7388  DO nic=lbound(element%ADJACENT_ELEMENTS,1),ubound(element%ADJACENT_ELEMENTS,1)
7389  CALL mesh_adjacent_element_finalise(element%ADJACENT_ELEMENTS(nic),err,error,*999)
7390  ENDDO !nic
7391  DEALLOCATE(element%ADJACENT_ELEMENTS)
7392  ENDIF
7393 
7394  exits("MESH_TOPOLOGY_ELEMENT_FINALISE")
7395  RETURN
7396 999 errorsexits("MESH_TOPOLOGY_ELEMENT_FINALISE",err,error)
7397  RETURN 1
7398  END SUBROUTINE mesh_topology_element_finalise
7399 
7400  !
7401  !================================================================================================================================
7402  !
7403 
7405  SUBROUTINE mesh_topology_elements_get(MESH,MESH_COMPONENT_NUMBER,ELEMENTS,ERR,ERROR,*)
7406 
7407  !Argument variables
7408  TYPE(mesh_type), POINTER :: mesh
7409  INTEGER(INTG), INTENT(IN) :: mesh_component_number
7410  TYPE(meshelementstype), POINTER :: elements
7411  INTEGER(INTG), INTENT(OUT) :: err
7412  TYPE(varying_string), INTENT(OUT) :: error
7413  !Local Variables
7414  TYPE(varying_string) :: local_error
7415 
7416  enters("MESH_TOPOLOGY_ELEMENTS_GET",err,error,*998)
7417 
7418  IF(ASSOCIATED(mesh)) THEN
7419  IF(mesh_component_number>0.AND.mesh_component_number<=mesh%NUMBER_OF_COMPONENTS) THEN
7420  IF(ASSOCIATED(elements)) THEN
7421  CALL flagerror("Elements is already associated.",err,error,*998)
7422  ELSE
7423  IF(ASSOCIATED(mesh%TOPOLOGY(mesh_component_number)%PTR)) THEN
7424  IF(ASSOCIATED(mesh%TOPOLOGY(mesh_component_number)%PTR%ELEMENTS)) THEN
7425  elements=>mesh%TOPOLOGY(mesh_component_number)%PTR%ELEMENTS
7426  ELSE
7427  CALL flagerror("Mesh topology elements is not associated",err,error,*999)
7428  ENDIF
7429  ELSE
7430  CALL flagerror("Mesh topology is not associated",err,error,*999)
7431  ENDIF
7432  ENDIF
7433  ELSE
7434  local_error="The specified mesh component number of "//trim(number_to_vstring(mesh_component_number,"*",err,error))// &
7435  & " is invalid. The component number must be between 1 and "// &
7436  & trim(number_to_vstring(mesh%NUMBER_OF_COMPONENTS,"*",err,error))
7437  CALL flagerror(local_error,err,error,*999)
7438  ENDIF
7439  ELSE
7440  CALL flagerror("Mesh is not associated",err,error,*998)
7441  ENDIF
7442 
7443  exits("MESH_TOPOLOGY_ELEMENTS_GET")
7444  RETURN
7445 999 NULLIFY(elements)
7446 998 errorsexits("MESH_TOPOLOGY_ELEMENTS_GET",err,error)
7447  RETURN 1
7448 
7449  END SUBROUTINE mesh_topology_elements_get
7450 
7451  !
7452  !================================================================================================================================
7453  !
7454 
7456  SUBROUTINE mesh_topology_element_initialise(ELEMENT,ERR,ERROR,*)
7457 
7458  !Argument variables
7459  TYPE(mesh_element_type) :: element
7460  INTEGER(INTG), INTENT(OUT) :: err
7461  TYPE(varying_string), INTENT(OUT) :: error
7462  !Local Variables
7463 
7464  enters("MESH_TOPOLOGY_ELEMENT_INITIALISE",err,error,*999)
7465 
7466  element%USER_NUMBER=0
7467  element%GLOBAL_NUMBER=0
7468  NULLIFY(element%BASIS)
7469  element%BOUNDARY_ELEMENT=.false.
7470 
7471  exits("MESH_TOPOLOGY_ELEMENT_INITIALISE")
7472  RETURN
7473 999 errorsexits("MESH_TOPOLOGY_ELEMENT_INITIALISE",err,error)
7474  RETURN 1
7475  END SUBROUTINE mesh_topology_element_initialise
7476 
7477  !
7478  !================================================================================================================================
7479  !
7480 
7481 !!MERGE: Take user number
7482 
7484  SUBROUTINE mesh_topology_elements_element_basis_get(GLOBAL_NUMBER,ELEMENTS,BASIS,ERR,ERROR,*)
7485 
7486  !Argument variables
7487  INTEGER(INTG), INTENT(IN) :: global_number
7488  TYPE(meshelementstype), POINTER :: elements
7489  TYPE(basis_type), POINTER :: basis
7490  INTEGER(INTG), INTENT(OUT) :: err
7491  TYPE(varying_string), INTENT(OUT) :: error
7492  !Local Variables
7493  TYPE(mesh_element_type), POINTER :: element
7494  TYPE(varying_string) :: local_error
7495 
7496  enters("MESH_TOPOLOGY_ELEMENTS_ELEMENT_BASIS_GET",err,error,*999)
7497 
7498  IF(ASSOCIATED(elements)) THEN
7499  IF(.NOT.elements%ELEMENTS_FINISHED) THEN
7500  CALL flagerror("Elements have been finished",err,error,*999)
7501  ELSE
7502  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
7503  element=>elements%ELEMENTS(global_number)
7504  basis=>element%BASIS
7505  ELSE
7506  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
7507  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))
7508  CALL flagerror(local_error,err,error,*999)
7509  ENDIF
7510  ENDIF
7511  ELSE
7512  CALL flagerror("Elements is not associated",err,error,*999)
7513  ENDIF
7514 
7515  exits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_BASIS_GET")
7516  RETURN
7517 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_BASIS_GET",err,error)
7518  RETURN 1
7519 
7520  END SUBROUTINE mesh_topology_elements_element_basis_get
7521 
7522  !
7523  !================================================================================================================================
7524  !
7525 
7527  SUBROUTINE mesh_topology_elements_element_basis_set(GLOBAL_NUMBER,ELEMENTS,BASIS,ERR,ERROR,*)
7528 
7529  !Argument variables
7530  INTEGER(INTG), INTENT(IN) :: global_number
7531  TYPE(meshelementstype), POINTER :: elements
7532  TYPE(basis_type), POINTER :: basis
7533  INTEGER(INTG), INTENT(OUT) :: err
7534  TYPE(varying_string), INTENT(OUT) :: error
7535  !Local Variables
7536  INTEGER(INTG), ALLOCATABLE :: new_user_element_nodes(:),new_global_element_nodes(:),new_user_element_node_versions(:,:)
7537  INTEGER(INTG) :: overlapping_number_nodes,overlapping_number_derivatives
7538  TYPE(mesh_element_type), POINTER :: element
7539  TYPE(varying_string) :: local_error
7540 
7541  enters("MESH_TOPOLOGY_ELEMENTS_ELEMENT_BASIS_SET",err,error,*999)
7542 
7543  IF(ASSOCIATED(elements)) THEN
7544  IF(elements%ELEMENTS_FINISHED) THEN
7545  CALL flagerror("Elements have been finished",err,error,*999)
7546  ELSE
7547  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
7548  IF(ASSOCIATED(basis)) THEN
7549  element=>elements%ELEMENTS(global_number)
7550  IF(element%BASIS%NUMBER_OF_NODES/=basis%NUMBER_OF_NODES.OR. &
7551  & element%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES/=basis%MAXIMUM_NUMBER_OF_DERIVATIVES) THEN
7552  !Allocate new user and global element nodes
7553  ALLOCATE(new_user_element_nodes(basis%NUMBER_OF_NODES),stat=err)
7554  IF(err/=0) CALL flagerror("Could not allocate new user element nodes",err,error,*999)
7555  ALLOCATE(new_global_element_nodes(basis%NUMBER_OF_NODES),stat=err)
7556  IF(err/=0) CALL flagerror("Could not allocate new user element nodes",err,error,*999)
7557  ALLOCATE(new_user_element_node_versions(basis%MAXIMUM_NUMBER_OF_DERIVATIVES, &
7558  & basis%NUMBER_OF_NODES),stat=err)
7559  IF(err/=0) CALL flagerror("Could not allocate element node versions",err,error,*999)
7560 
7561  overlapping_number_nodes=min(basis%NUMBER_OF_NODES,element%BASIS%NUMBER_OF_NODES)
7562  overlapping_number_derivatives=min(basis%MAXIMUM_NUMBER_OF_DERIVATIVES,element%BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES)
7563 
7564  !Set default values
7565  new_user_element_node_versions=1
7566  new_user_element_nodes(overlapping_number_nodes+1:)=0
7567  new_global_element_nodes(overlapping_number_nodes+1:)=0
7568  !Copy previous values
7569  new_user_element_nodes(1:overlapping_number_nodes)=element%USER_ELEMENT_NODES(1:overlapping_number_nodes)
7570  new_global_element_nodes(1:overlapping_number_nodes)=element%GLOBAL_ELEMENT_NODES(1:overlapping_number_nodes)
7571  new_user_element_node_versions(1:overlapping_number_derivatives,1:overlapping_number_nodes)= &
7572  & element%USER_ELEMENT_NODE_VERSIONS(1:overlapping_number_derivatives,1:overlapping_number_nodes)
7573 
7574  !Replace arrays with new ones
7575  CALL move_alloc(new_user_element_node_versions,element%USER_ELEMENT_NODE_VERSIONS)
7576  CALL move_alloc(new_user_element_nodes,element%USER_ELEMENT_NODES)
7577  CALL move_alloc(new_global_element_nodes,element%GLOBAL_ELEMENT_NODES)
7578  ENDIF
7579  element%BASIS=>basis
7580  ELSE
7581  CALL flagerror("Basis is not associated",err,error,*999)
7582  ENDIF
7583  ELSE
7584  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
7585  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))
7586  CALL flagerror(local_error,err,error,*999)
7587  ENDIF
7588  ENDIF
7589  ELSE
7590  CALL flagerror("Elements is not associated",err,error,*999)
7591  ENDIF
7592 
7593  exits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_BASIS_SET")
7594  RETURN
7595 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_BASIS_SET",err,error)
7596  RETURN 1
7597 
7598  END SUBROUTINE mesh_topology_elements_element_basis_set
7599 
7600  !
7601  !================================================================================================================================
7602  !
7603 
7605  SUBROUTINE mesh_topology_elements_adjacent_element_get(GLOBAL_NUMBER,ELEMENTS,ADJACENT_ELEMENT_XI,ADJACENT_ELEMENT_NUMBER, &
7606  & err,error,*)
7607 
7608  !Argument variables
7609  INTEGER(INTG), INTENT(IN) :: global_number
7610  TYPE(meshelementstype), POINTER :: elements
7611  INTEGER(INTG), INTENT(IN) :: adjacent_element_xi
7612  INTEGER(INTG), INTENT(OUT) :: adjacent_element_number
7613  INTEGER(INTG), INTENT(OUT) :: err
7614  TYPE(varying_string), INTENT(OUT) :: error
7615  !Local Variables
7616  TYPE(varying_string) :: local_error
7617 
7618  enters("MESH_TOPOLOGY_ELEMENTS_ADJACENT_ELEMENT_GET",err,error,*999)
7619 
7620  IF(ASSOCIATED(elements)) THEN
7621  IF(.NOT.elements%ELEMENTS_FINISHED) THEN
7622  CALL flagerror("Elements have not been finished",err,error,*999)
7623  ELSE
7624  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
7625  IF(adjacent_element_xi>=-elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_XI .AND. &
7626  & adjacent_element_xi<=elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_XI) THEN
7627  IF(elements%ELEMENTS(global_number)%ADJACENT_ELEMENTS(adjacent_element_xi)%NUMBER_OF_ADJACENT_ELEMENTS > 0) THEN !\todo Currently returns only the first adjacent element for now as the python binding require the output array size of the adjacent element to be known a-prior. Add routine to first output number of adjacent elements and then loop over all adjacent elements
7628  adjacent_element_number=elements%ELEMENTS(global_number)%ADJACENT_ELEMENTS(adjacent_element_xi)%ADJACENT_ELEMENTS(1)
7629  ELSE !Return 0 indicating the specified element has no adjacent elements in the specified xi coordinate direction.
7630  adjacent_element_number=0
7631  ENDIF
7632  ELSE
7633  local_error="The specified adjacent element xi is invalid. The supplied xi is "// &
7634  & trim(number_to_vstring(adjacent_element_xi,"*",err,error))//" and needs to be >=-"// &
7635  & trim(number_to_vstring(elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_XI,"*",err,error))//" and <="// &
7636  & trim(number_to_vstring(elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_XI,"*",err,error))//"."
7637  CALL flagerror(local_error,err,error,*999)
7638  ENDIF
7639  ELSE
7640  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
7641  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))
7642  CALL flagerror(local_error,err,error,*999)
7643  ENDIF
7644  ENDIF
7645  ELSE
7646  CALL flagerror("Elements is not associated",err,error,*999)
7647  ENDIF
7648 
7649  exits("MESH_TOPOLOGY_ELEMENTS_ADJACENT_ELEMENT_GET")
7650  RETURN
7651 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_ADJACENT_ELEMENT_GET",err,error)
7652  RETURN 1
7653 
7654  END SUBROUTINE mesh_topology_elements_adjacent_element_get
7655 
7656  !
7657  !================================================================================================================================
7658  !
7659 
7661  SUBROUTINE mesh_topology_elements_element_nodes_get(GLOBAL_NUMBER,ELEMENTS,USER_ELEMENT_NODES,ERR,ERROR,*)
7662 
7663  !Argument variables
7664  INTEGER(INTG), INTENT(IN) :: global_number
7665  TYPE(meshelementstype), POINTER :: elements
7666  INTEGER(INTG), INTENT(OUT) :: user_element_nodes(:)
7667  INTEGER(INTG), INTENT(OUT) :: err
7668  TYPE(varying_string), INTENT(OUT) :: error
7669  !Local Variables
7670  TYPE(varying_string) :: local_error
7671 
7672  enters("MESH_TOPOLOGY_ELEMENTS_ELEMENT_NODES_GET",err,error,*999)
7673 
7674  IF(ASSOCIATED(elements)) THEN
7675  IF(.NOT.elements%ELEMENTS_FINISHED) THEN
7676  CALL flagerror("Elements have not been finished",err,error,*999)
7677  ELSE
7678  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
7679  IF(SIZE(user_element_nodes,1)>=SIZE(elements%ELEMENTS(global_number)%USER_ELEMENT_NODES,1)) THEN
7680  user_element_nodes=elements%ELEMENTS(global_number)%USER_ELEMENT_NODES
7681  ELSE
7682  local_error="The size of USER_ELEMENT_NODES is too small. The supplied size is "// &
7683  & trim(number_to_vstring(SIZE(user_element_nodes,1),"*",err,error))//" and it needs to be >= "// &
7684  & trim(number_to_vstring(SIZE(elements%ELEMENTS(global_number)%USER_ELEMENT_NODES,1),"*",err,error))//"."
7685  CALL flagerror(local_error,err,error,*999)
7686  ENDIF
7687  ELSE
7688  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
7689  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))
7690  CALL flagerror(local_error,err,error,*999)
7691  ENDIF
7692  ENDIF
7693  ELSE
7694  CALL flagerror("Elements is not associated",err,error,*999)
7695  ENDIF
7696 
7697  exits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_NODES_GET")
7698  RETURN
7699 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_NODES_GET",err,error)
7700  RETURN 1
7701 
7702  END SUBROUTINE mesh_topology_elements_element_nodes_get
7703 
7704  !
7705  !================================================================================================================================
7706  !
7707 
7709  SUBROUTINE mesh_topology_elements_element_nodes_set(GLOBAL_NUMBER,ELEMENTS,USER_ELEMENT_NODES,ERR,ERROR,*)
7710 
7711  !Argument variables
7712  INTEGER(INTG), INTENT(IN) :: global_number
7713  TYPE(meshelementstype), POINTER :: elements
7714  INTEGER(INTG), INTENT(IN) :: user_element_nodes(:)
7715  INTEGER(INTG), INTENT(OUT) :: err
7716  TYPE(varying_string), INTENT(OUT) :: error
7717  !Local Variables
7718  INTEGER(INTG) :: nn,number_of_bad_nodes,global_node_number
7719  INTEGER(INTG), ALLOCATABLE :: global_element_nodes(:),bad_nodes(:)
7720  LOGICAL :: element_nodes_ok,node_exists
7721  TYPE(interface_type), POINTER :: interface
7722  TYPE(mesh_type), POINTER :: mesh
7723  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
7724  TYPE(nodes_type), POINTER :: nodes
7725  TYPE(region_type), POINTER :: parent_region,region
7726  TYPE(varying_string) :: local_error
7727 
7728  enters("MESH_TOPOLOGY_ELEMENTS_ELEMENT_NODES_SET",err,error,*999)
7729 
7730  IF(ASSOCIATED(elements)) THEN
7731  IF(elements%ELEMENTS_FINISHED) THEN
7732  CALL flagerror("Elements have been finished.",err,error,*999)
7733  ELSE
7734  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
7735  IF(SIZE(user_element_nodes,1)==elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_NODES) THEN
7736  meshcomponenttopology=>elements%meshComponentTopology
7737  IF(ASSOCIATED(meshcomponenttopology)) THEN
7738  mesh=>meshcomponenttopology%mesh
7739  IF(ASSOCIATED(mesh)) THEN
7740  region=>mesh%REGION
7741  IF(ASSOCIATED(region)) THEN
7742  nodes=>region%NODES
7743  ELSE
7744  interface=>mesh%INTERFACE
7745  IF(ASSOCIATED(interface)) THEN
7746  nodes=>interface%NODES
7747  parent_region=>interface%PARENT_REGION
7748  IF(.NOT.ASSOCIATED(parent_region)) CALL flagerror("Mesh interface has no parent region.",err,error,*999)
7749  ELSE
7750  CALL flagerror("Elements mesh has no associated region or interface.",err,error,*999)
7751  ENDIF
7752  ENDIF
7753  IF(ASSOCIATED(nodes)) THEN
7754  element_nodes_ok=.true.
7755  ALLOCATE(global_element_nodes(elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_NODES),stat=err)
7756  IF(err/=0) CALL flagerror("Could not allocate global element nodes.",err,error,*999)
7757  ALLOCATE(bad_nodes(elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_NODES),stat=err)
7758  IF(err/=0) CALL flagerror("Could not allocate bad nodes.",err,error,*999)
7759  number_of_bad_nodes=0
7760  DO nn=1,elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_NODES
7761  CALL node_check_exists(nodes,user_element_nodes(nn),node_exists,global_node_number,err,error,*999)
7762  IF(node_exists) THEN
7763  global_element_nodes(nn)=global_node_number
7764  ELSE
7765  number_of_bad_nodes=number_of_bad_nodes+1
7766  bad_nodes(number_of_bad_nodes)=user_element_nodes(nn)
7767  element_nodes_ok=.false.
7768  ENDIF
7769  ENDDO !nn
7770  IF(element_nodes_ok) THEN
7771  elements%ELEMENTS(global_number)%USER_ELEMENT_NODES=user_element_nodes
7772  elements%ELEMENTS(global_number)%GLOBAL_ELEMENT_NODES=global_element_nodes
7773  ELSE
7774  IF(number_of_bad_nodes==1) THEN
7775  IF(ASSOCIATED(region)) THEN
7776  local_error="The element user node number of "//trim(number_to_vstring(bad_nodes(1),"*",err,error))// &
7777  & " is not defined in region "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
7778  ELSE
7779  local_error="The element user node number of "//trim(number_to_vstring(bad_nodes(1),"*",err,error))// &
7780  & " is not defined in interface number "// &
7781  & trim(number_to_vstring(interface%USER_NUMBER,"*",err,error))// &
7782  & " of parent region number "//trim(number_to_vstring(parent_region%USER_NUMBER,"*",err,error))//"."
7783  ENDIF
7784  ELSE
7785  local_error="The element user node number of "//trim(number_to_vstring(bad_nodes(1),"*",err,error))
7786  DO nn=2,number_of_bad_nodes-1
7787  local_error=local_error//","//trim(number_to_vstring(bad_nodes(nn),"*",err,error))
7788  ENDDO !nn
7789  IF(ASSOCIATED(region)) THEN
7790  local_error=local_error//" & "//trim(number_to_vstring(bad_nodes(number_of_bad_nodes),"*",err,error))// &
7791  & " are not defined in region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
7792  ELSE
7793  local_error=local_error//" & "//trim(number_to_vstring(bad_nodes(number_of_bad_nodes),"*",err,error))// &
7794  & " are not defined in interface number "// &
7795  & trim(number_to_vstring(interface%USER_NUMBER,"*",err,error))//" of parent region number "// &
7796  & trim(number_to_vstring(parent_region%USER_NUMBER,"*",err,error))//"."
7797  ENDIF
7798  ENDIF
7799  CALL flagerror(local_error,err,error,*999)
7800  ENDIF
7801  ELSE
7802  IF(ASSOCIATED(region)) THEN
7803  CALL flagerror("The elements mesh region does not have any associated nodes.",err,error,*999)
7804  ELSE
7805  CALL flagerror("The elements mesh interface does not have any associated nodes.",err,error,*999)
7806  ENDIF
7807  ENDIF
7808  ELSE
7809  CALL flagerror("The mesh component topology mesh is not associated.",err,error,*999)
7810  ENDIF
7811  ELSE
7812  CALL flagerror("The elements mesh component topology is not associated.",err,error,*999)
7813  ENDIF
7814  ELSE
7815  CALL flagerror("Number of element nodes does not match number of basis nodes for this element.",err,error,*999)
7816  ENDIF
7817  ELSE
7818  local_error="The specified global element number of "//trim(number_to_vstring(global_number,"*",err,error))// &
7819  & " is invalid. The global element number should be between 1 and "// &
7820  & trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))//"."
7821  CALL flagerror(local_error,err,error,*999)
7822  ENDIF
7823  ENDIF
7824  ELSE
7825  CALL flagerror("Elements is not associated.",err,error,*999)
7826  ENDIF
7827 
7828  exits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_NODES_SET")
7829  RETURN
7830 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_ELEMENT_NODES_SET",err,error)
7831  RETURN 1
7832 
7833  END SUBROUTINE mesh_topology_elements_element_nodes_set
7834 
7835  !
7836  !================================================================================================================================
7837  !
7838 
7840  SUBROUTINE meshelements_elementnodeversionset(GLOBAL_NUMBER,ELEMENTS,VERSION_NUMBER,DERIVATIVE_NUMBER, &
7841  & user_element_node_index,err,error,*)
7842 
7843  !Argument variables
7844  INTEGER(INTG), INTENT(IN) :: global_number
7845  TYPE(meshelementstype), POINTER :: elements
7846  INTEGER(INTG), INTENT(IN) :: version_number
7847  INTEGER(INTG), INTENT(IN) :: derivative_number
7848  INTEGER(INTG), INTENT(IN) :: user_element_node_index
7849  INTEGER(INTG), INTENT(OUT) :: err
7850  TYPE(varying_string), INTENT(OUT) :: error
7851 
7852  !Local Variables
7853  TYPE(interface_type), POINTER :: interface
7854  TYPE(mesh_type), POINTER :: mesh
7855  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
7856  TYPE(nodes_type), POINTER :: nodes
7857  TYPE(region_type), POINTER :: parent_region,region
7858  TYPE(varying_string) :: local_error
7859 
7860  enters("MeshElements_ElementNodeVersionSet",err,error,*999)
7861 
7862  IF(ASSOCIATED(elements)) THEN
7863  IF(elements%ELEMENTS_FINISHED) THEN
7864  CALL flagerror("Elements have been finished.",err,error,*999)
7865  ELSE
7866  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
7867  IF(user_element_node_index>=1.AND.user_element_node_index<=elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_NODES) THEN
7868  meshcomponenttopology=>elements%meshComponentTopology
7869  IF(ASSOCIATED(meshcomponenttopology)) THEN
7870  mesh=>meshcomponenttopology%mesh
7871  IF(ASSOCIATED(mesh)) THEN
7872  region=>mesh%REGION
7873  IF(ASSOCIATED(region)) THEN
7874  nodes=>region%NODES
7875  ELSE
7876  interface=>mesh%INTERFACE
7877  IF(ASSOCIATED(interface)) THEN
7878  nodes=>interface%NODES
7879  parent_region=>interface%PARENT_REGION
7880  IF(.NOT.ASSOCIATED(parent_region)) CALL flagerror("Mesh interface has no parent region.",err,error,*999)
7881  ELSE
7882  CALL flagerror("Elements mesh has no associated region or interface.",err,error,*999)
7883  ENDIF
7884  ENDIF
7885  IF(derivative_number>=1.AND.derivative_number<=elements%ELEMENTS(global_number)%BASIS% &
7886  & number_of_derivatives(user_element_node_index)) THEN !Check if the specified derivative exists
7887  IF(version_number>=1) THEN !Check if the specified version is greater than 1
7888  elements%ELEMENTS(global_number)%USER_ELEMENT_NODE_VERSIONS(derivative_number,user_element_node_index) &
7889  & = version_number
7890  !\todo : There is redunancy in USER_ELEMENT_NODE_VERSIONS since it was allocated in MESH_TOPOLOGY_ELEMENTS_CREATE_START based on MAXIMUM_NUMBER_OF_DERIVATIVES for that elements basis:ALLOCATE(ELEMENTS%ELEMENTS(ne)%USER_ELEMENT_NODE_VERSIONS(BASIS%MAXIMUM_NUMBER_OF_DERIVATIVES,BASIS%NUMBER_OF_NODES),STAT=ERR)
7891  ELSE
7892  local_error="The specified node version number of "//trim(number_to_vstring(version_number,"*", &
7893  & err,error))//" is invalid. The element node index should be greater than 1."
7894  CALL flagerror(local_error,err,error,*999)
7895  ENDIF
7896  ELSE
7897  local_error="The specified node derivative number of "//trim(number_to_vstring(derivative_number,"*", &
7898  & err,error))//" is invalid. The element node derivative index should be between 1 and "// &
7899  & trim(number_to_vstring(elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_DERIVATIVES( &
7900  & user_element_node_index),"*",err,error))//"."
7901  CALL flagerror(local_error,err,error,*999)
7902  ENDIF
7903  ELSE
7904  CALL flagerror("The mesh component topology mesh is not associated.",err,error,*999)
7905  ENDIF
7906  ELSE
7907  CALL flagerror("The elements mesh component topology is not associated.",err,error,*999)
7908  ENDIF
7909  ELSE
7910  local_error="The specified element node index of "//trim(number_to_vstring(user_element_node_index,"*",err,error))// &
7911  & " is invalid. The element node index should be between 1 and "// &
7912  & trim(number_to_vstring(elements%ELEMENTS(global_number)%BASIS%NUMBER_OF_NODES,"*",err,error))//"."
7913  CALL flagerror(local_error,err,error,*999)
7914  ENDIF
7915  ELSE
7916  local_error="The specified global element number of "//trim(number_to_vstring(global_number,"*",err,error))// &
7917  & " is invalid. The global element number should be between 1 and "// &
7918  & trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))//"."
7919  CALL flagerror(local_error,err,error,*999)
7920  ENDIF
7921  ENDIF
7922  ELSE
7923  CALL flagerror("Elements is not associated.",err,error,*999)
7924  ENDIF
7925 
7926  exits("MeshElements_ElementNodeVersionSet")
7927  RETURN
7928 999 errorsexits("MeshElements_ElementNodeVersionSet",err,error)
7929  RETURN 1
7930 
7931  END SUBROUTINE meshelements_elementnodeversionset
7932 
7933  !
7934  !================================================================================================================================
7935  !
7936 
7938  SUBROUTINE meshtopology_elementsadjacentelementscalculate(TOPOLOGY,ERR,ERROR,*)
7939 
7940  !Argument variables
7941  TYPE(meshcomponenttopologytype), POINTER :: topology
7942  INTEGER(INTG), INTENT(OUT) :: err
7943  TYPE(varying_string), INTENT(OUT) :: error
7944  !Local Variables
7945  INTEGER(INTG) :: j,ne,ne1,nep1,ni,nic,nn,nn1,nn2,nn3,node_idx,np,np1,dummy_err,face_xi(2),face_xic(3),node_position_index(4)
7946  INTEGER(INTG) :: xi_direction,direction_index,xi_dir_check,xi_dir_search,number_node_matches
7947  INTEGER(INTG) :: number_surrounding,number_of_nodes_xic(4)
7948  INTEGER(INTG), ALLOCATABLE :: node_matches(:),adjacent_elements(:)
7949  LOGICAL :: xi_collapsed,face_collapsed(-3:3),subset
7950  TYPE(list_type), POINTER :: node_match_list
7951  TYPE(list_ptr_type) :: adjacent_elements_list(-4:4)
7952  TYPE(basis_type), POINTER :: basis
7953  TYPE(varying_string) :: dummy_error,local_error
7954 
7955  NULLIFY(node_match_list)
7956  DO nic=-4,4
7957  NULLIFY(adjacent_elements_list(nic)%PTR)
7958  ENDDO !nic
7959 
7960  enters("MeshTopology_ElementsAdjacentElementsCalculate",err,error,*999)
7961 
7962  IF(ASSOCIATED(topology)) THEN
7963  IF(ASSOCIATED(topology%NODES)) THEN
7964  IF(ASSOCIATED(topology%ELEMENTS)) THEN
7965  !Loop over the global elements in the mesh
7966  DO ne=1,topology%ELEMENTS%NUMBER_OF_ELEMENTS
7967  !%%%% first we initialize lists that are required to find the adjacent elements list
7968  basis=>topology%ELEMENTS%ELEMENTS(ne)%BASIS
7969  DO nic=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
7970  NULLIFY(adjacent_elements_list(nic)%PTR)
7971  CALL list_create_start(adjacent_elements_list(nic)%PTR,err,error,*999)
7972  CALL list_data_type_set(adjacent_elements_list(nic)%PTR,list_intg_type,err,error,*999)
7973  CALL list_initial_size_set(adjacent_elements_list(nic)%PTR,5,err,error,*999)
7974  CALL list_create_finish(adjacent_elements_list(nic)%PTR,err,error,*999)
7975  ENDDO !ni
7976  number_of_nodes_xic=1
7977  number_of_nodes_xic(1:basis%NUMBER_OF_XI_COORDINATES)=basis%NUMBER_OF_NODES_XIC(1:basis%NUMBER_OF_XI_COORDINATES)
7978  !Place the current element in the surrounding list
7979  CALL list_item_add(adjacent_elements_list(0)%PTR,topology%ELEMENTS%ELEMENTS(ne)%GLOBAL_NUMBER,err,error,*999)
7980  SELECT CASE(basis%TYPE)
7981  CASE(basis_lagrange_hermite_tp_type)
7982  !Determine the collapsed "faces" if any
7983  node_position_index=1
7984  !Loop over the face normals of the element
7985  DO ni=1,basis%NUMBER_OF_XI
7986  !Determine the xi directions that lie in this xi direction
7987  face_xi(1)=other_xi_directions3(ni,2,1)
7988  face_xi(2)=other_xi_directions3(ni,3,1)
7989  !Reset the node_position_index in this xi direction
7990  node_position_index(ni)=1
7991  !Loop over the two faces with this normal
7992  DO direction_index=-1,1,2
7993  xi_direction=direction_index*ni
7994  face_collapsed(xi_direction)=.false.
7995  DO j=1,2
7996  xi_dir_check=face_xi(j)
7997  IF(xi_dir_check<=basis%NUMBER_OF_XI) THEN
7998  xi_dir_search=face_xi(3-j)
7999  node_position_index(xi_dir_search)=1
8000  xi_collapsed=.true.
8001  DO WHILE(node_position_index(xi_dir_search)<=number_of_nodes_xic(xi_dir_search).AND.xi_collapsed)
8002  !Get the first local node along the xi check direction
8003  node_position_index(xi_dir_check)=1
8004  nn1=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2),node_position_index(3),1)
8005  !Get the second local node along the xi check direction
8006  node_position_index(xi_dir_check)=2
8007  nn2=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2),node_position_index(3),1)
8008  IF(nn1/=0.AND.nn2/=0) THEN
8009  IF(topology%ELEMENTS%ELEMENTS(ne)%MESH_ELEMENT_NODES(nn1)/= &
8010  & topology%ELEMENTS%ELEMENTS(ne)%MESH_ELEMENT_NODES(nn2)) xi_collapsed=.true.
8011  ENDIF
8012  node_position_index(xi_dir_search)=node_position_index(xi_dir_search)+1
8013  ENDDO !xi_dir_search
8014  IF(xi_collapsed) face_collapsed(xi_direction)=.true.
8015  ENDIF
8016  ENDDO !j
8017  node_position_index(ni)=number_of_nodes_xic(ni)
8018  ENDDO !direction_index
8019  ENDDO !ni
8020  !Loop over the xi directions and calculate the surrounding elements
8021  DO ni=1,basis%NUMBER_OF_XI
8022  !Determine the xi directions that lie in this xi direction
8023  face_xi(1)=other_xi_directions3(ni,2,1)
8024  face_xi(2)=other_xi_directions3(ni,3,1)
8025  !Loop over the two faces
8026  DO direction_index=-1,1,2
8027  xi_direction=direction_index*ni
8028  !Find nodes in the element on the appropriate face/line/point
8029  NULLIFY(node_match_list)
8030  CALL list_create_start(node_match_list,err,error,*999)
8031  CALL list_data_type_set(node_match_list,list_intg_type,err,error,*999)
8032 
8033  CALL list_initial_size_set(node_match_list,16,err,error,*999)
8034  CALL list_create_finish(node_match_list,err,error,*999)
8035  IF(direction_index==-1) THEN
8036  node_position_index(ni)=1
8037  ELSE
8038  node_position_index(ni)=number_of_nodes_xic(ni)
8039  ENDIF
8040  !If the face is collapsed then don't look in this xi direction. The exception is if the opposite face is also
8041  !collpased. This may indicate that we have a funny element in non-rc coordinates that goes around the central
8042  !axis back to itself
8043  IF(face_collapsed(xi_direction).AND..NOT.face_collapsed(-xi_direction)) THEN
8044  !Do nothing - the match lists are already empty
8045  ELSE
8046  !Find the nodes to match and add them to the node match list
8047  DO nn1=1,number_of_nodes_xic(face_xi(1))
8048  node_position_index(face_xi(1))=nn1
8049  DO nn2=1,number_of_nodes_xic(face_xi(2))
8050  node_position_index(face_xi(2))=nn2
8051  nn=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2),node_position_index(3),1)
8052  IF(nn/=0) THEN
8053  np=topology%ELEMENTS%ELEMENTS(ne)%MESH_ELEMENT_NODES(nn)
8054  CALL list_item_add(node_match_list,np,err,error,*999)
8055  ENDIF
8056  ENDDO !nn2
8057  ENDDO !nn1
8058  ENDIF
8059  CALL list_remove_duplicates(node_match_list,err,error,*999)
8060  CALL list_detach_and_destroy(node_match_list,number_node_matches,node_matches,err,error,*999)
8061  number_surrounding=0
8062  IF(number_node_matches>0) THEN
8063  !Find list of elements surrounding those nodes
8064  np1=node_matches(1)
8065  DO nep1=1,topology%NODES%NODES(np1)%numberOfSurroundingElements
8066  ne1=topology%NODES%NODES(np1)%surroundingElements(nep1)
8067  IF(ne1/=ne) THEN !Don't want the current element
8068  ! grab the nodes list for current and this surrouding elements
8069  ! current face : NODE_MATCHES
8070  ! candidate elem : TOPOLOGY%ELEMENTS%ELEMENTS(ne1)%MESH_ELEMENT_NODES ! should this be GLOBAL_ELEMENT_NODES?
8071  ! if all of current face belongs to the candidate element, we will have found the neighbour
8072  CALL list_subset_of(node_matches(1:number_node_matches),topology%ELEMENTS%ELEMENTS(ne1)% &
8073  & mesh_element_nodes,subset,err,error,*999)
8074  IF(subset) THEN
8075  CALL list_item_add(adjacent_elements_list(xi_direction)%PTR,ne1,err,error,*999)
8076  number_surrounding=number_surrounding+1
8077  ENDIF
8078  ENDIF
8079  ENDDO !nep1
8080  ENDIF
8081  IF(ALLOCATED(node_matches)) DEALLOCATE(node_matches)
8082  ENDDO !direction_index
8083  ENDDO !ni
8084  CASE(basis_simplex_type)
8085  !Loop over the xi coordinates and calculate the surrounding elements
8086  DO nic=1,basis%NUMBER_OF_XI_COORDINATES
8087  !Find the other coordinates of the face/line/point
8088  face_xic(1)=other_xi_directions4(nic,1)
8089  face_xic(2)=other_xi_directions4(nic,2)
8090  face_xic(3)=other_xi_directions4(nic,3)
8091  !Find nodes in the element on the appropriate face/line/point
8092  NULLIFY(node_match_list)
8093  CALL list_create_start(node_match_list,err,error,*999)
8094  CALL list_data_type_set(node_match_list,list_intg_type,err,error,*999)
8095  CALL list_initial_size_set(node_match_list,16,err,error,*999)
8096  CALL list_create_finish(node_match_list,err,error,*999)
8097  node_position_index(nic)=1 !Furtherest away from node with the nic'th coordinate
8098  !Find the nodes to match and add them to the node match list
8099  DO nn1=1,number_of_nodes_xic(face_xic(1))
8100  node_position_index(face_xic(1))=nn1
8101  DO nn2=1,number_of_nodes_xic(face_xic(2))
8102  node_position_index(face_xic(2))=nn2
8103  DO nn3=1,number_of_nodes_xic(face_xic(3))
8104  node_position_index(face_xic(3))=nn3
8105  nn=basis%NODE_POSITION_INDEX_INV(node_position_index(1),node_position_index(2),node_position_index(3), &
8106  node_position_index(4))
8107  IF(nn/=0) THEN
8108  np=topology%ELEMENTS%ELEMENTS(ne)%MESH_ELEMENT_NODES(nn)
8109  CALL list_item_add(node_match_list,np,err,error,*999)
8110  ENDIF
8111  ENDDO !nn3
8112  ENDDO !nn2
8113  ENDDO !nn1
8114  CALL list_remove_duplicates(node_match_list,err,error,*999)
8115  CALL list_detach_and_destroy(node_match_list,number_node_matches,node_matches,err,error,*999)
8116  IF(number_node_matches>0) THEN
8117  !Find list of elements surrounding those nodes
8118  DO node_idx=1,number_node_matches
8119  np1=node_matches(node_idx)
8120  DO nep1=1,topology%NODES%NODES(np1)%numberOfSurroundingElements
8121  ne1=topology%NODES%NODES(np1)%surroundingElements(nep1)
8122  IF(ne1/=ne) THEN !Don't want the current element
8123  ! grab the nodes list for current and this surrouding elements
8124  ! current face : NODE_MATCHES
8125  ! candidate elem : TOPOLOGY%ELEMENTS%ELEMENTS(ne1)%MESH_ELEMENT_NODES
8126  ! if all of current face belongs to the candidate element, we will have found the neighbour
8127  CALL list_subset_of(node_matches(1:number_node_matches),topology%ELEMENTS%ELEMENTS(ne1)% &
8128  & mesh_element_nodes,subset,err,error,*999)
8129  IF(subset) THEN
8130  CALL list_item_add(adjacent_elements_list(nic)%PTR,ne1,err,error,*999)
8131  ENDIF
8132  ENDIF
8133  ENDDO !nep1
8134  ENDDO !node_idx
8135  ENDIF
8136  IF(ALLOCATED(node_matches)) DEALLOCATE(node_matches)
8137  ENDDO !nic
8138  CASE(basis_serendipity_type)
8139  CALL flagerror("Not implemented.",err,error,*999)
8140  CASE(basis_auxilliary_type)
8141  CALL flagerror("Not implemented.",err,error,*999)
8142  CASE(basis_b_spline_tp_type)
8143  CALL flagerror("Not implemented.",err,error,*999)
8144  CASE(basis_fourier_lagrange_hermite_tp_type)
8145  CALL flagerror("Not implemented.",err,error,*999)
8146  CASE(basis_extended_lagrange_tp_type)
8147  CALL flagerror("Not implemented.",err,error,*999)
8148  CASE DEFAULT
8149  local_error="The basis type of "//trim(number_to_vstring(basis%TYPE,"*",err,error))// &
8150  & " is invalid."
8151  CALL flagerror(local_error,err,error,*999)
8152  END SELECT
8153  !Set the surrounding elements for this element
8154  ALLOCATE(topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(-basis%NUMBER_OF_XI_COORDINATES: &
8155  & basis%NUMBER_OF_XI_COORDINATES),stat=err)
8156  IF(err/=0) CALL flagerror("Could not allocate adjacent elements.",err,error,*999)
8157  DO nic=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
8158  CALL mesh_adjacent_element_initialise(topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic),err,error,*999)
8159  CALL list_remove_duplicates(adjacent_elements_list(nic)%PTR,err,error,*999)
8160  CALL list_detach_and_destroy(adjacent_elements_list(nic)%PTR,topology%ELEMENTS%ELEMENTS(ne)% &
8161  & adjacent_elements(nic)%NUMBER_OF_ADJACENT_ELEMENTS,adjacent_elements,err,error,*999)
8162  ALLOCATE(topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%ADJACENT_ELEMENTS(topology%ELEMENTS%ELEMENTS(ne)% &
8163  adjacent_elements(nic)%NUMBER_OF_ADJACENT_ELEMENTS),stat=err)
8164  IF(err/=0) CALL flagerror("Could not allocate element adjacent elements.",err,error,*999)
8165  topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%ADJACENT_ELEMENTS(1:topology%ELEMENTS%ELEMENTS(ne)% &
8166  adjacent_elements(nic)%NUMBER_OF_ADJACENT_ELEMENTS) = adjacent_elements(1:topology%ELEMENTS% &
8167  & elements(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS)
8168  IF(ALLOCATED(adjacent_elements)) DEALLOCATE(adjacent_elements)
8169  ENDDO !nic
8170  ENDDO !ne
8171  ELSE
8172  CALL flagerror("Mesh topology elements is not associated.",err,error,*999)
8173  ENDIF
8174  ELSE
8175  CALL flagerror("Mesh topology nodes is not associated.",err,error,*999)
8176  ENDIF
8177  ELSE
8178  CALL flagerror("Mesh topology is not allocated.",err,error,*999)
8179  ENDIF
8180 
8181  IF(diagnostics1) THEN
8182  CALL write_string_value(diagnostic_output_type,"Number of elements = ",topology%ELEMENTS%NUMBER_OF_ELEMENTS,err,error,*999)
8183  DO ne=1,topology%ELEMENTS%NUMBER_OF_ELEMENTS
8184  basis=>topology%ELEMENTS%ELEMENTS(ne)%BASIS
8185  CALL write_string_value(diagnostic_output_type," Global element number : ",ne,err,error,*999)
8186  CALL write_string_value(diagnostic_output_type," Number of xi coordinates = ",basis%NUMBER_OF_XI_COORDINATES, &
8187  & err,error,*999)
8188  DO nic=-basis%NUMBER_OF_XI_COORDINATES,basis%NUMBER_OF_XI_COORDINATES
8189  CALL write_string_value(diagnostic_output_type," Xi coordinate : ",nic,err,error,*999)
8190  CALL write_string_value(diagnostic_output_type," Number of adjacent elements = ", &
8191  & topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS,err,error,*999)
8192  IF(topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)%NUMBER_OF_ADJACENT_ELEMENTS>0) THEN
8193  CALL write_string_vector(diagnostic_output_type,1,1,topology%ELEMENTS%ELEMENTS(ne)% &
8194  & adjacent_elements(nic)%NUMBER_OF_ADJACENT_ELEMENTS,8,8,topology%ELEMENTS%ELEMENTS(ne)%ADJACENT_ELEMENTS(nic)% &
8195  & adjacent_elements,'(" Adjacent elements :",8(X,I8))','(30x,8(X,I8))',err,error,*999)
8196  ENDIF
8197  ENDDO !nic
8198  ENDDO !ne
8199  ENDIF
8200 
8201  exits("MeshTopology_ElementsAdjacentElementsCalculate")
8202  RETURN
8203 999 IF(ALLOCATED(node_matches)) DEALLOCATE(node_matches)
8204  IF(ALLOCATED(adjacent_elements)) DEALLOCATE(adjacent_elements)
8205  IF(ASSOCIATED(node_match_list)) CALL list_destroy(node_match_list,dummy_err,dummy_error,*998)
8206 998 DO nic=-4,4
8207  IF(ASSOCIATED(adjacent_elements_list(nic)%PTR)) CALL list_destroy(adjacent_elements_list(nic)%PTR,dummy_err,dummy_error,*997)
8208  ENDDO !ni
8209 997 errors("MeshTopology_ElementsAdjacentElementsCalculate",err,error)
8210  exits("MeshTopology_ElementsAdjacentElementsCalculate")
8211  RETURN 1
8212 
8213  END SUBROUTINE meshtopology_elementsadjacentelementscalculate
8214 
8215  !
8216  !================================================================================================================================
8217  !
8218 
8220  SUBROUTINE mesh_topology_elements_finalise(ELEMENTS,ERR,ERROR,*)
8221 
8222  !Argument variables
8223  TYPE(meshelementstype), POINTER :: elements
8224  INTEGER(INTG), INTENT(OUT) :: err
8225  TYPE(varying_string), INTENT(OUT) :: error
8226  !Local Variables
8227  INTEGER(INTG) :: ne
8228 
8229  enters("MESH_TOPOLOGY_ELEMENTS_FINALISE",err,error,*999)
8230 
8231  IF(ASSOCIATED(elements)) THEN
8232  DO ne=1,elements%NUMBER_OF_ELEMENTS
8233  CALL mesh_topology_element_finalise(elements%ELEMENTS(ne),err,error,*999)
8234  ENDDO !ne
8235  DEALLOCATE(elements%ELEMENTS)
8236  IF(ASSOCIATED(elements%ELEMENTS_TREE)) CALL tree_destroy(elements%ELEMENTS_TREE,err,error,*999)
8237  DEALLOCATE(elements)
8238  ENDIF
8239 
8240  exits("MESH_TOPOLOGY_ELEMENTS_FINALISE")
8241  RETURN
8242 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_FINALISE",err,error)
8243  RETURN 1
8244  END SUBROUTINE mesh_topology_elements_finalise
8245 
8246  !
8247  !================================================================================================================================
8248  !
8249 
8251  SUBROUTINE mesh_topology_elements_initialise(TOPOLOGY,ERR,ERROR,*)
8252 
8253  !Argument variables
8254  TYPE(meshcomponenttopologytype), POINTER :: topology
8255  INTEGER(INTG), INTENT(OUT) :: err
8256  TYPE(varying_string), INTENT(OUT) :: error
8257  !Local Variables
8258 
8259  enters("MESH_TOPOLOGY_ELEMENTS_INITIALISE",err,error,*999)
8260 
8261  IF(ASSOCIATED(topology)) THEN
8262  IF(ASSOCIATED(topology%ELEMENTS)) THEN
8263  CALL flagerror("Mesh already has topology elements associated",err,error,*999)
8264  ELSE
8265  ALLOCATE(topology%ELEMENTS,stat=err)
8266  IF(err/=0) CALL flagerror("Could not allocate topology elements",err,error,*999)
8267  topology%ELEMENTS%NUMBER_OF_ELEMENTS=0
8268  topology%ELEMENTS%meshComponentTopology=>topology
8269  NULLIFY(topology%ELEMENTS%ELEMENTS)
8270  NULLIFY(topology%ELEMENTS%ELEMENTS_TREE)
8271  ENDIF
8272  ELSE
8273  CALL flagerror("Topology is not associated",err,error,*999)
8274  ENDIF
8275 
8276  exits("MESH_TOPOLOGY_ELEMENTS_INITIALISE")
8277  RETURN
8278 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_INITIALISE",err,error)
8279  RETURN 1
8280  END SUBROUTINE mesh_topology_elements_initialise
8281 
8282  !
8283  !================================================================================================================================
8284  !
8285 
8287  SUBROUTINE mesh_topology_data_points_initialise(TOPOLOGY,ERR,ERROR,*)
8288 
8289  !Argument variables
8290  TYPE(meshcomponenttopologytype), POINTER :: topology
8291  INTEGER(INTG), INTENT(OUT) :: err
8292  TYPE(varying_string), INTENT(OUT) :: error
8293  !Local Variables
8294 
8295  enters("MESH_TOPOLOGY_DATA_POINTS_INITIALISE",err,error,*999)
8296 
8297  IF(ASSOCIATED(topology)) THEN
8298  IF(ASSOCIATED(topology%dataPoints)) THEN
8299  CALL flagerror("Mesh already has topology data points associated",err,error,*999)
8300  ELSE
8301  ALLOCATE(topology%dataPoints,stat=err)
8302  IF(err/=0) CALL flagerror("Could not allocate topology data points",err,error,*999)
8303  topology%dataPoints%totalNumberOfProjectedData=0
8304  topology%dataPoints%meshComponentTopology=>topology
8305  ENDIF
8306  ELSE
8307  CALL flagerror("Topology is not associated",err,error,*999)
8308  ENDIF
8309 
8310  exits("MESH_TOPOLOGY_DATA_POINTS_INITIALISE")
8311  RETURN
8312 999 errorsexits("MESH_TOPOLOGY_DATA_POINTS_INITIALISE",err,error)
8313  RETURN 1
8314  END SUBROUTINE mesh_topology_data_points_initialise
8315 
8316  !
8317  !================================================================================================================================
8318  !
8319 
8320 !!MERGE: ditto.
8321 
8323  SUBROUTINE mesh_topology_elements_number_get(GLOBAL_NUMBER,USER_NUMBER,ELEMENTS,ERR,ERROR,*)
8324 
8325  !Argument variables
8326  INTEGER(INTG), INTENT(IN) :: global_number
8327  INTEGER(INTG), INTENT(OUT) :: user_number
8328  TYPE(meshelementstype), POINTER :: elements
8329  INTEGER(INTG), INTENT(OUT) :: err
8330  TYPE(varying_string), INTENT(OUT) :: error
8331  !Local Variables
8332  TYPE(varying_string) :: local_error
8333 
8334  enters("MESH_TOPOLOGY_ELEMENTS_NUMBER_SET",err,error,*999)
8335 
8336  IF(ASSOCIATED(elements)) THEN
8337  IF(elements%ELEMENTS_FINISHED) THEN
8338  CALL flagerror("Elements have been finished",err,error,*999)
8339  ELSE
8340  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
8341  user_number=elements%ELEMENTS(global_number)%USER_NUMBER
8342  ELSE
8343  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
8344  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))
8345  CALL flagerror(local_error,err,error,*999)
8346  ENDIF
8347  ENDIF
8348  ELSE
8349  CALL flagerror("Elements is not associated",err,error,*999)
8350  ENDIF
8351 
8352  exits("MESH_TOPOLOGY_ELEMENTS_NUMBER_GET")
8353  RETURN
8354 999 errorsexits("MESH_TOPOLOGY_ELEMENTS_NUMBER_GET",err,error)
8355  RETURN 1
8356 
8357  END SUBROUTINE mesh_topology_elements_number_get
8358 
8359  !
8360  !================================================================================================================================
8361  !
8362 
8364  SUBROUTINE meshelements_elementusernumberget(GLOBAL_NUMBER,USER_NUMBER,ELEMENTS,ERR,ERROR,*)
8365 
8366  !Argument variables
8367  INTEGER(INTG), INTENT(IN) :: global_number
8368  INTEGER(INTG), INTENT(OUT) :: user_number
8369  TYPE(meshelementstype), POINTER :: elements
8370  INTEGER(INTG), INTENT(OUT) :: err
8371  TYPE(varying_string), INTENT(OUT) :: error
8372  !Local Variables
8373  TYPE(varying_string) :: local_error
8374 
8375  enters("MeshElements_ElementUserNumberGet",err,error,*999)
8376 
8377  IF(ASSOCIATED(elements)) THEN
8378  IF(elements%ELEMENTS_FINISHED) THEN
8379  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
8380  user_number=elements%ELEMENTS(global_number)%USER_NUMBER
8381  ELSE
8382  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
8383  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))//"."
8384  CALL flagerror(local_error,err,error,*999)
8385  ENDIF
8386  ELSE
8387  CALL flagerror("Elements have not been finished.",err,error,*999)
8388  ENDIF
8389  ELSE
8390  CALL flagerror("Elements is not associated.",err,error,*999)
8391  ENDIF
8392 
8393  exits("MeshElements_ElementUserNumberGet")
8394  RETURN
8395 999 errorsexits("MeshElements_ElementUserNumberGet",err,error)
8396  RETURN 1
8397 
8398 
8399  END SUBROUTINE meshelements_elementusernumberget
8400 
8401  !
8402  !================================================================================================================================
8403  !
8404 
8406  SUBROUTINE meshelements_elementusernumberset(GLOBAL_NUMBER,USER_NUMBER,ELEMENTS,ERR,ERROR,*)
8407 
8408  !Argument variables
8409  INTEGER(INTG), INTENT(IN) :: global_number
8410  INTEGER(INTG), INTENT(IN) :: user_number
8411  TYPE(meshelementstype), POINTER :: elements
8412  INTEGER(INTG), INTENT(OUT) :: err
8413 
8414  TYPE(varying_string), INTENT(OUT) :: error
8415  !Local Variables
8416  INTEGER(INTG) :: global_element_number,insert_status
8417  TYPE(tree_node_type), POINTER :: tree_node
8418  TYPE(varying_string) :: local_error
8419 
8420  enters("MeshElements_ElementUserNumberSet",err,error,*999)
8421 
8422  IF(ASSOCIATED(elements)) THEN
8423  IF(elements%ELEMENTS_FINISHED) THEN
8424  CALL flagerror("Elements have been finished.",err,error,*999)
8425  ELSE
8426  IF(global_number>=1.AND.global_number<=elements%NUMBER_OF_ELEMENTS) THEN
8427  NULLIFY(tree_node)
8428  CALL tree_search(elements%ELEMENTS_TREE,user_number,tree_node,err,error,*999)
8429  IF(ASSOCIATED(tree_node)) THEN
8430  CALL tree_node_value_get(elements%ELEMENTS_TREE,tree_node,global_element_number,err,error,*999)
8431  local_error="Element user number "//trim(number_to_vstring(user_number,"*",err,error))// &
8432  & " is already used by global element number "// &
8433  & trim(number_to_vstring(global_element_number,"*",err,error))//"."
8434  CALL flagerror(local_error,err,error,*999)
8435  ELSE
8436  CALL tree_item_delete(elements%ELEMENTS_TREE,elements%ELEMENTS(global_number)%USER_NUMBER,err,error,*999)
8437  CALL tree_item_insert(elements%ELEMENTS_TREE,user_number,global_number,insert_status,err,error,*999)
8438  elements%ELEMENTS(global_number)%USER_NUMBER=user_number
8439  ENDIF
8440  ELSE
8441  local_error="Global element number "//trim(number_to_vstring(global_number,"*",err,error))// &
8442  & " is invalid. The limits are 1 to "//trim(number_to_vstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))//"."
8443  CALL flagerror(local_error,err,error,*999)
8444  ENDIF
8445  ENDIF
8446  ELSE
8447  CALL flagerror("Elements is not associated.",err,error,*999)
8448  ENDIF
8449 
8450  exits("MeshElements_ElementUserNumberSet")
8451  RETURN
8452 999 errorsexits("MeshElements_ElementUserNumberSet",err,error)
8453  RETURN 1
8454 
8455  END SUBROUTINE meshelements_elementusernumberset
8456 
8457  !
8458  !================================================================================================================================
8459  !
8460 
8462  SUBROUTINE meshtopologyelementsusernumbersallset(elements,userNumbers,err,error,*)
8463 
8464  !Argument variables
8465  TYPE(meshelementstype), POINTER :: elements
8466  INTEGER(INTG), INTENT(IN) :: usernumbers(:)
8467  INTEGER(INTG), INTENT(OUT) :: err
8468  TYPE(varying_string), INTENT(OUT) :: error
8469  !Local Variables
8470  INTEGER(INTG) :: elementidx,insertstatus
8471  TYPE(tree_type), POINTER :: newelementstree
8472  TYPE(varying_string) :: localerror
8473 
8474  NULLIFY(newelementstree)
8475 
8476  enters("MeshTopologyElementsUserNumbersAllSet",err,error,*999)
8477 
8478  IF(ASSOCIATED(elements)) THEN
8479  IF(elements%ELEMENTS_FINISHED) THEN
8480  CALL flagerror("Elements have been finished.",err,error,*999)
8481  ELSE
8482  IF(elements%NUMBER_OF_ELEMENTS==SIZE(usernumbers,1)) THEN
8483  !Check the users numbers to ensure that there are no duplicates
8484  CALL tree_create_start(newelementstree,err,error,*999)
8485  CALL tree_insert_type_set(newelementstree,tree_no_duplicates_allowed,err,error,*999)
8486  CALL tree_create_finish(newelementstree,err,error,*999)
8487  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8488  CALL tree_item_insert(newelementstree,usernumbers(elementidx),elementidx,insertstatus,err,error,*999)
8489  IF(insertstatus/=tree_node_insert_sucessful) THEN
8490  localerror="The specified user number of "//trim(numbertovstring(usernumbers(elementidx),"*",err,error))// &
8491  & " for global element number "//trim(number_to_vstring(elementidx,"*",err,error))// &
8492  & " is a duplicate. The user element numbers must be unique."
8493  CALL flagerror(localerror,err,error,*999)
8494  ENDIF
8495  ENDDO !elementIdx
8496  CALL tree_destroy(elements%ELEMENTS_TREE,err,error,*999)
8497  elements%ELEMENTS_TREE=>newelementstree
8498  NULLIFY(newelementstree)
8499  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8500  elements%ELEMENTS(elementidx)%GLOBAL_NUMBER=elementidx
8501  elements%ELEMENTS(elementidx)%USER_NUMBER=usernumbers(elementidx)
8502  ENDDO !elementIdx
8503  ELSE
8504  localerror="The number of specified element user numbers ("// &
8505  trim(numbertovstring(SIZE(usernumbers,1),"*",err,error))// &
8506  ") does not match number of elements ("// &
8507  trim(numbertovstring(elements%NUMBER_OF_ELEMENTS,"*",err,error))//")."
8508  CALL flagerror(localerror,err,error,*999)
8509  ENDIF
8510  ENDIF
8511  ELSE
8512  CALL flagerror("Elements is not associated.",err,error,*999)
8513  ENDIF
8514 
8515  exits("MeshTopologyElementsUserNumbersAllSet")
8516  RETURN
8517 999 IF(ASSOCIATED(newelementstree)) CALL tree_destroy(newelementstree,err,error,*998)
8518 998 errorsexits("MeshTopologyElementsUserNumbersAllSet",err,error)
8519  RETURN 1
8520 
8521  END SUBROUTINE meshtopologyelementsusernumbersallset
8522 
8523  !
8524  !================================================================================================================================
8525  !
8526 
8528  SUBROUTINE meshtopologydatapointscalculateprojection(mesh,dataProjection,err,error,*)
8529 
8530  !Argument variables
8531  TYPE(mesh_type), POINTER :: mesh
8532  TYPE(data_projection_type), POINTER :: dataprojection
8533  INTEGER(INTG), INTENT(OUT) :: err
8534  TYPE(varying_string), INTENT(OUT) :: error
8535  !Local Variables
8536  TYPE(data_points_type), POINTER :: datapoints
8537  TYPE(meshdatapointstype), POINTER :: datapointstopology
8538  TYPE(data_projection_result_type), POINTER :: dataprojectionresult
8539  TYPE(meshelementstype), POINTER :: elements
8540  INTEGER(INTG) :: datapointidx,elementidx,countidx,projectionnumber,globalcountidx,elementnumber
8541 
8542  enters("MeshTopologyDataPointsCalculateProjection",err,error,*999)
8543 
8544  IF(ASSOCIATED(mesh)) THEN
8545  IF(dataprojection%DATA_PROJECTION_FINISHED) THEN
8546  datapoints=>dataprojection%DATA_POINTS
8547  !Default the first mesh component topology to contain data points ! \TODO: need to be changed once the data points topology is moved under meshTopologyType.
8548  datapointstopology=>mesh%TOPOLOGY(1)%PTR%dataPoints
8549  !Extract the global number of the data projection
8550  projectionnumber=dataprojection%GLOBAL_NUMBER
8551  !Hard code the first mesh component since element topology is the same for all mesh components
8552  !\TODO: need to be changed once the elements topology is moved under meshTopologyType.
8553  elements=>mesh%TOPOLOGY(1)%PTR%ELEMENTS
8554  ALLOCATE(datapointstopology%elementDataPoint(elements%NUMBER_OF_ELEMENTS),stat=err)
8555  IF(err/=0) CALL flagerror("Could not allocate data points topology element.",err,error,*999)
8556  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8557  datapointstopology%elementDataPoint(elementidx)%elementNumber=elements%ELEMENTS(elementidx)%GLOBAL_NUMBER
8558  datapointstopology%elementDataPoint(elementidx)%numberOfProjectedData=0
8559  ENDDO
8560  !Calculate number of projected data points on an element
8561  DO datapointidx=1,datapoints%NUMBER_OF_DATA_POINTS
8562  dataprojectionresult=>dataprojection%DATA_PROJECTION_RESULTS(datapointidx)
8563  elementnumber=dataprojectionresult%ELEMENT_NUMBER
8564  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8565  IF(datapointstopology%elementDataPoint(elementidx)%elementNumber==elementnumber) THEN
8566  datapointstopology%elementDataPoint(elementidx)%numberOfProjectedData= &
8567  & datapointstopology%elementDataPoint(elementidx)%numberOfProjectedData+1;
8568  ENDIF
8569  ENDDO !elementIdx
8570  ENDDO
8571  !Allocate memory to store data indices and initialise them to be zero
8572  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8573  ALLOCATE(datapointstopology%elementDataPoint(elementidx)%dataIndices(datapointstopology% &
8574  & elementdatapoint(elementidx)%numberOfProjectedData),stat=err)
8575  IF(err/=0) CALL flagerror("Could not allocate data points topology element data points.",err,error,*999)
8576  DO countidx=1,datapointstopology%elementDataPoint(elementidx)%numberOfProjectedData
8577  datapointstopology%elementDataPoint(elementidx)%dataIndices(countidx)%userNumber=0
8578  datapointstopology%elementDataPoint(elementidx)%dataIndices(countidx)%globalNumber=0
8579  ENDDO
8580  ENDDO
8581  !Record the indices of the data that projected on the elements
8582  globalcountidx=0
8583  datapointstopology%totalNumberOfProjectedData=0
8584  DO datapointidx=1,datapoints%NUMBER_OF_DATA_POINTS
8585  dataprojectionresult=>dataprojection%DATA_PROJECTION_RESULTS(datapointidx)
8586  elementnumber=dataprojectionresult%ELEMENT_NUMBER
8587  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8588  countidx=1
8589  IF(datapointstopology%elementDataPoint(elementidx)%elementNumber==elementnumber) THEN
8590  globalcountidx=globalcountidx+1
8591  !Find the next data point index in this element
8592  DO WHILE(datapointstopology%elementDataPoint(elementidx)%dataIndices(countidx)%globalNumber/=0)
8593  countidx=countidx+1
8594  ENDDO
8595  datapointstopology%elementDataPoint(elementidx)%dataIndices(countidx)%userNumber=datapointidx
8596  datapointstopology%elementDataPoint(elementidx)%dataIndices(countidx)%globalNumber=datapointidx!globalCountIdx (used this if only projected data are taken into account)
8597  datapointstopology%totalNumberOfProjectedData=datapointstopology%totalNumberOfProjectedData+1
8598  ENDIF
8599  ENDDO !elementIdx
8600  ENDDO !dataPointIdx
8601  !Allocate memory to store total data indices in ascending order and element map
8602  ALLOCATE(datapointstopology%dataPoints(datapointstopology%totalNumberOfProjectedData),stat=err)
8603  IF(err/=0) CALL flagerror("Could not allocate data points topology data points.",err,error,*999)
8604  !The global number for the data points will be looping through elements.
8605  countidx=1
8606  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
8607  DO datapointidx=1,datapointstopology%elementDataPoint(elementidx)%numberOfProjectedData
8608  datapointstopology%dataPoints(countidx)%userNumber=datapointstopology%elementDataPoint(elementidx)% &
8609  & dataindices(datapointidx)%userNumber
8610  datapointstopology%dataPoints(countidx)%globalNumber=datapointstopology%elementDataPoint(elementidx)% &
8611  & dataindices(datapointidx)%globalNumber
8612  datapointstopology%dataPoints(countidx)%elementNumber=datapointstopology%elementDataPoint(elementidx)% &
8613  & elementnumber
8614  countidx=countidx+1
8615  ENDDO !dataPointIdx
8616  ENDDO !elementIdx
8617  ELSE
8618  CALL flagerror("Data projection is not finished.",err,error,*999)
8619  ENDIF
8620  ELSE
8621  CALL flagerror("Mesh is not associated.",err,error,*999)
8622  ENDIF
8623 
8624  exits("MeshTopologyDataPointsCalculateProjection")
8625  RETURN
8626 999 errorsexits("MeshTopologyDataPointsCalculateProjection",err,error)
8627  RETURN 1
8628  END SUBROUTINE meshtopologydatapointscalculateprojection
8629 
8630  !
8631  !================================================================================================================================
8632  !
8633 
8635  SUBROUTINE meshtopologyfinalise(mesh,err,error,*)
8636 
8637  !Argument variables
8638  TYPE(mesh_type), POINTER :: mesh
8639  INTEGER(INTG), INTENT(OUT) :: err
8640  TYPE(varying_string), INTENT(OUT) :: error
8641  !Local Variables
8642  INTEGER(INTG) :: componentidx
8643 
8644  enters("MeshTopologyFinalise",err,error,*999)
8645 
8646  IF(ASSOCIATED(mesh)) THEN
8647  DO componentidx=1,mesh%NUMBER_OF_COMPONENTS
8648  CALL meshtopologycomponentfinalise(mesh%topology(componentidx)%ptr,err,error,*999)
8649  ENDDO !componentIdx
8650  DEALLOCATE(mesh%topology)
8651  ELSE
8652  CALL flagerror("Mesh is not associated.",err,error,*999)
8653  ENDIF
8654 
8655  exits("MeshTopologyFinalise")
8656  RETURN
8657 999 errorsexits("MeshTopologyFinalise",err,error)
8658  RETURN 1
8659 
8660  END SUBROUTINE meshtopologyfinalise
8661 
8662  !
8663  !================================================================================================================================
8664  !
8665 
8667  SUBROUTINE meshtopologycomponentfinalise(meshComponent,err,error,*)
8668 
8669  !Argument variables
8670  TYPE(meshcomponenttopologytype), POINTER :: meshcomponent
8671  INTEGER(INTG), INTENT(OUT) :: err
8672  TYPE(varying_string), INTENT(OUT) :: error
8673  !Local Variables
8674 
8675  enters("MeshTopologyComponentFinalise",err,error,*999)
8676 
8677  IF(ASSOCIATED(meshcomponent)) THEN
8678  CALL meshtopologynodesfinalise(meshcomponent%nodes,err,error,*999)
8679  CALL mesh_topology_elements_finalise(meshcomponent%elements,err,error,*999)
8680  CALL meshtopologydofsfinalise(meshcomponent%dofs,err,error,*999)
8681  DEALLOCATE(meshcomponent)
8682  ENDIF
8683 
8684  exits("MeshTopologyComponentFinalise")
8685  RETURN
8686 999 errorsexits("MeshTopologyComponentFinalise",err,error)
8687  RETURN 1
8688 
8689  END SUBROUTINE meshtopologycomponentfinalise
8690 
8691  !
8692  !================================================================================================================================
8693  !
8694 
8696  SUBROUTINE meshtopologyinitialise(mesh,err,error,*)
8697 
8698  !Argument variables
8699  TYPE(mesh_type), POINTER :: mesh
8700  INTEGER(INTG), INTENT(OUT) :: err
8701  TYPE(varying_string), INTENT(OUT) :: error
8702  !Local Variables
8703  INTEGER(INTG) :: componentidx
8704 
8705  enters("MeshTopologyInitialise",err,error,*999)
8706 
8707  IF(ASSOCIATED(mesh)) THEN
8708  IF(ASSOCIATED(mesh%topology)) THEN
8709  CALL flagerror("Mesh already has topology associated.",err,error,*999)
8710  ELSE
8711  !Allocate mesh topology
8712  ALLOCATE(mesh%topology(mesh%NUMBER_OF_COMPONENTS),stat=err)
8713  IF(err/=0) CALL flagerror("Mesh topology could not be allocated.",err,error,*999)
8714  DO componentidx=1,mesh%NUMBER_OF_COMPONENTS
8715  ALLOCATE(mesh%topology(componentidx)%ptr,stat=err)
8716  IF(err/=0) CALL flagerror("Mesh topology component could not be allocated.",err,error,*999)
8717  mesh%topology(componentidx)%ptr%mesh=>mesh
8718  NULLIFY(mesh%topology(componentidx)%ptr%elements)
8719  NULLIFY(mesh%topology(componentidx)%ptr%nodes)
8720  NULLIFY(mesh%topology(componentidx)%ptr%dofs)
8721  NULLIFY(mesh%topology(componentidx)%ptr%dataPoints)
8722  !Initialise the topology components
8723  CALL mesh_topology_elements_initialise(mesh%topology(componentidx)%ptr,err,error,*999)
8724  CALL meshtopologynodesinitialise(mesh%topology(componentidx)%ptr,err,error,*999)
8725  CALL meshtopologydofsinitialise(mesh%topology(componentidx)%ptr,err,error,*999)
8726  CALL mesh_topology_data_points_initialise(mesh%topology(componentidx)%ptr,err,error,*999)
8727  ENDDO !componentIdx
8728  ENDIF
8729  ELSE
8730  CALL flagerror("Mesh is not associated.",err,error,*999)
8731  ENDIF
8732 
8733  exits("MeshTopologyInitialise")
8734  RETURN
8735 999 errorsexits("MeshTopologyInitialise",err,error)
8736  RETURN 1
8737  END SUBROUTINE meshtopologyinitialise
8738 
8739  !
8740  !================================================================================================================================
8741  !
8742 
8744  SUBROUTINE meshtopologyelementcheckexistsmesh(mesh,meshComponentNumber,userElementNumber,elementExists,globalElementNumber, &
8745  & err,error,*)
8746 
8747  !Argument variables
8748  TYPE(mesh_type), POINTER :: mesh
8749  INTEGER(INTG), INTENT(IN) :: meshcomponentnumber
8750  INTEGER(INTG), INTENT(IN) :: userelementnumber
8751  LOGICAL, INTENT(OUT) :: elementexists
8752  INTEGER(INTG), INTENT(OUT) :: globalelementnumber
8753  INTEGER(INTG), INTENT(OUT) :: err
8754  TYPE(varying_string), INTENT(OUT) :: error
8755  !Local Variables
8756  TYPE(meshelementstype), POINTER :: elements
8757 
8758  NULLIFY(elements)
8759 
8760  enters("MeshTopologyElementCheckExistsMesh",err,error,*999)
8761 
8762  IF(ASSOCIATED(mesh)) THEN
8763  IF(mesh%MESH_FINISHED) THEN
8764  CALL mesh_topology_elements_get(mesh,meshcomponentnumber,elements,err,error,*999)
8765  CALL meshtopologyelementcheckexistsmeshelements(elements,userelementnumber,elementexists,globalelementnumber,err,error,*999)
8766  ELSE
8767  CALL flagerror("Mesh has not been finished.",err,error,*999)
8768  ENDIF
8769  ELSE
8770  CALL flagerror("Mesh is not associated.",err,error,*999)
8771  ENDIF
8772 
8773  exits("MeshTopologyElementCheckExistsMesh")
8774  RETURN
8775 999 errorsexits("MeshTopologyElementCheckExistsMesh",err,error)
8776  RETURN 1
8777 
8778  END SUBROUTINE meshtopologyelementcheckexistsmesh
8779 
8780  !
8781  !================================================================================================================================
8782  !
8783 
8785  SUBROUTINE meshtopologyelementcheckexistsmeshelements(meshElements,userElementNumber,elementExists,globalElementNumber, &
8786  & err,error,*)
8787 
8788  !Argument variables
8789  TYPE(meshelementstype), POINTER :: meshelements
8790  INTEGER(INTG), INTENT(IN) :: userelementnumber
8791  LOGICAL, INTENT(OUT) :: elementexists
8792  INTEGER(INTG), INTENT(OUT) :: globalelementnumber
8793  INTEGER(INTG), INTENT(OUT) :: err
8794  TYPE(varying_string), INTENT(OUT) :: error
8795  !Local Variables
8796  TYPE(tree_node_type), POINTER :: treenode
8797 
8798  enters("MeshTopologyElementCheckExistsMesh",err,error,*999)
8799 
8800  elementexists=.false.
8801  globalelementnumber=0
8802  IF(ASSOCIATED(meshelements)) THEN
8803  NULLIFY(treenode)
8804  CALL tree_search(meshelements%ELEMENTS_TREE,userelementnumber,treenode,err,error,*999)
8805  IF(ASSOCIATED(treenode)) THEN
8806  CALL tree_node_value_get(meshelements%ELEMENTS_TREE,treenode,globalelementnumber,err,error,*999)
8807  elementexists=.true.
8808  ENDIF
8809  ELSE
8810  CALL flagerror("Mesh elements is not associated.",err,error,*999)
8811  ENDIF
8812 
8813  exits("MeshTopologyElementCheckExistsMeshElements")
8814  RETURN
8815 999 errorsexits("MeshTopologyElementCheckExistsMeshElements",err,error)
8816  RETURN 1
8817 
8818  END SUBROUTINE meshtopologyelementcheckexistsmeshelements
8819 
8820  !
8821  !================================================================================================================================
8822  !
8823 
8825  SUBROUTINE meshtopologynodecheckexistsmesh(mesh,meshComponentNumber,userNodeNumber,nodeExists,meshNodeNumber,err,error,*)
8826 
8827  !Argument variables
8828  TYPE(mesh_type), POINTER :: mesh
8829  INTEGER(INTG), INTENT(IN) :: meshcomponentnumber
8830  INTEGER(INTG), INTENT(IN) :: usernodenumber
8831  LOGICAL, INTENT(OUT) :: nodeexists
8832  INTEGER(INTG), INTENT(OUT) :: meshnodenumber
8833  INTEGER(INTG), INTENT(OUT) :: err
8834  TYPE(varying_string), INTENT(OUT) :: error
8835  !Local Variables
8836  INTEGER(INTG) :: globalnodenumber
8837  TYPE(meshnodestype), POINTER :: meshnodes
8838  TYPE(nodes_type), POINTER :: nodes
8839  TYPE(region_type), POINTER :: region
8840  TYPE(tree_node_type), POINTER :: treenode
8841 
8842  NULLIFY(meshnodes)
8843  NULLIFY(nodes)
8844  NULLIFY(region)
8845 
8846  enters("MeshTopologyNodeCheckExistsMesh",err,error,*999)
8847 
8848  nodeexists=.false.
8849  meshnodenumber=0
8850  IF(ASSOCIATED(mesh)) THEN
8851  IF(mesh%MESH_FINISHED) THEN
8852  CALL meshtopologynodesget(mesh,meshcomponentnumber,meshnodes,err,error,*999)
8853  CALL meshregionget(mesh,region,err,error,*999)
8854  nodes=>region%nodes
8855  IF(ASSOCIATED(nodes)) THEN
8856  CALL node_check_exists(nodes,usernodenumber,nodeexists,globalnodenumber,err,error,*999)
8857  NULLIFY(treenode)
8858  CALL tree_search(meshnodes%nodesTree,globalnodenumber,treenode,err,error,*999)
8859  IF(ASSOCIATED(treenode)) THEN
8860  CALL tree_node_value_get(meshnodes%nodesTree,treenode,meshnodenumber,err,error,*999)
8861  nodeexists=.true.
8862  ENDIF
8863  ELSE
8864  CALL flagerror("Region nodes is not associated.",err,error,*999)
8865  ENDIF
8866  ELSE
8867  CALL flagerror("Mesh has not been finished.",err,error,*999)
8868  ENDIF
8869  ELSE
8870  CALL flagerror("Mesh is not associated.",err,error,*999)
8871  ENDIF
8872 
8873  exits("MeshTopologyNodeCheckExistsMesh")
8874  RETURN
8875 999 errorsexits("MeshTopologyNodeCheckExistsMesh",err,error)
8876  RETURN 1
8877 
8878  END SUBROUTINE meshtopologynodecheckexistsmesh
8879 
8880  !
8881  !================================================================================================================================
8882  !
8883 
8885  SUBROUTINE meshtopologynodecheckexistsmeshnodes(meshNodes,userNodeNumber,nodeExists,meshNodeNumber,err,error,*)
8886 
8887  !Argument variables
8888  TYPE(meshnodestype), POINTER :: meshnodes
8889  INTEGER(INTG), INTENT(IN) :: usernodenumber
8890  LOGICAL, INTENT(OUT) :: nodeexists
8891  INTEGER(INTG), INTENT(OUT) :: meshnodenumber
8892  INTEGER(INTG), INTENT(OUT) :: err
8893  TYPE(varying_string), INTENT(OUT) :: error
8894  !Local Variables
8895  INTEGER(INTG) :: globalnodenumber
8896  TYPE(mesh_type), POINTER :: mesh
8897  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
8898  TYPE(nodes_type), POINTER :: nodes
8899  TYPE(region_type), POINTER :: region
8900  TYPE(tree_node_type), POINTER :: treenode
8901 
8902  NULLIFY(nodes)
8903  NULLIFY(region)
8904 
8905  enters("MeshTopologyNodeCheckExistsMeshNodes",err,error,*999)
8906 
8907  nodeexists=.false.
8908  meshnodenumber=0
8909  IF(ASSOCIATED(meshnodes)) THEN
8910  meshcomponenttopology=>meshnodes%meshComponentTopology
8911  IF(ASSOCIATED(meshcomponenttopology)) THEN
8912  mesh=>meshcomponenttopology%mesh
8913  IF(ASSOCIATED(mesh)) THEN
8914  IF(mesh%MESH_FINISHED) THEN
8915  CALL meshregionget(mesh,region,err,error,*999)
8916  nodes=>region%nodes
8917  IF(ASSOCIATED(nodes)) THEN
8918  CALL node_check_exists(nodes,usernodenumber,nodeexists,globalnodenumber,err,error,*999)
8919  NULLIFY(treenode)
8920  CALL tree_search(meshnodes%nodesTree,globalnodenumber,treenode,err,error,*999)
8921  IF(ASSOCIATED(treenode)) THEN
8922  CALL tree_node_value_get(meshnodes%nodesTree,treenode,meshnodenumber,err,error,*999)
8923  nodeexists=.true.
8924  ENDIF
8925  ELSE
8926  CALL flagerror("Region nodes is not associated.",err,error,*999)
8927  ENDIF
8928  ELSE
8929  CALL flagerror("Mesh has not been finished.",err,error,*999)
8930  ENDIF
8931  ELSE
8932  CALL flagerror("Mesh component topology mesh is not associated.",err,error,*999)
8933  ENDIF
8934  ELSE
8935  CALL flagerror("Mesh nodes mesh component topology is not associated.",err,error,*999)
8936  ENDIF
8937  ELSE
8938  CALL flagerror("Mesh nodes is not associated.",err,error,*999)
8939  ENDIF
8940 
8941  exits("MeshTopologyNodeCheckExistsMeshNodes")
8942  RETURN
8943 999 errorsexits("MeshTopologyNodeCheckExistsMeshNodes",err,error)
8944  RETURN 1
8945 
8946  END SUBROUTINE meshtopologynodecheckexistsmeshnodes
8947 
8948  !
8949  !================================================================================================================================
8950  !
8951 
8953  SUBROUTINE meshtopologynodefinalise(node,err,error,*)
8954 
8955  !Argument variables
8956  TYPE(meshnodetype) :: node
8957  INTEGER(INTG), INTENT(OUT) :: err
8958  TYPE(varying_string), INTENT(OUT) :: error
8959  !Local Variables
8960  INTEGER(INTG) :: derivativeidx
8961 
8962  enters("MeshTopologyNodeFinalise",err,error,*999)
8963 
8964  IF(ALLOCATED(node%derivatives)) THEN
8965  DO derivativeidx=1,node%numberOfDerivatives
8966  CALL meshtopologynodederivativefinalise(node%derivatives(derivativeidx),err,error,*999)
8967  ENDDO !derivativeIdx
8968  DEALLOCATE(node%derivatives)
8969  ENDIF
8970  IF(ASSOCIATED(node%surroundingElements)) DEALLOCATE(node%surroundingElements)
8971 
8972  exits("MeshTopologyNodeFinalise")
8973  RETURN
8974 999 errorsexits("MeshTopologyNodeFinalise",err,error)
8975  RETURN 1
8976 
8977  END SUBROUTINE meshtopologynodefinalise
8978 
8979  !
8980  !================================================================================================================================
8981  !
8982 
8984  SUBROUTINE meshtopologynodeinitialise(node,err,error,*)
8985 
8986  !Argument variables
8987  TYPE(meshnodetype) :: node
8988  INTEGER(INTG), INTENT(OUT) :: err
8989  TYPE(varying_string), INTENT(OUT) :: error
8990  !Local Variables
8991 
8992  enters("MeshTopologyNodeInitialise",err,error,*999)
8993 
8994  node%userNumber=0
8995  node%globalNumber=0
8996  node%numberOfSurroundingElements=0
8997  NULLIFY(node%surroundingElements)
8998  node%numberOfDerivatives=0
8999  node%boundaryNode=.false.
9000 
9001  exits("MeshTopologyNodeInitialise")
9002  RETURN
9003 999 errorsexits("MeshTopologyNodeInitialise",err,error)
9004  RETURN 1
9005  END SUBROUTINE meshtopologynodeinitialise
9006 
9007  !
9008  !================================================================================================================================
9009  !
9010 
9012  SUBROUTINE meshtopologynodescalculate(topology,err,error,*)
9013 
9014  !Argument variables
9015  TYPE(meshcomponenttopologytype), POINTER :: topology
9016  INTEGER(INTG), INTENT(OUT) :: err
9017  TYPE(varying_string), INTENT(OUT) :: error
9018  !Local Variables
9019  INTEGER(INTG) :: dummyerr,elementidx,insertstatus,localnodeidx,globalnode,meshnodeidx,meshnode,numberofnodes
9020  INTEGER(INTG), POINTER :: globalnodenumbers(:)
9021  TYPE(basis_type), POINTER :: basis
9022  TYPE(mesh_type), POINTER :: mesh
9023  TYPE(meshelementstype), POINTER :: elements
9024  TYPE(meshnodestype), POINTER :: meshnodes
9025  TYPE(nodes_type), POINTER :: nodes
9026  TYPE(tree_type), POINTER :: globalnodestree
9027  TYPE(tree_node_type), POINTER :: treenode
9028  TYPE(varying_string) :: dummyerror,localerror
9029 
9030  NULLIFY(globalnodenumbers)
9031  NULLIFY(globalnodestree)
9032 
9033  enters("MeshTopologyNodesCalculate",err,error,*998)
9034 
9035  IF(ASSOCIATED(topology)) THEN
9036  elements=>topology%elements
9037  IF(ASSOCIATED(elements)) THEN
9038  meshnodes=>topology%nodes
9039  IF(ASSOCIATED(meshnodes)) THEN
9040  mesh=>topology%mesh
9041  IF(ASSOCIATED(mesh)) THEN
9042  NULLIFY(nodes)
9043  CALL meshglobalnodesget(mesh,nodes,err,error,*999)
9044  IF(ALLOCATED(meshnodes%nodes)) THEN
9045  localerror="Mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))// &
9046  & " already has allocated mesh topology nodes."
9047  CALL flagerror(localerror,err,error,*998)
9048  ELSE
9049  !Work out what nodes are in the mesh
9050  CALL tree_create_start(globalnodestree,err,error,*999)
9051  CALL tree_insert_type_set(globalnodestree,tree_no_duplicates_allowed,err,error,*999)
9052  CALL tree_create_finish(globalnodestree,err,error,*999)
9053  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
9054  basis=>elements%elements(elementidx)%basis
9055  DO localnodeidx=1,basis%NUMBER_OF_NODES
9056  globalnode=elements%elements(elementidx)%GLOBAL_ELEMENT_NODES(localnodeidx)
9057  CALL tree_item_insert(globalnodestree,globalnode,globalnode,insertstatus,err,error,*999)
9058  ENDDO !localNodeIdx
9059  ENDDO !elementIdx
9060  CALL tree_detach_and_destroy(globalnodestree,numberofnodes,globalnodenumbers,err,error,*999)
9061  !Set up the mesh nodes.
9062  ALLOCATE(meshnodes%nodes(numberofnodes),stat=err)
9063  IF(err/=0) CALL flagerror("Could not allocate mesh topology nodes nodes.",err,error,*999)
9064  CALL tree_create_start(meshnodes%nodesTree,err,error,*999)
9065  CALL tree_insert_type_set(meshnodes%nodesTree,tree_no_duplicates_allowed,err,error,*999)
9066  CALL tree_create_finish(meshnodes%nodesTree,err,error,*999)
9067  DO meshnodeidx=1,numberofnodes
9068  CALL meshtopologynodeinitialise(meshnodes%nodes(meshnodeidx),err,error,*999)
9069  meshnodes%nodes(meshnodeidx)%meshNumber=meshnodeidx
9070  meshnodes%nodes(meshnodeidx)%globalNumber=globalnodenumbers(meshnodeidx)
9071  meshnodes%nodes(meshnodeidx)%userNumber=nodes%nodes(globalnodenumbers(meshnodeidx))%USER_NUMBER
9072  CALL tree_item_insert(meshnodes%nodesTree,globalnodenumbers(meshnodeidx),meshnodeidx,insertstatus,err,error,*999)
9073  ENDDO !nodeIdx
9074  meshnodes%numberOfNodes=numberofnodes
9075  IF(ASSOCIATED(globalnodenumbers)) DEALLOCATE(globalnodenumbers)
9076  !Now recalculate the mesh element nodes
9077  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
9078  basis=>elements%elements(elementidx)%basis
9079  ALLOCATE(elements%elements(elementidx)%MESH_ELEMENT_NODES(basis%NUMBER_OF_NODES),stat=err)
9080  IF(err/=0) CALL flagerror("Could not allocate mesh topology elements mesh element nodes.",err,error,*999)
9081  DO localnodeidx=1,basis%NUMBER_OF_NODES
9082  globalnode=elements%elements(elementidx)%GLOBAL_ELEMENT_NODES(localnodeidx)
9083  NULLIFY(treenode)
9084  CALL tree_search(meshnodes%nodesTree,globalnode,treenode,err,error,*999)
9085  IF(ASSOCIATED(treenode)) THEN
9086  CALL tree_node_value_get(meshnodes%nodesTree,treenode,meshnode,err,error,*999)
9087  elements%elements(elementidx)%MESH_ELEMENT_NODES(localnodeidx)=meshnode
9088  ELSE
9089  localerror="Could not find global node "//trim(numbertovstring(globalnode,"*",err,error))//" (user node "// &
9090  & trim(numbertovstring(nodes%nodes(globalnode)%USER_NUMBER,"*",err,error))//") in the mesh nodes."
9091  CALL flagerror(localerror,err,error,*999)
9092  ENDIF
9093  ENDDO !localNodeIdx
9094  ENDDO !elementIdx
9095  ENDIF
9096  ELSE
9097  CALL flagerror("Mesh topology mesh is not associated.",err,error,*998)
9098  ENDIF
9099  ELSE
9100  CALL flagerror("Mesh topology nodes is not associated.",err,error,*998)
9101  ENDIF
9102  ELSE
9103  CALL flagerror("Mesh topology elements is not associated.",err,error,*998)
9104  ENDIF
9105  ELSE
9106  CALL flagerror("Mesh topology is not associated.",err,error,*998)
9107  ENDIF
9108 
9109  IF(diagnostics1) THEN
9110  CALL writestringvalue(diagnostic_output_type,"Number of mesh nodes = ",meshnodes%numberOfNodes,err,error,*999)
9111  DO meshnodeidx=1,meshnodes%numberOfNodes
9112  CALL writestringvalue(diagnostic_output_type," Mesh node number = ",meshnodeidx,err,error,*999)
9113  CALL writestringvalue(diagnostic_output_type," Global node number = ",meshnodes%nodes(meshnodeidx)%globalNumber, &
9114  & err,error,*999)
9115  ENDDO !meshNodeIdx
9116  ENDIF
9117 
9118  exits("MeshTopologyNodesCalculate")
9119  RETURN
9120 999 IF(ASSOCIATED(globalnodenumbers)) DEALLOCATE(globalnodenumbers)
9121  IF(ASSOCIATED(globalnodestree)) CALL tree_destroy(globalnodestree,dummyerr,dummyerror,*998)
9122 998 errorsexits("MeshTopologyNodesCalculate",err,error)
9123  RETURN 1
9124 
9125  END SUBROUTINE meshtopologynodescalculate
9126 
9127  !
9128  !================================================================================================================================
9129  !
9130 
9132  SUBROUTINE meshtopologynodesdestroy(nodes,err,error,*)
9133 
9134  !Argument variables
9135  TYPE(meshnodestype), POINTER :: nodes
9136  INTEGER(INTG), INTENT(OUT) :: err
9137  TYPE(varying_string), INTENT(OUT) :: error
9138  !Local Variables
9139 
9140  enters("MeshTopologyNodesDestroy",err,error,*999)
9141 
9142  IF(ASSOCIATED(nodes)) THEN
9143  CALL meshtopologynodesfinalise(nodes,err,error,*999)
9144  ELSE
9145  CALL flagerror("Mesh topology nodes is not associated",err,error,*999)
9146  ENDIF
9147 
9148  exits("MeshTopologyNodesDestroy")
9149  RETURN
9150 999 errorsexits("MeshTopologyNodesDestroy",err,error)
9151  RETURN 1
9152 
9153  END SUBROUTINE meshtopologynodesdestroy
9154 
9155  !
9156  !================================================================================================================================
9157  !
9158 
9160  SUBROUTINE meshtopologynodesget(mesh,meshComponentNumber,nodes,err,error,*)
9161 
9162  !Argument variables
9163  TYPE(mesh_type), POINTER :: mesh
9164  INTEGER(INTG), INTENT(IN) :: meshcomponentnumber
9165  TYPE(meshnodestype), POINTER :: nodes
9166  INTEGER(INTG), INTENT(OUT) :: err
9167  TYPE(varying_string), INTENT(OUT) :: error
9168  !Local Variables
9169  TYPE(varying_string) :: localerror
9170 
9171  enters("MeshTopologyNodesGet",err,error,*998)
9172 
9173  IF(ASSOCIATED(mesh)) THEN
9174  IF(meshcomponentnumber>0.AND.meshcomponentnumber<=mesh%NUMBER_OF_COMPONENTS) THEN
9175  IF(ASSOCIATED(nodes)) THEN
9176  CALL flagerror("Nodes is already associated.",err,error,*998)
9177  ELSE
9178  IF(ASSOCIATED(mesh%topology(meshcomponentnumber)%ptr)) THEN
9179  IF(ASSOCIATED(mesh%topology(meshcomponentnumber)%ptr%nodes)) THEN
9180  nodes=>mesh%topology(meshcomponentnumber)%ptr%nodes
9181  ELSE
9182  CALL flagerror("Mesh topology nodes is not associated.",err,error,*999)
9183  ENDIF
9184  ELSE
9185  CALL flagerror("Mesh topology is not associated.",err,error,*999)
9186  ENDIF
9187  ENDIF
9188  ELSE
9189  localerror="The specified mesh component number of "//trim(numbertovstring(meshcomponentnumber,"*",err,error))// &
9190  & " is invalid. The component number must be between 1 and "// &
9191  & trim(numbertovstring(mesh%NUMBER_OF_COMPONENTS,"*",err,error))//"."
9192  CALL flagerror(localerror,err,error,*999)
9193  ENDIF
9194  ELSE
9195  CALL flagerror("Mesh is not associated",err,error,*998)
9196  ENDIF
9197 
9198  exits("MeshTopologyNodesGet")
9199  RETURN
9200 999 NULLIFY(nodes)
9201 998 errorsexits("MeshTopologyNodesGet",err,error)
9202  RETURN 1
9203 
9204  END SUBROUTINE meshtopologynodesget
9205 
9206  !
9207  !================================================================================================================================
9208  !
9209 
9211  SUBROUTINE meshtopologynodederivativefinalise(nodeDerivative,err,error,*)
9212 
9213  !Argument variables
9214  TYPE(meshnodederivativetype) :: nodederivative
9215  INTEGER(INTG), INTENT(OUT) :: err
9216  TYPE(varying_string), INTENT(OUT) :: error
9217  !Local Variables
9218 
9219  enters("MeshTopologyNodeDerivativeFinalise",err,error,*999)
9220 
9221  IF(ALLOCATED(nodederivative%userVersionNumbers)) DEALLOCATE(nodederivative%userVersionNumbers)
9222  IF(ALLOCATED(nodederivative%dofIndex)) DEALLOCATE(nodederivative%dofIndex)
9223 
9224  exits("MeshTopologyNodeDerivativeFinalise")
9225  RETURN
9226 999 errorsexits("MeshTopologyNodeDerivativeFinalise",err,error)
9227  RETURN 1
9228 
9229  END SUBROUTINE meshtopologynodederivativefinalise
9230 
9231  !
9232  !================================================================================================================================
9233  !
9234 
9236  SUBROUTINE meshtopologynodederivativeinitialise(nodeDerivative,err,error,*)
9237 
9238  !Argument variables
9239  TYPE(meshnodederivativetype) :: nodederivative
9240  INTEGER(INTG), INTENT(OUT) :: err
9241  TYPE(varying_string), INTENT(OUT) :: error
9242  !Local Variables
9243 
9244  enters("MeshTopologyNodeDerivativeInitialise",err,error,*999)
9245 
9246  nodederivative%numberOfVersions=0
9247  nodederivative%globalDerivativeIndex=0
9248  nodederivative%partialDerivativeIndex=0
9249 
9250  exits("MeshTopologyNodeDerivativeInitialise")
9251  RETURN
9252 999 errorsexits("MeshTopologyNodeDerivativeInitialise",err,error)
9253  RETURN 1
9254 
9255  END SUBROUTINE meshtopologynodederivativeinitialise
9256 
9257  !
9258  !================================================================================================================================
9259  !
9260 
9262  SUBROUTINE meshtopologynodesderivativescalculate(topology,err,error,*)
9263 
9264  !Argument variables
9265  TYPE(meshcomponenttopologytype), POINTER :: topology
9266  INTEGER(INTG), INTENT(OUT) :: err
9267  TYPE(varying_string), INTENT(OUT) :: error
9268  !Local Variables
9269  INTEGER(INTG) :: derivativeidx,element,elementidx,globalderivative,localnodeidx,maxnumberofderivatives,nodeidx, &
9270  & numberOfDerivatives
9271  INTEGER(INTG), ALLOCATABLE :: derivatives(:)
9272  LOGICAL :: found
9273  TYPE(list_type), POINTER :: nodederivativelist
9274  TYPE(meshelementstype), POINTER :: elements
9275  TYPE(meshnodestype), POINTER :: nodes
9276  TYPE(basis_type), POINTER :: basis
9277  TYPE(varying_string) :: localerror
9278 
9279  enters("MeshTopologyNodesDerivativesCalculate",err,error,*999)
9280 
9281  IF(ASSOCIATED(topology)) THEN
9282  elements=>topology%elements
9283  IF(ASSOCIATED(elements)) THEN
9284  nodes=>topology%nodes
9285  IF(ASSOCIATED(nodes)) THEN
9286  !Loop over the mesh nodes
9287  DO nodeidx=1,nodes%numberOfNodes
9288  !Calculate the number of derivatives and versions at each node. This needs to be calculated by looking at the
9289  !mesh elements as we may have an adjacent element in another domain with a higher order basis also with versions.
9290  NULLIFY(nodederivativelist)
9291  CALL list_create_start(nodederivativelist,err,error,*999)
9292  CALL list_data_type_set(nodederivativelist,list_intg_type,err,error,*999)
9293  CALL list_initial_size_set(nodederivativelist,8,err,error,*999)
9294  CALL list_create_finish(nodederivativelist,err,error,*999)
9295  maxnumberofderivatives=-1
9296  DO elementidx=1,nodes%nodes(nodeidx)%numberOfSurroundingElements
9297  element=nodes%nodes(nodeidx)%surroundingElements(elementidx)
9298  basis=>elements%elements(element)%basis
9299  !Find the local node corresponding to this node
9300  found=.false.
9301  DO localnodeidx=1,basis%NUMBER_OF_NODES
9302  IF(elements%elements(element)%MESH_ELEMENT_NODES(localnodeidx)==nodeidx) THEN
9303  found=.true.
9304  EXIT
9305  ENDIF
9306  ENDDO !nn
9307  IF(found) THEN
9308  DO derivativeidx=1,basis%NUMBER_OF_DERIVATIVES(localnodeidx)
9309  CALL list_item_add(nodederivativelist,basis%PARTIAL_DERIVATIVE_INDEX(derivativeidx,localnodeidx),err,error,*999)
9310  ENDDO !derivativeIdx
9311  IF(basis%NUMBER_OF_DERIVATIVES(localnodeidx)>maxnumberofderivatives) &
9312  & maxnumberofderivatives=basis%NUMBER_OF_DERIVATIVES(localnodeidx)
9313  ELSE
9314  CALL flagerror("Could not find local node.",err,error,*999)
9315  ENDIF
9316  ENDDO !elem_idx
9317  CALL list_remove_duplicates(nodederivativelist,err,error,*999)
9318  CALL list_detach_and_destroy(nodederivativelist,numberofderivatives,derivatives,err,error,*999)
9319  IF(numberofderivatives==maxnumberofderivatives) THEN
9320  !Set up the node derivatives.
9321  ALLOCATE(nodes%nodes(nodeidx)%derivatives(maxnumberofderivatives),stat=err)
9322  nodes%nodes(nodeidx)%numberOfDerivatives=maxnumberofderivatives
9323  DO derivativeidx=1,numberofderivatives
9324  CALL meshtopologynodederivativeinitialise(nodes%nodes(nodeidx)%derivatives(derivativeidx),err,error,*999)
9325  nodes%nodes(nodeidx)%derivatives(derivativeidx)%partialDerivativeIndex = derivatives(derivativeidx)
9326  globalderivative=partial_derivative_global_derivative_map(derivatives(derivativeidx))
9327  IF(globalderivative/=0) THEN
9328  nodes%nodes(nodeidx)%derivatives(derivativeidx)%globalDerivativeIndex=globalderivative
9329  ELSE
9330  localerror="The partial derivative index of "//trim(numbertovstring(derivatives(derivativeidx),"*", &
9331  & err,error))//" for derivative number "//trim(numbertovstring(derivativeidx,"*",err,error))// &
9332  & " does not have a corresponding global derivative."
9333  CALL flagerror(localerror,err,error,*999)
9334  ENDIF
9335  ENDDO !derivativeIdx
9336  DEALLOCATE(derivatives)
9337  ELSE
9338  localerror="Invalid mesh configuration. User node "// &
9339  & trim(numbertovstring(nodes%nodes(nodeidx)%userNumber,"*",err,error))// &
9340  & " has inconsistent derivative directions."
9341  CALL flagerror(localerror,err,error,*999)
9342  ENDIF
9343  ENDDO !nodeIdx
9344  ELSE
9345  CALL flagerror("Mesh topology nodes is not associated.",err,error,*999)
9346  ENDIF
9347  ELSE
9348  CALL flagerror("Mesh topology elements is not associated.",err,error,*999)
9349  ENDIF
9350  ELSE
9351  CALL flagerror("Mesh topology is not associated.",err,error,*999)
9352  ENDIF
9353 
9354  IF(diagnostics1) THEN
9355  CALL writestringvalue(diagnostic_output_type,"Number of mesh global nodes = ",nodes%numberOfNodes,err,error,*999)
9356  DO nodeidx=1,nodes%numberOfNodes
9357  CALL writestringvalue(diagnostic_output_type," Mesh global node number = ",nodeidx,err,error,*999)
9358  CALL writestringvalue(diagnostic_output_type," Number of derivatives = ",nodes%nodes(nodeidx)%numberOfDerivatives, &
9359  & err,error,*999)
9360  DO derivativeidx=1,nodes%nodes(nodeidx)%numberOfDerivatives
9361  !TODO: change output string below so that it writes out derivativeIdx index as well
9362  CALL writestringvalue(diagnostic_output_type," Global derivative index(derivativeIdx) = ", &
9363  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%globalDerivativeIndex,err,error,*999)
9364  CALL writestringvalue(diagnostic_output_type," Partial derivative index(derivativeIdx) = ", &
9365  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%partialDerivativeIndex,err,error,*999)
9366  ENDDO !derivativeIdx
9367  ENDDO !node_idx
9368  ENDIF
9369 
9370  exits("MeshTopologyNodesDerivativesCalculate")
9371  RETURN
9372 999 IF(ALLOCATED(derivatives)) DEALLOCATE(derivatives)
9373  IF(ASSOCIATED(nodederivativelist)) CALL list_destroy(nodederivativelist,err,error,*998)
9374 998 errorsexits("MeshTopologyNodesDerivativesCalculate",err,error)
9375  RETURN 1
9376 
9377  END SUBROUTINE meshtopologynodesderivativescalculate
9378 
9379  !
9380  !================================================================================================================================
9381  !
9382 
9384  SUBROUTINE meshtopologynodenumberofderivativesget(meshNodes,userNumber,numberOfDerivatives,err,error,*)
9385 
9386  !Argument variables
9387  TYPE(meshnodestype), POINTER :: meshnodes
9388  INTEGER(INTG), INTENT(IN) :: usernumber
9389  INTEGER(INTG), INTENT(OUT) :: numberofderivatives
9390  INTEGER(INTG), INTENT(OUT) :: err
9391  TYPE(varying_string), INTENT(OUT) :: error
9392  !Local Variables
9393  INTEGER(INTG) :: meshcomponentnumber,meshnumber
9394  LOGICAL :: nodeexists
9395  TYPE(mesh_type), POINTER :: mesh
9396  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
9397  TYPE(varying_string) :: localerror
9398 
9399  enters("MeshTopologyNodeNumberOfDerivativesGet",err,error,*999)
9400 
9401  IF(ASSOCIATED(meshnodes)) THEN
9402  CALL meshtopologynodecheckexists(meshnodes,usernumber,nodeexists,meshnumber,err,error,*999)
9403  IF(nodeexists) THEN
9404  numberofderivatives=meshnodes%nodes(meshnumber)%numberOfDerivatives
9405  ELSE
9406  meshcomponenttopology=>meshnodes%meshComponentTopology
9407  IF(ASSOCIATED(meshcomponenttopology)) THEN
9408  mesh=>meshcomponenttopology%mesh
9409  IF(ASSOCIATED(mesh)) THEN
9410  meshcomponentnumber=meshcomponenttopology%meshComponentNumber
9411  localerror="The user node number "//trim(numbertovstring(usernumber,"*",err,error))// &
9412  & " does not exist in mesh component number "//trim(numbertovstring(meshcomponentnumber,"*",err,error))// &
9413  & " of mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))//"."
9414  CALL flagerror(localerror,err,error,*999)
9415  ELSE
9416  CALL flagerror("Mesh component topology mesh is not associated.",err,error,*999)
9417  ENDIF
9418  ELSE
9419  CALL flagerror("Mesh nodes mesh component topology is not associated.",err,error,*999)
9420  ENDIF
9421  ENDIF
9422  ELSE
9423  CALL flagerror("Mesh nodes is not associated.",err,error,*999)
9424  ENDIF
9425 
9426  exits("MeshTopologyNodeNumberOfDerivativesGet")
9427  RETURN
9428 999 errorsexits("MeshTopologyNodeNumberOfDerivativesGet",err,error)
9429  RETURN 1
9430 
9431  END SUBROUTINE meshtopologynodenumberofderivativesget
9432 
9433  !
9434  !================================================================================================================================
9435  !
9436 
9438  SUBROUTINE meshtopologynodederivativesget(meshNodes,userNumber,derivatives,err,error,*)
9439 
9440  !Argument variables
9441  TYPE(meshnodestype), POINTER :: meshnodes
9442  INTEGER(INTG), INTENT(IN) :: usernumber
9443  INTEGER(INTG), INTENT(OUT) :: derivatives(:)
9444  INTEGER(INTG), INTENT(OUT) :: err
9445  TYPE(varying_string), INTENT(OUT) :: error
9446  !Local Variables
9447  INTEGER(INTG) :: derivativeidx,meshcomponentnumber,meshnumber,numberofderivatives
9448  LOGICAL :: nodeexists
9449  TYPE(mesh_type), POINTER :: mesh
9450  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
9451  TYPE(varying_string) :: localerror
9452 
9453  enters("MeshTopologyNodeDerivativesGet",err,error,*999)
9454 
9455  IF(ASSOCIATED(meshnodes)) THEN
9456  CALL meshtopologynodecheckexists(meshnodes,usernumber,nodeexists,meshnumber,err,error,*999)
9457  IF(nodeexists) THEN
9458  numberofderivatives=meshnodes%nodes(meshnumber)%numberOfDerivatives
9459  IF(SIZE(derivatives,1)>=numberofderivatives) THEN
9460  DO derivativeidx=1,numberofderivatives
9461  derivatives(derivativeidx)=meshnodes%nodes(meshnumber)%derivatives(derivativeidx)%globalDerivativeIndex
9462  ENDDO !derivativeIdx
9463  ELSE
9464  localerror="The size of the supplied derivatives array of "// &
9465  & trim(numbertovstring(SIZE(derivatives,1),"*",err,error))// &
9466  & " is too small. The size should be >= "// &
9467  & trim(numbertovstring(numberofderivatives,"*",err,error))//"."
9468  CALL flagerror(localerror,err,error,*999)
9469  ENDIF
9470  ELSE
9471  meshcomponenttopology=>meshnodes%meshComponentTopology
9472  IF(ASSOCIATED(meshcomponenttopology)) THEN
9473  mesh=>meshcomponenttopology%mesh
9474  IF(ASSOCIATED(mesh)) THEN
9475  meshcomponentnumber=meshcomponenttopology%meshComponentNumber
9476  localerror="The user node number "//trim(numbertovstring(usernumber,"*",err,error))// &
9477  & " does not exist in mesh component number "//trim(numbertovstring(meshcomponentnumber,"*",err,error))// &
9478  & " of mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))//"."
9479  CALL flagerror(localerror,err,error,*999)
9480  ELSE
9481  CALL flagerror("Mesh component topology mesh is not associated.",err,error,*999)
9482  ENDIF
9483  ELSE
9484  CALL flagerror("Mesh nodes mesh component topology is not associated.",err,error,*999)
9485  ENDIF
9486  ENDIF
9487  ELSE
9488  CALL flagerror("Mesh nodes is not associated.",err,error,*999)
9489  ENDIF
9490 
9491  exits("MeshTopologyNodeDerivativesGet")
9492  RETURN
9493 999 errorsexits("MeshTopologyNodeDerivativesGet",err,error)
9494  RETURN 1
9495 
9496  END SUBROUTINE meshtopologynodederivativesget
9497 
9498  !
9499  !================================================================================================================================
9500  !
9501 
9503  SUBROUTINE meshtopologynodenumberofversionsget(meshNodes,derivativeNumber,userNumber,numberOfVersions,err,error,*)
9504 
9505  !Argument variables
9506  TYPE(meshnodestype), POINTER :: meshnodes
9507  INTEGER(INTG), INTENT(IN) :: derivativenumber
9508  INTEGER(INTG), INTENT(IN) :: usernumber
9509  INTEGER(INTG), INTENT(OUT) :: numberofversions
9510  INTEGER(INTG), INTENT(OUT) :: err
9511  TYPE(varying_string), INTENT(OUT) :: error
9512  !Local Variables
9513  INTEGER(INTG) :: meshcomponentnumber,meshnumber
9514  LOGICAL :: nodeexists
9515  TYPE(mesh_type), POINTER :: mesh
9516  TYPE(meshcomponenttopologytype), POINTER :: meshcomponenttopology
9517  TYPE(varying_string) :: localerror
9518 
9519  enters("MeshTopologyNodeNumberOfVersionsGet",err,error,*999)
9520 
9521  IF(ASSOCIATED(meshnodes)) THEN
9522  CALL meshtopologynodecheckexists(meshnodes,usernumber,nodeexists,meshnumber,err,error,*999)
9523  IF(nodeexists) THEN
9524  IF(derivativenumber>=1.AND.derivativenumber<=meshnodes%nodes(meshnumber)%numberOfDerivatives) THEN
9525  numberofversions=meshnodes%nodes(meshnumber)%derivatives(derivativenumber)%numberOfVersions
9526  ELSE
9527  localerror="The specified derivative index of "// &
9528  & trim(numbertovstring(derivativenumber,"*",err,error))// &
9529  & " is invalid. The derivative index must be >= 1 and <= "// &
9530  & trim(numbertovstring(meshnodes%nodes(meshnumber)%numberOfDerivatives,"*",err,error))// &
9531  & " for user node number "//trim(numbertovstring(usernumber,"*",err,error))//"."
9532  CALL flagerror(localerror,err,error,*999)
9533  ENDIF
9534  ELSE
9535  meshcomponenttopology=>meshnodes%meshComponentTopology
9536  IF(ASSOCIATED(meshcomponenttopology)) THEN
9537  mesh=>meshcomponenttopology%mesh
9538  IF(ASSOCIATED(mesh)) THEN
9539  meshcomponentnumber=meshcomponenttopology%meshComponentNumber
9540  localerror="The user node number "//trim(numbertovstring(usernumber,"*",err,error))// &
9541  & " does not exist in mesh component number "//trim(numbertovstring(meshcomponentnumber,"*",err,error))// &
9542  & " of mesh number "//trim(numbertovstring(mesh%USER_NUMBER,"*",err,error))//"."
9543  CALL flagerror(localerror,err,error,*999)
9544  ELSE
9545  CALL flagerror("Mesh component topology mesh is not associated.",err,error,*999)
9546  ENDIF
9547  ENDIF
9548  ENDIF
9549  ELSE
9550  CALL flagerror("Mesh nodes is not associated.",err,error,*999)
9551  ENDIF
9552 
9553  exits("MeshTopologyNodeNumberOfVersionsGet")
9554  RETURN
9555 999 errorsexits("MeshTopologyNodeNumberOfVersionsGet",err,error)
9556  RETURN 1
9557 
9558  END SUBROUTINE meshtopologynodenumberofversionsget
9559 
9560  !
9561  !================================================================================================================================
9562  !
9563 
9565  SUBROUTINE meshtopologynodesnumberofnodesget(meshNodes,numberOfNodes,err,error,*)
9566 
9567  !Argument variables
9568  TYPE(meshnodestype), POINTER :: meshnodes
9569  INTEGER(INTG), INTENT(OUT) :: numberofnodes
9570  INTEGER(INTG), INTENT(OUT) :: err
9571  TYPE(varying_string), INTENT(OUT) :: error
9572  !Local Variables
9573 
9574  enters("MeshTopologyNodesNumberOfNodesGet",err,error,*999)
9575 
9576  IF(ASSOCIATED(meshnodes)) THEN
9577  numberofnodes=meshnodes%numberOfNodes
9578  ELSE
9579  CALL flagerror("Mesh nodes is not associated.",err,error,*999)
9580  ENDIF
9581 
9582  exits("MeshTopologyNodesNumberOfNodesGet")
9583  RETURN
9584 999 errorsexits("MeshTopologyNodesNumberOfNodesGet",err,error)
9585  RETURN 1
9586 
9587  END SUBROUTINE meshtopologynodesnumberofnodesget
9588 
9589  !
9590  !================================================================================================================================
9591  !
9592 
9594  SUBROUTINE meshtopologynodesversioncalculate(topology,err,error,*)
9595 
9596  !Argument variables
9597  TYPE(meshcomponenttopologytype), POINTER :: topology
9598  INTEGER(INTG), INTENT(OUT) :: err
9599  TYPE(varying_string), INTENT(OUT) :: error
9600  !Local Variables
9601  INTEGER(INTG) :: element,localnodeidx,derivativeidx,nodeidx,numberofversions,versionidx
9602  INTEGER(INTG), ALLOCATABLE :: versions(:)
9603  TYPE(list_ptr_type), POINTER :: nodeversionlist(:,:)
9604  TYPE(meshelementstype), POINTER :: elements
9605  TYPE(meshnodestype), POINTER :: nodes
9606  TYPE(basis_type), POINTER :: basis
9607 
9608  enters("MeshTopologyNodesVersionCalculate",err,error,*999)
9609 
9610  IF(ASSOCIATED(topology)) THEN
9611  elements=>topology%elements
9612  IF(ASSOCIATED(elements)) THEN
9613  nodes=>topology%nodes
9614  IF(ASSOCIATED(nodes)) THEN
9615  !Loop over the mesh elements
9616  !Calculate the number of versions at each node. This needs to be calculated by looking at all the mesh elements
9617  !as we may have an adjacent elements in another domain with a higher order basis along with different versions
9618  !being assigned to its derivatives.
9619  !\todo : See if there are any constraints that can be applied to restrict the amount of memory being allocated here
9620  ALLOCATE(nodeversionlist(maximum_global_deriv_number,nodes%numberOfNodes),stat=err)
9621  IF(err/=0) CALL flagerror("Could not allocate node version list.",err,error,*999)
9622  DO nodeidx=1,nodes%numberOfNodes
9623  DO derivativeidx=1,nodes%nodes(nodeidx)%numberOfDerivatives
9624  NULLIFY(nodeversionlist(derivativeidx,nodeidx)%ptr)
9625  CALL list_create_start(nodeversionlist(derivativeidx,nodeidx)%ptr,err,error,*999)
9626  CALL list_data_type_set(nodeversionlist(derivativeidx,nodeidx)%ptr,list_intg_type,err,error,*999)
9627  CALL list_initial_size_set(nodeversionlist(derivativeidx,nodeidx)%ptr,8,err,error,*999)
9628  CALL list_create_finish(nodeversionlist(derivativeidx,nodeidx)%ptr,err,error,*999)
9629  ENDdo!derivativeIdx
9630  ENDdo!nodeIdx
9631  DO element=1,elements%NUMBER_OF_ELEMENTS
9632  basis=>elements%elements(element)%basis
9633  DO localnodeidx=1,basis%NUMBER_OF_NODES
9634  DO derivativeidx=1,basis%NUMBER_OF_DERIVATIVES(localnodeidx)
9635  CALL list_item_add(nodeversionlist(derivativeidx,elements%elements(element)% &
9636  & mesh_element_nodes(localnodeidx))%ptr,elements%elements(element)%USER_ELEMENT_NODE_VERSIONS( &
9637  & derivativeidx,localnodeidx),err,error,*999)
9638  ENDdo!derivativeIdx
9639  ENDdo!localNodeIdx
9640  ENDdo!element
9641  DO nodeidx=1,nodes%numberOfNodes
9642  DO derivativeidx=1,nodes%nodes(nodeidx)%numberOfDerivatives
9643  CALL list_remove_duplicates(nodeversionlist(derivativeidx,nodeidx)%ptr,err,error,*999)
9644  CALL list_detach_and_destroy(nodeversionlist(derivativeidx,nodeidx)%ptr,numberofversions,versions, &
9645  & err,error,*999)
9646  nodes%nodes(nodeidx)%derivatives(derivativeidx)%numberOfVersions = maxval(versions(1:numberofversions))
9647  ALLOCATE(nodes%nodes(nodeidx)%derivatives(derivativeidx)%userVersionNumbers(nodes%nodes(nodeidx)% &
9648  & derivatives(derivativeidx)%numberOfVersions),stat=err)
9649  IF(err/=0) CALL flagerror("Could not allocate node global derivative index.",err,error,*999)
9650  DO versionidx=1,nodes%nodes(nodeidx)%derivatives(derivativeidx)%numberOfVersions
9651  nodes%nodes(nodeidx)%derivatives(derivativeidx)%userVersionNumbers(versionidx) = versionidx
9652  ENDDO !versionIdx
9653  DEALLOCATE(versions)
9654  ENDdo!derivativeIdx
9655  ENDdo!nodeIdx
9656  DEALLOCATE(nodeversionlist)
9657  NULLIFY(nodeversionlist)
9658  ELSE
9659  CALL flagerror("Mesh topology nodes is not associated.",err,error,*999)
9660  ENDIF
9661  ELSE
9662  CALL flagerror("Mesh topology elements is not associated.",err,error,*999)
9663  ENDIF
9664  ELSE
9665  CALL flagerror("Mesh topology is not associated.",err,error,*999)
9666  ENDIF
9667 
9668  IF(diagnostics1) THEN
9669  CALL writestringvalue(diagnostic_output_type,"Number of mesh global nodes = ",nodes%numberOfNodes,err,error,*999)
9670  DO nodeidx=1,nodes%numberOfNodes
9671  CALL writestringvalue(diagnostic_output_type," Mesh global node number = ",nodeidx,err,error,*999)
9672  CALL writestringvalue(diagnostic_output_type," Number of derivatives = ", &
9673  & nodes%nodes(nodeidx)%numberOfDerivatives,err,error,*999)
9674  DO derivativeidx=1,nodes%nodes(nodeidx)%numberOfDerivatives
9675  !\todo : change output string below so that it writes out derivativeIdx index as well
9676  CALL writestringvalue(diagnostic_output_type," Global derivative index(derivativeIdx) = ", &
9677  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%globalDerivativeIndex,err,error,*999)
9678  CALL writestringvalue(diagnostic_output_type," Partial derivative index(derivativeIdx) = ", &
9679  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%partialDerivativeIndex,err,error,*999)
9680  CALL write_string_vector(diagnostic_output_type,1,1, &
9681  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%numberOfVersions,8,8, &
9682  & nodes%nodes(nodeidx)%derivatives(derivativeidx)%userVersionNumbers, &
9683  & '(" User Version index(derivativeIdx,:) :",8(X,I2))','(36X,8(X,I2))',err,error,*999)
9684  ENDdo!derivativeIdx
9685  ENDDO !nodeIdx
9686  ENDIF
9687 
9688  exits("MeshTopologyNodesVersionCalculate")
9689  RETURN
9690 999 IF(ALLOCATED(versions)) DEALLOCATE(versions)
9691  IF(ASSOCIATED(nodeversionlist)) THEN
9692  DO nodeidx=1,nodes%numberOfNodes
9693  DO derivativeidx=1,nodes%nodes(nodeidx)%numberOfDerivatives
9694  CALL list_destroy(nodeversionlist(derivativeidx,nodeidx)%ptr,err,error,*998)
9695  ENDDO !derivativeIdx
9696  ENDDO !nodeIdx
9697  DEALLOCATE(nodeversionlist)
9698  ENDIF
9699 998 errorsexits("MeshTopologyNodesVersionCalculate",err,error)
9700  RETURN 1
9701 
9702  END SUBROUTINE meshtopologynodesversioncalculate
9703 
9704  !
9705  !================================================================================================================================
9706  !
9707 
9709  SUBROUTINE meshtopologysurroundingelementscalculate(topology,err,error,*)
9710 
9711  !Argument variables
9712  TYPE(meshcomponenttopologytype), POINTER :: topology
9713  INTEGER(INTG), INTENT(OUT) :: err
9714  TYPE(varying_string), INTENT(OUT) :: error
9715  !Local Variables
9716  INTEGER(INTG) :: element,elementidx,insertposition,localnodeidx,node,surroundingelementnumber
9717  INTEGER(INTG), POINTER :: newsurroundingelements(:)
9718  LOGICAL :: foundelement
9719  TYPE(basis_type), POINTER :: basis
9720  TYPE(meshelementstype), POINTER :: elements
9721  TYPE(meshnodestype), POINTER :: nodes
9722 
9723  NULLIFY(newsurroundingelements)
9724 
9725  enters("MeshTopologySurroundingElementsCalculate",err,error,*999)
9726 
9727  IF(ASSOCIATED(topology)) THEN
9728  elements=>topology%elements
9729  IF(ASSOCIATED(elements)) THEN
9730  nodes=>topology%nodes
9731  IF(ASSOCIATED(nodes)) THEN
9732  IF(ALLOCATED(nodes%nodes)) THEN
9733  DO elementidx=1,elements%NUMBER_OF_ELEMENTS
9734  basis=>elements%elements(elementidx)%basis
9735  DO localnodeidx=1,basis%NUMBER_OF_NODES
9736  node=elements%elements(elementidx)%MESH_ELEMENT_NODES(localnodeidx)
9737  foundelement=.false.
9738  element=1
9739  insertposition=1
9740  DO WHILE(element<=nodes%nodes(node)%numberOfSurroundingElements.AND..NOT.foundelement)
9741  surroundingelementnumber=nodes%nodes(node)%surroundingElements(element)
9742  IF(surroundingelementnumber==elementidx) THEN
9743  foundelement=.true.
9744  ENDIF
9745  element=element+1
9746  IF(elementidx>=surroundingelementnumber) THEN
9747  insertposition=element
9748  ENDIF
9749  ENDDO
9750  IF(.NOT.foundelement) THEN
9751  !Insert element into surrounding elements
9752  ALLOCATE(newsurroundingelements(nodes%nodes(node)%numberOfSurroundingElements+1),stat=err)
9753  IF(err/=0) CALL flagerror("Could not allocate new surrounding elements.",err,error,*999)
9754  IF(ASSOCIATED(nodes%nodes(node)%surroundingElements)) THEN
9755  newsurroundingelements(1:insertposition-1)=nodes%nodes(node)%surroundingElements(1:insertposition-1)
9756  newsurroundingelements(insertposition)=elementidx
9757  newsurroundingelements(insertposition+1:nodes%nodes(node)%numberOfSurroundingElements+1)= &
9758  & nodes%nodes(node)%surroundingElements(insertposition:nodes%nodes(node)%numberOfSurroundingElements)
9759  DEALLOCATE(nodes%nodes(node)%surroundingElements)
9760  ELSE
9761  newsurroundingelements(1)=elementidx
9762  ENDIF
9763  nodes%nodes(node)%surroundingElements=>newsurroundingelements
9764  nodes%nodes(node)%numberOfSurroundingElements=nodes%nodes(node)%numberOfSurroundingElements+1
9765  ENDIF
9766  ENDDO !localNodeIdx
9767  ENDDO !elementIdx
9768  ELSE
9769  CALL flagerror("Mesh topology nodes nodes have not been allocated.",err,error,*999)
9770  ENDIF
9771  ELSE
9772  CALL flagerror("Mesh topology nodes are not associated.",err,error,*999)
9773  ENDIF
9774  ELSE
9775  CALL flagerror("Mesh topology elements is not associated.",err,error,*999)
9776  ENDIF
9777  ELSE
9778  CALL flagerror("Mesh topology not associated.",err,error,*999)
9779  ENDIF
9780 
9781  exits("MeshTopologySurroundingElementsCalculate")
9782  RETURN
9783 999 IF(ASSOCIATED(newsurroundingelements)) DEALLOCATE(newsurroundingelements)
9784  errorsexits("MeshTopologySurroundingElementsCalculate",err,error)
9785  RETURN 1
9786  END SUBROUTINE meshtopologysurroundingelementscalculate
9787 
9788  !
9789  !===============================================================================================================================
9790  !
9791 
9793  SUBROUTINE meshtopologynodesfinalise(nodes,err,error,*)
9794 
9795  !Argument variables
9796  TYPE(meshnodestype), POINTER :: nodes
9797  INTEGER(INTG), INTENT(OUT) :: err
9798  TYPE(varying_string), INTENT(OUT) :: error
9799  !Local Variables
9800  INTEGER(INTG) :: nodeidx
9801 
9802  enters("MeshTopologyNodesFinalise",err,error,*999)
9803 
9804  IF(ASSOCIATED(nodes)) THEN
9805  IF(ALLOCATED(nodes%nodes)) THEN
9806  DO nodeidx=1,SIZE(nodes%nodes,1)
9807  CALL meshtopologynodefinalise(nodes%nodes(nodeidx),err,error,*999)
9808  ENDDO !nodesIdx
9809  DEALLOCATE(nodes%nodes)
9810  ENDIF
9811  IF(ASSOCIATED(nodes%nodesTree)) CALL tree_destroy(nodes%nodesTree,err,error,*999)
9812  DEALLOCATE(nodes)
9813  ENDIF
9814 
9815  exits("MeshTopologyNodesFinalise")
9816  RETURN
9817 999 errorsexits("MeshTopologyNodesFinalise",err,error)
9818  RETURN 1
9819 
9820  END SUBROUTINE meshtopologynodesfinalise
9821 
9822  !
9823  !================================================================================================================================
9824  !
9825 
9827  SUBROUTINE meshtopologynodesinitialise(topology,err,error,*)
9828 
9829  !Argument variables
9830  TYPE(meshcomponenttopologytype), POINTER :: topology
9831  INTEGER(INTG), INTENT(OUT) :: err
9832  TYPE(varying_string), INTENT(OUT) :: error
9833  !Local Variables
9834 
9835  enters("MeshTopologyNodesInitialise",err,error,*999)
9836 
9837  IF(ASSOCIATED(topology)) THEN
9838  IF(ASSOCIATED(topology%nodes)) THEN
9839  CALL flagerror("Mesh already has topology nodes associated.",err,error,*999)
9840  ELSE
9841  ALLOCATE(topology%nodes,stat=err)
9842  IF(err/=0) CALL flagerror("Could not allocate topology nodes.",err,error,*999)
9843  topology%nodes%numberOfNodes=0
9844  topology%nodes%meshComponentTopology=>topology
9845  NULLIFY(topology%nodes%nodesTree)
9846  ENDIF
9847  ELSE
9848  CALL flagerror("Topology is not associated.",err,error,*999)
9849  ENDIF
9850 
9851  exits("MeshTopologyNodesInitialise")
9852  RETURN
9853 999 errorsexits("MeshTopologyNodesInitialise",err,error)
9854  RETURN 1
9855  END SUBROUTINE meshtopologynodesinitialise
9856 
9857  !
9858  !================================================================================================================================
9859  !
9860 
9862  SUBROUTINE mesh_user_number_find_generic(USER_NUMBER,MESHES,MESH,ERR,ERROR,*)
9863 
9864  !Argument variables
9865  INTEGER(INTG), INTENT(IN) :: user_number
9866  TYPE(meshes_type), POINTER :: meshes
9867  TYPE(mesh_type), POINTER :: mesh
9868  INTEGER(INTG), INTENT(OUT) :: err
9869  TYPE(varying_string), INTENT(OUT) :: error
9870  !Local Variables
9871  INTEGER(INTG) :: mesh_idx
9872 
9873  enters("MESH_USER_NUMBER_FIND_GENERIC",err,error,*999)
9874 
9875  IF(ASSOCIATED(meshes)) THEN
9876  IF(ASSOCIATED(mesh)) THEN
9877  CALL flagerror("Mesh is already associated.",err,error,*999)
9878  ELSE
9879  NULLIFY(mesh)
9880  mesh_idx=1
9881  DO WHILE(mesh_idx<=meshes%NUMBER_OF_MESHES.AND..NOT.ASSOCIATED(mesh))
9882  IF(meshes%MESHES(mesh_idx)%PTR%USER_NUMBER==user_number) THEN
9883  mesh=>meshes%MESHES(mesh_idx)%PTR
9884  ELSE
9885  mesh_idx=mesh_idx+1
9886  ENDIF
9887  ENDDO
9888  ENDIF
9889  ELSE
9890  CALL flagerror("Meshes is not associated",err,error,*999)
9891  ENDIF
9892 
9893  exits("MESH_USER_NUMBER_FIND_GENERIC")
9894  RETURN
9895 999 errorsexits("MESH_USER_NUMBER_FIND_GENERIC",err,error)
9896  RETURN 1
9897  END SUBROUTINE mesh_user_number_find_generic
9898 
9899  !
9900  !================================================================================================================================
9901  !
9902 
9904  SUBROUTINE mesh_user_number_find_interface(USER_NUMBER,INTERFACE,MESH,ERR,ERROR,*)
9905 
9906  !Argument variables
9907  INTEGER(INTG), INTENT(IN) :: user_number
9908  TYPE(interface_type), POINTER :: interface
9909  TYPE(mesh_type), POINTER :: mesh
9910  INTEGER(INTG), INTENT(OUT) :: err
9911  TYPE(varying_string), INTENT(OUT) :: error
9912  !Local Variables
9913 
9914  enters("MESH_USER_NUMBER_FIND_INTERFACE",err,error,*999)
9915 
9916  IF(ASSOCIATED(interface)) THEN
9917  CALL mesh_user_number_find_generic(user_number,interface%MESHES,mesh,err,error,*999)
9918  ELSE
9919  CALL flagerror("Interface is not associated",err,error,*999)
9920  ENDIF
9921 
9922  exits("MESH_USER_NUMBER_FIND_INTERFACE")
9923  RETURN
9924 999 errorsexits("MESH_USER_NUMBER_FIND_INTERFACE",err,error)
9925  RETURN 1
9926 
9927  END SUBROUTINE mesh_user_number_find_interface
9928 
9929  !
9930  !================================================================================================================================
9931  !
9932 
9934  SUBROUTINE mesh_user_number_find_region(USER_NUMBER,REGION,MESH,ERR,ERROR,*)
9935 
9936  !Argument variables
9937  INTEGER(INTG), INTENT(IN) :: user_number
9938  TYPE(region_type), POINTER :: region
9939  TYPE(mesh_type), POINTER :: mesh
9940  INTEGER(INTG), INTENT(OUT) :: err
9941  TYPE(varying_string), INTENT(OUT) :: error
9942  !Local Variables
9943 
9944  enters("MESH_USER_NUMBER_FIND_REGION",err,error,*999)
9945 
9946  IF(ASSOCIATED(region)) THEN
9947  CALL mesh_user_number_find_generic(user_number,region%MESHES,mesh,err,error,*999)
9948  ELSE
9949  CALL flagerror("Region is not associated",err,error,*999)
9950  ENDIF
9951 
9952  exits("MESH_USER_NUMBER_FIND_REGION")
9953  RETURN
9954 999 errorsexits("MESH_USER_NUMBER_FIND_REGION",err,error)
9955  RETURN 1
9956  END SUBROUTINE mesh_user_number_find_region
9957 
9958  !
9959  !================================================================================================================================
9960  !
9961 
9963  SUBROUTINE meshes_finalise(MESHES,ERR,ERROR,*)
9964 
9965  !Argument variables
9966  TYPE(meshes_type), POINTER :: meshes
9967  INTEGER(INTG), INTENT(OUT) :: err
9968  TYPE(varying_string), INTENT(OUT) :: error
9969  !Local Variables
9970  TYPE(mesh_type), POINTER :: mesh
9971 
9972  enters("MESHES_FINALISE",err,error,*999)
9973 
9974  IF(ASSOCIATED(meshes)) THEN
9975  DO WHILE(meshes%NUMBER_OF_MESHES>0)
9976  mesh=>meshes%MESHES(1)%PTR
9977  CALL mesh_destroy(mesh,err,error,*999)
9978  ENDDO !mesh_idx
9979  DEALLOCATE(meshes)
9980  ELSE
9981  CALL flagerror("Meshes is not associated.",err,error,*999)
9982  ENDIF
9983 
9984  exits("MESHES_FINALISE")
9985  RETURN
9986 999 errorsexits("MESHES_FINALISE",err,error)
9987  RETURN 1
9988 
9989  END SUBROUTINE meshes_finalise
9990 
9991  !
9992  !================================================================================================================================
9993  !
9994 
9996  SUBROUTINE meshes_initialise_generic(MESHES,ERR,ERROR,*)
9997 
9998  !Argument variables
9999  TYPE(meshes_type), POINTER :: meshes
10000  INTEGER(INTG), INTENT(OUT) :: err
10001  TYPE(varying_string), INTENT(OUT) :: error
10002  !Local Variables
10003  INTEGER(INTG) :: dummy_err
10004  TYPE(varying_string) :: dummy_error
10005 
10006  enters("MESHES_INITIALISE_GENERIC",err,error,*998)
10007 
10008  IF(ASSOCIATED(meshes)) THEN
10009  CALL flagerror("Meshes is already associated.",err,error,*998)
10010  ELSE
10011  ALLOCATE(meshes,stat=err)
10012  IF(err/=0) CALL flagerror("Meshes could not be allocated",err,error,*999)
10013  NULLIFY(meshes%REGION)
10014  NULLIFY(meshes%INTERFACE)
10015  meshes%NUMBER_OF_MESHES=0
10016  NULLIFY(meshes%MESHES)
10017  ENDIF
10018 
10019  exits("MESHES_INITIALISE_GENERIC")
10020  RETURN
10021 999 CALL meshes_finalise(meshes,dummy_err,dummy_error,*998)
10022 998 errorsexits("MESHES_INITIALISE_GENERIC",err,error)
10023  RETURN 1
10024  END SUBROUTINE meshes_initialise_generic
10025 
10026  !
10027  !================================================================================================================================
10028  !
10029 
10031  SUBROUTINE meshes_initialise_interface(INTERFACE,ERR,ERROR,*)
10032 
10033  !Argument variables
10034  TYPE(interface_type), POINTER :: interface
10035  INTEGER(INTG), INTENT(OUT) :: err
10036  TYPE(varying_string), INTENT(OUT) :: error
10037  !Local Variables
10038  TYPE(varying_string) :: local_error
10039 
10040  enters("MESHES_INITIALISE_INTERFACE",err,error,*999)
10041 
10042  IF(ASSOCIATED(interface)) THEN
10043  IF(ASSOCIATED(interface%MESHES)) THEN
10044  local_error="Interface number "//trim(numbertovstring(interface%USER_NUMBER,"*",err,error))// &
10045  & " already has a mesh associated"
10046  CALL flagerror(local_error,err,error,*999)
10047  ELSE
10048  CALL meshes_initialise_generic(interface%MESHES,err,error,*999)
10049  interface%MESHES%INTERFACE=>INTERFACE
10050  ENDIF
10051  ELSE
10052  CALL flagerror("Interface is not associated",err,error,*999)
10053  ENDIF
10054 
10055  exits("MESHES_INITIALISE_INTERFACE")
10056  RETURN
10057 999 errorsexits("MESHES_INITIALISE_INTERFACE",err,error)
10058  RETURN 1
10059  END SUBROUTINE meshes_initialise_interface
10060 
10061  !
10062  !================================================================================================================================
10063  !
10064 
10066  SUBROUTINE meshes_initialise_region(REGION,ERR,ERROR,*)
10067 
10068  !Argument variables
10069  TYPE(region_type), POINTER :: region
10070  INTEGER(INTG), INTENT(OUT) :: err
10071  TYPE(varying_string), INTENT(OUT) :: error
10072  !Local Variables
10073  TYPE(varying_string) :: local_error
10074 
10075  enters("MESHES_INITIALISE_REGION",err,error,*999)
10076 
10077  IF(ASSOCIATED(region)) THEN
10078  IF(ASSOCIATED(region%MESHES)) THEN
10079  local_error="Region number "//trim(numbertovstring(region%USER_NUMBER,"*",err,error))// &
10080  & " already has a mesh associated"
10081  CALL flagerror(local_error,err,error,*999)
10082  ELSE
10083  CALL meshes_initialise_generic(region%MESHES,err,error,*999)
10084  region%MESHES%REGION=>region
10085  ENDIF
10086  ELSE
10087  CALL flagerror("Region is not associated",err,error,*999)
10088  ENDIF
10089 
10090  exits("MESHES_INITIALISE_REGION")
10091  RETURN
10092 999 errorsexits("MESHES_INITIALISE_REGION",err,error)
10093  RETURN 1
10094  END SUBROUTINE meshes_initialise_region
10095 
10096  !
10097  !================================================================================================================================
10098  !
10099 
10101  SUBROUTINE decomposition_node_domain_get(DECOMPOSITION,USER_NODE_NUMBER,MESH_COMPONENT_NUMBER,DOMAIN_NUMBER,ERR,ERROR,*)
10102 
10103  !Argument variables
10104  TYPE(decomposition_type), POINTER :: decomposition
10105  INTEGER(INTG), INTENT(IN) :: user_node_number
10106  INTEGER(INTG), INTENT(IN) :: mesh_component_number
10107  INTEGER(INTG), INTENT(OUT) :: domain_number
10108  INTEGER(INTG), INTENT(OUT) :: err
10109  TYPE(varying_string), INTENT(OUT) :: error
10110  !Local Variables`
10111  TYPE(mesh_type), POINTER :: mesh
10112  TYPE(meshcomponenttopologytype), POINTER :: mesh_topology
10113  TYPE(varying_string) :: local_error
10114  INTEGER(INTG) :: global_node_number
10115  TYPE(tree_node_type), POINTER :: tree_node
10116  TYPE(meshnodestype), POINTER :: mesh_nodes
10117  TYPE(domain_type), POINTER :: mesh_domain
10118 
10119  enters("DECOMPOSITION_NODE_DOMAIN_GET",err,error,*999)
10120 
10121 !!TODO: interface should specify user element number ???
10122  global_node_number=0
10123  IF(ASSOCIATED(decomposition)) THEN
10124  IF(decomposition%DECOMPOSITION_FINISHED) THEN
10125  mesh=>decomposition%MESH
10126  IF(ASSOCIATED(mesh)) THEN
10127  mesh_topology=>mesh%TOPOLOGY(mesh_component_number)%PTR
10128  IF(ASSOCIATED(mesh_topology)) THEN
10129  mesh_nodes=>mesh_topology%nodes
10130  IF(ASSOCIATED(mesh_nodes)) THEN
10131  NULLIFY(tree_node)
10132  CALL tree_search(mesh_nodes%nodesTree,user_node_number,tree_node,err,error,*999)
10133  IF(ASSOCIATED(tree_node)) THEN
10134  CALL tree_node_value_get(mesh_nodes%nodesTree,tree_node,global_node_number,err,error,*999)
10135  IF(global_node_number>0.AND.global_node_number<=mesh_topology%NODES%numberOfNodes) THEN
10136  IF(mesh_component_number>0.AND.mesh_component_number<=mesh%NUMBER_OF_COMPONENTS) THEN
10137  mesh_domain=>decomposition%DOMAIN(mesh_component_number)%PTR
10138  IF(ASSOCIATED(mesh_domain)) THEN
10139  domain_number=mesh_domain%NODE_DOMAIN(global_node_number)
10140  ELSE
10141  CALL flagerror("Decomposition domain is not associated.",err,error,*999)
10142  ENDIF
10143  ELSE
10144  local_error="Mesh Component number "//trim(numbertovstring(mesh_component_number,"*",err,error))// &
10145  & " is invalid. The limits are 1 to "// &
10146  & trim(numbertovstring(mesh%NUMBER_OF_COMPONENTS,"*",err,error))//"."
10147  CALL flagerror(local_error,err,error,*999)
10148  ENDIF
10149  ELSE
10150  local_error="Global element number found "//trim(numbertovstring(global_node_number,"*",err,error))// &
10151  & " is invalid. The limits are 1 to "// &
10152  & trim(numbertovstring(mesh_topology%NODES%numberOfNodes,"*",err,error))//"."
10153  CALL flagerror(local_error,err,error,*999)
10154  ENDIF
10155  ELSE
10156  CALL flagerror("Decomposition mesh node corresponding to user number not found.",err,error,*999)
10157  ENDIF
10158  ELSE
10159  CALL flagerror("Decomposition mesh nodes are not associated.",err,error,*999)
10160  ENDIF
10161  ELSE
10162  CALL flagerror("Decomposition mesh topology is not associated.",err,error,*999)
10163  ENDIF
10164  ELSE
10165  CALL flagerror("Decomposition mesh is not associated.",err,error,*999)
10166  ENDIF
10167  ELSE
10168  CALL flagerror("Decomposition has not been finished.",err,error,*999)
10169  ENDIF
10170  ELSE
10171  CALL flagerror("Decomposition is not associated.",err,error,*999)
10172  ENDIF
10173 
10174  exits("DECOMPOSITION_NODE_DOMAIN_GET")
10175  RETURN
10176 999 errorsexits("DECOMPOSITION_NODE_DOMAIN_GET",err,error)
10177  RETURN 1
10178  END SUBROUTINE decomposition_node_domain_get
10179 
10180  !
10181  !================================================================================================================================
10182  !
10183 
10185  SUBROUTINE embedded_mesh_initialise(MESH_EMBEDDING,ERR,ERROR,*)
10186 
10187  !Argument variables
10188  !TYPE(MESH_EMBEDDING_TYPE), INTENT(INOUT) :: MESH_EMBEDDING !<Mesh embedding to initialise
10189  TYPE(mesh_embedding_type), POINTER :: mesh_embedding
10190  INTEGER(INTG), INTENT(OUT) :: err
10191  TYPE(varying_string), INTENT(OUT) :: error
10192  !Local Variables
10193 
10194  enters("EMBEDDED_MESH_INITIALISE",err,error,*998)
10195 
10196  ALLOCATE(mesh_embedding,stat=err)
10197  NULLIFY(mesh_embedding%PARENT_MESH)
10198  NULLIFY(mesh_embedding%CHILD_MESH)
10199 
10200  exits("EMBEDDED_MESH_INITIALISE")
10201  RETURN
10202 !999 CALL EMBEDDED_MESH_FINALISE(MESH_EMBEDDING,DUMMY_ERR,DUMMY_ERROR,*998)
10203 998 errorsexits("EMBEDDED_MESH_INITIALISE",err,error)
10204  RETURN 1
10205  END SUBROUTINE embedded_mesh_initialise
10206 
10207  !
10208  !================================================================================================================================
10209  !
10210 
10212  SUBROUTINE mesh_embedding_create(MESH_EMBEDDING, PARENT_MESH, CHILD_MESH,ERR,ERROR,*)
10213 ! TYPE(MESH_EMBEDDING_TYPE), INTENT(INOUT) :: MESH_EMBEDDING !<Mesh embedding to create.
10214  TYPE(mesh_embedding_type), POINTER :: mesh_embedding
10215  TYPE(mesh_type), POINTER, INTENT(IN) :: parent_mesh
10216  TYPE(mesh_type), POINTER, INTENT(IN) :: child_mesh
10217  INTEGER(INTG), INTENT(OUT) :: err
10218  TYPE(varying_string), INTENT(OUT) :: error
10219  !Local variables
10220  INTEGER(INTG) :: ngp = 0, ne
10221 
10222  enters("MESH_EMBEDDING_CREATE",err,error,*999)
10223 
10224  WRITE(*,*) 'parent mesh', parent_mesh%NUMBER_OF_ELEMENTS
10225  WRITE(*,*) 'child mesh', child_mesh%NUMBER_OF_ELEMENTS
10226  CALL embedded_mesh_initialise(mesh_embedding,err,error,*999)
10227 
10228  DO ne=1,parent_mesh%NUMBER_OF_ELEMENTS
10229  ngp = max(ngp,parent_mesh%TOPOLOGY(1)%PTR%ELEMENTS%ELEMENTS(ne)%BASIS%QUADRATURE%&
10230  & quadrature_scheme_map(basis_default_quadrature_scheme)%PTR%NUMBER_OF_GAUSS)
10231  ENDDO !ne
10232 
10233  mesh_embedding%PARENT_MESH => parent_mesh
10234  mesh_embedding%CHILD_MESH => child_mesh
10235  ALLOCATE(mesh_embedding%CHILD_NODE_XI_POSITION(parent_mesh%NUMBER_OF_ELEMENTS),stat=err)
10236  IF(err/=0) CALL flagerror("Could not allocate child node positions.",err,error,*999)
10237  ALLOCATE(mesh_embedding%GAUSS_POINT_XI_POSITION(ngp,parent_mesh%NUMBER_OF_ELEMENTS),stat=err)
10238  IF(err/=0) CALL flagerror("Could not allocate gauss point positions.",err,error,*999)
10239 
10240  exits("MESH_EMBEDDING_CREATE")
10241  RETURN
10242 
10243 999 errorsexits("MESH_EMBEDDING_CREATE",err,error)
10244  RETURN 1
10245  END SUBROUTINE mesh_embedding_create
10246 
10247  !
10248  !================================================================================================================================
10249  !
10250 
10252  SUBROUTINE mesh_embedding_set_child_node_position(MESH_EMBEDDING, ELEMENT_NUMBER, NODE_NUMBERS, XI_COORDS,ERR,ERROR,*)
10253  TYPE(mesh_embedding_type), INTENT(INOUT) :: mesh_embedding
10254  INTEGER(INTG), INTENT(IN) :: element_number
10255  INTEGER(INTG), INTENT(IN) :: node_numbers(:)
10256  REAL(DP), INTENT(IN) :: xi_coords(:,:)
10257 
10258  INTEGER(INTG), INTENT(OUT) :: err
10259  TYPE(varying_string), INTENT(OUT) :: error
10260 
10261  enters("MESH_EMBEDDING_SET_CHILD_NODE_POSITION",err,error,*999)
10262 
10263  IF(element_number<1 .OR. element_number > mesh_embedding%PARENT_MESH%NUMBER_OF_ELEMENTS) THEN
10264  CALL flagerror("Element number out of range",err,error,*999)
10265  ENDIF
10266 
10267  mesh_embedding%CHILD_NODE_XI_POSITION(element_number)%NUMBER_OF_NODES = SIZE(node_numbers)
10268 
10269  ALLOCATE(mesh_embedding%CHILD_NODE_XI_POSITION(element_number)%NODE_NUMBERS(SIZE(node_numbers)))
10270  mesh_embedding%CHILD_NODE_XI_POSITION(element_number)%NODE_NUMBERS(1:SIZE(node_numbers)) = node_numbers(1:SIZE(node_numbers))
10271 
10272  ALLOCATE(mesh_embedding%CHILD_NODE_XI_POSITION(element_number)%XI_COORDS(SIZE(xi_coords,1),SIZE(xi_coords,2)))
10273  mesh_embedding%CHILD_NODE_XI_POSITION(element_number)%XI_COORDS(1:SIZE(xi_coords,1),1:SIZE(xi_coords,2)) = &
10274  & xi_coords(1:SIZE(xi_coords,1),1:SIZE(xi_coords,2))
10275 
10276  RETURN
10277 999 errorsexits("MESH_EMBEDDING_SET_CHILD_NODE_POSITION",err,error)
10278  RETURN 1
10279  END SUBROUTINE mesh_embedding_set_child_node_position
10280 
10281  !
10282  !================================================================================================================================
10283  !
10284 
10286  SUBROUTINE mesh_embedding_set_gauss_point_data(MESH_EMBEDDING, PARENT_ELEMENT_NUMBER, GAUSSPT_NUMBER,&
10287  & parent_xi_coord, child_element_number, child_xi_coord,err,error,*)
10288  TYPE(mesh_embedding_type), INTENT(INOUT) :: mesh_embedding
10289  INTEGER(INTG), INTENT(IN) :: parent_element_number
10290  INTEGER(INTG), INTENT(IN) :: gausspt_number
10291  REAL(DP), INTENT(IN) :: parent_xi_coord(:)
10292 
10293  INTEGER(INTG), INTENT(IN) :: child_element_number
10294  REAL(DP), INTENT(IN) :: child_xi_coord(:)
10295 
10296  INTEGER(INTG), INTENT(OUT) :: err
10297  TYPE(varying_string), INTENT(OUT) :: error
10298 
10299  enters("MESH_EMBEDDING_SET_GAUSS_POINT_DATA",err,error,*999)
10300 
10301  IF(parent_element_number<1 .OR. parent_element_number > mesh_embedding%PARENT_MESH%NUMBER_OF_ELEMENTS) THEN
10302  CALL flagerror("Parent element number out of range",err,error,*999)
10303  ENDIF
10304  IF(child_element_number<1 .OR. child_element_number > mesh_embedding%CHILD_MESH%NUMBER_OF_ELEMENTS) THEN
10305  CALL flagerror("Child element number out of range",err,error,*999)
10306  ENDIF
10307  IF(gausspt_number<1 .OR. gausspt_number > SIZE(mesh_embedding%GAUSS_POINT_XI_POSITION,1)) THEN
10308  CALL flagerror("Gauss point number out of range",err,error,*999)
10309  ENDIF
10310 
10311  ALLOCATE(mesh_embedding%GAUSS_POINT_XI_POSITION(gausspt_number,parent_element_number)&
10312  & %PARENT_XI_COORD(SIZE(parent_xi_coord)))
10313  ALLOCATE(mesh_embedding%GAUSS_POINT_XI_POSITION(gausspt_number,parent_element_number)&
10314  & %CHILD_XI_COORD(SIZE(child_xi_coord)))
10315 
10316 
10317  mesh_embedding%GAUSS_POINT_XI_POSITION(gausspt_number,parent_element_number)%PARENT_XI_COORD(1:SIZE(parent_xi_coord)) = &
10318  & parent_xi_coord(1:SIZE(parent_xi_coord))
10319  mesh_embedding%GAUSS_POINT_XI_POSITION(gausspt_number,parent_element_number)%CHILD_XI_COORD(1:SIZE(child_xi_coord)) = &
10320  & child_xi_coord(1:SIZE(child_xi_coord))
10321  mesh_embedding%GAUSS_POINT_XI_POSITION(gausspt_number,parent_element_number)%ELEMENT_NUMBER = child_element_number
10322 
10323  RETURN
10324 999 errorsexits("MESH_EMBEDDING_SET_GAUSS_POINT_DATA",err,error)
10325  RETURN 1
10326  END SUBROUTINE mesh_embedding_set_gauss_point_data
10327 
10328 
10329  !
10330  !================================================================================================================================
10331  !
10332 
10334  SUBROUTINE mesh_user_number_to_mesh( USER_NUMBER, REGION, MESH, ERR, ERROR, * )
10335  !Arguments
10336  INTEGER(INTG), INTENT(IN) :: user_number
10337  TYPE(region_type), POINTER :: region
10338  TYPE(mesh_type), POINTER :: mesh
10339  INTEGER(INTG), INTENT(OUT) :: err
10340  TYPE(varying_string), INTENT(OUT) :: error
10341 
10342  !Locals
10343  TYPE(varying_string) :: local_error
10344 
10345  enters("MESH_USER_NUMBER_TO_MESH", err, error, *999 )
10346 
10347  NULLIFY( mesh )
10348  CALL mesh_user_number_find( user_number, region, mesh, err, error, *999 )
10349  IF( .NOT.ASSOCIATED( mesh ) ) THEN
10350  local_error = "A mesh with an user number of "//trim(numbertovstring( user_number, "*", err, error ))// &
10351  & " does not exist on region number "//trim(numbertovstring( region%USER_NUMBER, "*", err, error ))//"."
10352  CALL flagerror( local_error, err, error, *999 )
10353  ENDIF
10354 
10355  exits( "MESH_USER_NUMBER_TO_MESH" )
10356  RETURN
10357 999 errorsexits( "MESH_USER_NUMBER_TO_MESH", err, error )
10358  RETURN 1
10359 
10360  END SUBROUTINE mesh_user_number_to_mesh
10361 
10362  !
10363  !================================================================================================================================
10364  !
10365 !!\todo THIS SHOULD REALLY BE MESH_USER_NUMBER_TO_DECOMPOSITION
10366 
10368  SUBROUTINE decomposition_user_number_to_decomposition( USER_NUMBER, MESH, DECOMPOSITION, ERR, ERROR, * )
10369  !Arguments
10370  INTEGER(INTG), INTENT(IN) :: user_number
10371  TYPE(mesh_type), POINTER :: mesh
10372  TYPE(decomposition_type), POINTER :: decomposition
10373  INTEGER(INTG), INTENT(OUT) :: err
10374  TYPE(varying_string), INTENT(OUT) :: error
10375 
10376  !Locals
10377  TYPE(varying_string) :: local_error
10378 
10379  enters("DECOMPOSITION_USER_NUMBER_TO_DECOMPOSITION", err, error, *999 )
10380 
10381  NULLIFY( decomposition )
10382  CALL decomposition_user_number_find( user_number, mesh, decomposition, err, error, *999 )
10383  IF( .NOT.ASSOCIATED( decomposition ) ) THEN
10384  local_error = "A decomposition with an user number of "//trim(numbertovstring( user_number, "*", err, error ))// &
10385  & " does not exist on mesh number "//trim(numbertovstring( mesh%USER_NUMBER, "*", err, error ))//"."
10386  CALL flagerror( local_error, err, error, *999 )
10387  ENDIF
10388 
10389  exits( "DECOMPOSITION_USER_NUMBER_TO_DECOMPOSITION" )
10390  RETURN
10391 999 errors( "DECOMPOSITION_USER_NUMBER_TO_DECOMPOSITION", err, error )
10392  exits( "DECOMPOSITION_USER_NUMBER_TO_DECOMPOSITION")
10393  RETURN 1
10394 
10395  END SUBROUTINE decomposition_user_number_to_decomposition
10396 
10397  !
10398  !================================================================================================================================
10399  !
10400 
10401 END MODULE mesh_routines
10402 
basis_routines
This module contains all basis function routines.
Definition: basis_routines.f90:45
base_routines::enters
subroutine, public enters(NAME, ERR, ERROR,)
Records the entry into the named procedure and initialises the error code.
Definition: base_routines.f90:363
trees::tree_insert_type_set
subroutine, public tree_insert_type_set(TREE, INSERT_TYPE, ERR, ERROR,)
Sets/changes the insert type for a tree.
Definition: trees.f90:480
input_output::write_string_value
Write a string followed by a value to a given output stream.
Definition: input_output.f90:86
coordinate_routines
This module contains all coordinate transformation and support routines.
Definition: coordinate_routines.f90:45
types::region_type
Contains information for a region.
Definition: types.f90:3252
types::domain_face_type
Contains the information for a face in a domain.
Definition: types.f90:644
types::meshnodetype
Contains the topology information for a global node of a mesh.
Definition: types.f90:421
base_routines::cmiss_random_seeds
integer(intg), dimension(:), allocatable, public cmiss_random_seeds
The current error handling seeds for OpenCMISS.
Definition: base_routines.f90:151
constants::partial_derivative_global_derivative_map
integer(intg), dimension(20) partial_derivative_global_derivative_map
PARTIAL_DERIVATIVE_GLOBAL_DERIVATIVE_MAP(nu) gives the global derivative index for the the nu&#39;th part...
Definition: constants.f90:262
constants::no_global_deriv
integer(intg), parameter no_global_deriv
No global derivative i.e., u.
Definition: constants.f90:213
strings::number_to_vstring
Converts a number to its equivalent varying string representation.
Definition: strings.f90:161
trees
Implements trees of base types.
Definition: trees.f90:45
types::decomposition_ptr_type
A buffer type to allow for an array of pointers to a DECOMPOSITION_TYPE.
Definition: types.f90:1081
types::decomposition_type
Contains information on the mesh decomposition.
Definition: types.f90:1063
kinds::idx
integer, parameter idx
Integer index kind.
Definition: kinds.f90:59
trees::tree_node_insert_sucessful
integer(intg), parameter, public tree_node_insert_sucessful
Successful insert status.
Definition: trees.f90:73
types::domain_topology_type
Contains the topology information for a domain.
Definition: types.f90:724
domain_mappings::domain_local_boundary
integer(intg), parameter, public domain_local_boundary
The domain item is on the boundary of the domain.
Definition: domain_mappings.f90:69
kinds::intg
integer, parameter intg
Standard integer kind.
Definition: kinds.f90:55
types::data_points_type
Contains information on the data points defined on a region.
Definition: types.f90:333
types::meshnodederivativetype
Contains the information for a node derivative of a mesh.
Definition: types.f90:412
trees::tree_search
subroutine, public tree_search(TREE, KEY, X, ERR, ERROR,)
Searches a tree to see if it contains a key.
Definition: trees.f90:1277
strings
This module contains all string manipulation and transformation routines.
Definition: strings.f90:45
types::domain_node_derivative_type
Contains the topology information for a local node derivative of a domain.
Definition: types.f90:687
types::meshcomponenttopologyptrtype
A buffer type to allow for an array of pointers to a MeshComponentTopologyType.
Definition: types.f90:478
basis_routines::basis_b_spline_tp_type
integer(intg), parameter, public basis_b_spline_tp_type
B-spline basis type.
Definition: basis_routines.f90:72
trees::tree_node_type
Definition: trees.f90:87
basis_routines::basis_simplex_type
integer(intg), parameter, public basis_simplex_type
Simplex basis type.
Definition: basis_routines.f90:69
trees::tree_detach_and_destroy
subroutine, public tree_detach_and_destroy(TREE, NUMBER_IN_TREE, TREE_VALUES, ERR, ERROR,)
Detaches the tree values and returns them as a pointer to the an array and then destroys the tree...
Definition: trees.f90:335
lists::list_intg_type
integer(intg), parameter, public list_intg_type
Integer data type for a list.
Definition: lists.f90:67
base_routines::diagnostics2
logical, save, public diagnostics2
.TRUE. if level 2 diagnostic output is active in the current routine
Definition: base_routines.f90:154
types::decompositions_type
Contains information on the domain decompositions defined on a mesh.
Definition: types.f90:1086
iso_varying_string
This module provides an iso_varying_string module, conformant to the API specified in ISO/IEC 1539-2:...
Definition: iso_varying_string.f90:62
lists::list_remove_duplicates
subroutine, public list_remove_duplicates(LIST, ERR, ERROR,)
Removes duplicate entries from a list. A side effect of this is that the list is sorted.
Definition: lists.f90:2648
types::domain_element_type
Contains the information for an element in a domain.
Definition: types.f90:668
iso_varying_string::varying_string
Definition: iso_varying_string.f90:75
domain_mappings::domain_local_ghost
integer(intg), parameter, public domain_local_ghost
The domain item is ghosted from another domain.
Definition: domain_mappings.f90:70
types::decomposition_face_type
Contains the information for a face in a decomposition.
Definition: types.f90:979
types::domain_line_type
Contains the information for a line in a domain.
Definition: types.f90:622
basis_routines::basis_serendipity_type
integer(intg), parameter, public basis_serendipity_type
Serendipity basis type.
Definition: basis_routines.f90:70
types::domain_elements_type
Contains the topology information for the elements of a domain.
Definition: types.f90:677
lists::list_detach_and_destroy
Detaches the list values from a list and returns them as a pointer to a array of base type before des...
Definition: lists.f90:113
types::decomposition_line_type
Contains the information for a line in a decomposition.
Definition: types.f90:961
types::data_projection_type
Definition: types.f90:289
types::domain_dofs_type
Contains information on the degrees-of-freedom (dofs) for a domain.
Definition: types.f90:613
kinds::dp
integer, parameter dp
Double precision real kind.
Definition: kinds.f90:68
types::decomposition_topology_type
Contains the topology information for a decomposition.
Definition: types.f90:1054
base_routines::exits
subroutine, public exits(NAME)
Records the exit out of the named procedure.
Definition: base_routines.f90:504
types::data_projection_result_type
Contains information about a data projection result.
Definition: types.f90:278
basis_routines::basis_extended_lagrange_tp_type
integer(intg), parameter, public basis_extended_lagrange_tp_type
Extendend Lagrange tensor product basis type.
Definition: basis_routines.f90:74
types
This module contains all type definitions in order to avoid cyclic module references.
Definition: types.f90:70
trees::tree_type
Definition: trees.f90:97
types::domain_node_type
Contains the topology information for a local node of a domain.
Definition: types.f90:696
basis_routines::basis_fourier_lagrange_hermite_tp_type
integer(intg), parameter, public basis_fourier_lagrange_hermite_tp_type
Fourier-Lagrange tensor product basis type.
Definition: basis_routines.f90:73
types::decomposition_faces_type
Contains the topology information for the faces of a decomposition.
Definition: types.f90:991
constants::other_xi_directions3
integer(intg), dimension(3, 3, 2) other_xi_directions3
OTHER_XI_DIRECTIONS3(ni,nii,type) gives the other xi directions for direction ni for a three dimensio...
Definition: constants.f90:275
input_output::write_string
Write a string to a given output stream.
Definition: input_output.f90:74
base_routines
This module contains all the low-level base routines e.g., all debug, control, and low-level communic...
Definition: base_routines.f90:45
types::meshdofstype
Contains information on the dofs for a mesh.
Definition: types.f90:376
trees::tree_item_delete
subroutine, public tree_item_delete(TREE, KEY, ERR, ERROR,)
Deletes a tree node specified by a key from a tree.
Definition: trees.f90:521
domain_mappings::domain_mappings_local_from_global_calculate
subroutine, public domain_mappings_local_from_global_calculate(DOMAIN_MAPPING, ERR, ERROR,)
Calculates the domain mappings local map from a domain mappings global map.
Definition: domain_mappings.f90:188
iso_varying_string::trim
Definition: iso_varying_string.f90:204
lists::list_create_finish
subroutine, public list_create_finish(LIST, ERR, ERROR,)
Finishes the creation of a list created with LIST_CREATE_START.
Definition: lists.f90:419
comp_environment::computational_nodes_number_get
integer(intg) function, public computational_nodes_number_get(ERR, ERROR)
Returns the number of computational nodes.
Definition: computational_environment.f90:668
types::domain_mappings_type
Contains information on the domain decomposition mappings.
Definition: types.f90:930
types::decompositiondatapointstype
Contains data point decompostion topology.
Definition: types.f90:1041
trees::tree_create_finish
subroutine, public tree_create_finish(TREE, ERR, ERROR,)
Finishes the creation of a tree created with TREE_CREATE_START.
Definition: trees.f90:190
types::list_type
Contains information on a list.
Definition: types.f90:113
comp_environment
This module contains all computational environment variables.
Definition: computational_environment.f90:46
types::mesh_element_type
Contains the information for an element in a mesh.
Definition: types.f90:388
cmiss_mpi
This module contains CMISS MPI routines.
Definition: cmiss_mpi.f90:45
types::meshes_type
Contains information on the meshes defined on a region.
Definition: types.f90:529
input_output::writestringvalue
Write a string followed by a value to a given output stream.
Definition: input_output.f90:97
domain_mappings
This module handles all domain mappings routines.
Definition: domain_mappings.f90:45
base_routines::my_computational_node_number
integer(intg), save my_computational_node_number
The computational rank for this node.
Definition: base_routines.f90:149
types::domain_faces_type
Contains the topology information for the faces of a domain.
Definition: types.f90:661
comp_environment::computational_environment
type(computational_environment_type), target, public computational_environment
The computational environment the program is running in.
Definition: computational_environment.f90:125
domain_mappings::domain_local_internal
integer(intg), parameter, public domain_local_internal
The domain item is internal to the domain.
Definition: domain_mappings.f90:68
types::decomposition_elements_type
Contains the topology information for the elements of a decomposition.
Definition: types.f90:1017
types::meshnodestype
Contains the information for the nodes of a mesh.
Definition: types.f90:433
trees::tree_no_duplicates_allowed
integer(intg), parameter, public tree_no_duplicates_allowed
No duplicate keys allowed tree type.
Definition: trees.f90:82
types::mesh_type
Contains information on a mesh defined on a region.
Definition: types.f90:503
domain_mappings::domain_mappings_mapping_initialise
subroutine, public domain_mappings_mapping_initialise(DOMAIN_MAPPING, NUMBER_OF_DOMAINS, ERR, ERROR,)
Initialises the mapping for a domain mappings mapping.
Definition: domain_mappings.f90:730
constants::other_xi_directions4
integer(intg), dimension(4, 3) other_xi_directions4
OTHER_XI_DIRECTIONS4(nic,nii) gives the other xi coordinates for coordinate nic for a simplex element...
Definition: constants.f90:277
types::domain_nodes_type
Contains the topology information for the nodes of a domain.
Definition: types.f90:713
types::decomposition_adjacent_element_type
Contains information on the decomposition adjacent elements for a xi coordinate.
Definition: types.f90:998
basis_routines::basis_lagrange_hermite_tp_type
integer(intg), parameter, public basis_lagrange_hermite_tp_type
Lagrange-Hermite tensor product basis type.
Definition: basis_routines.f90:68
base_routines::diagnostics1
logical, save, public diagnostics1
.TRUE. if level 1 diagnostic output is active in the current routine
Definition: base_routines.f90:153
types::decomposition_lines_type
Contains the topology information for the lines of a decomposition.
Definition: types.f90:972
domain_mappings::domain_mappings_mapping_finalise
subroutine, public domain_mappings_mapping_finalise(DOMAIN_MAPPING, ERR, ERROR,)
Finalises the mapping for a domain mappings mapping and deallocates all memory.
Definition: domain_mappings.f90:636
trees::tree_destroy
subroutine, public tree_destroy(TREE, ERR, ERROR,)
Destroys a tree.
Definition: trees.f90:265
input_output::write_string_vector
Write a string followed by a vector to a specified output stream.
Definition: input_output.f90:290
basis_routines::basis_auxilliary_type
integer(intg), parameter, public basis_auxilliary_type
Auxillary basis type.
Definition: basis_routines.f90:71
base_routines::diagnostic_output_type
integer(intg), parameter, public diagnostic_output_type
Diagnostic output type.
Definition: base_routines.f90:67
cmiss_parmetis::parmetis_partmeshkway
subroutine, public parmetis_partmeshkway(ELEMENT_DISTANCE, ELEMENT_PTR, ELEMENT_INDEX, ELEMENT_WEIGHT, WEIGHT_FLAG, NUM_FLAG, NCON, NUMBER_COMMON_NODES, NUMBER_PARTS, TP_WEIGHTS, UB_VEC, OPTIONS, NUMBER_EDGES_CUT, PARTITION, COMMUNICATOR, ERR, ERROR,)
Buffer routine to the ParMetis ParMETIS_V3_PartMeshKway routine.
Definition: cmiss_parmetis.f90:173
cmiss_parmetis
This module is a CMISS buffer module to the ParMETIS library.
Definition: cmiss_parmetis.f90:45
types::nodes_type
Contains information on the nodes defined on a region.
Definition: types.f90:359
lists::list_create_start
subroutine, public list_create_start(LIST, ERR, ERROR,)
Starts the creation of a list and returns a pointer to the created list.
Definition: lists.f90:486
lists::list_subset_of
Checks whether an array is a subset of another array.
Definition: lists.f90:328
input_output::writestring
Write a string to a given output stream.
Definition: input_output.f90:80
types::domain_mapping_type
Contains information on the domain mappings (i.e., local and global numberings).
Definition: types.f90:904
constants::maximum_global_deriv_number
integer(intg), parameter maximum_global_deriv_number
The maximum global derivative number.
Definition: constants.f90:212
types::domain_type
A pointer to the domain decomposition for this domain.
Definition: types.f90:938
types::mesh_ptr_type
A buffer type to allow for an array of pointers to a MESH_TYPE.
Definition: types.f90:524
trees::tree_item_insert
subroutine, public tree_item_insert(TREE, KEY, VALUE, INSERT_STATUS, ERR, ERROR,)
Inserts a tree node into a red-black tree.
Definition: trees.f90:769
lists::list_item_add
Adds an item to the end of a list.
Definition: lists.f90:133
domain_mappings::domain_mappings_mapping_global_initialise
subroutine, public domain_mappings_mapping_global_initialise(MAPPING_GLOBAL_MAP, ERR, ERROR,)
Finalises the global mapping in the given domain mappings.
Definition: domain_mappings.f90:706
base_routines::errors
subroutine, public errors(NAME, ERR, ERROR)
Records the exiting error of the subroutine.
Definition: base_routines.f90:481
types::interface_type
Contains information for the interface data.
Definition: types.f90:2228
lists
Implements lists of base types.
Definition: lists.f90:46
lists::list_data_type_set
subroutine, public list_data_type_set(LIST, DATA_TYPE, ERR, ERROR,)
Sets/changes the data type for a list.
Definition: lists.f90:579
lists::list_destroy
subroutine, public list_destroy(LIST, ERR, ERROR,)
Destroys a list.
Definition: lists.f90:622
trees::tree_node_value_get
subroutine, public tree_node_value_get(TREE, TREE_NODE, VALUE, ERR, ERROR,)
Gets the value at a specified tree node.
Definition: trees.f90:1059
types::basis_type
Contains all information about a basis .
Definition: types.f90:184
types::meshcomponenttopologytype
Contains information on the (global) topology of a mesh.
Definition: types.f90:468
base_routines::flagerror
Flags an error condition.
Definition: base_routines.f90:240
trees::tree_create_start
subroutine, public tree_create_start(TREE, ERR, ERROR,)
Starts the creation of a tree and returns a pointer to the created tree.
Definition: trees.f90:233
types::mesh_adjacent_element_type
Contains information on the mesh adjacent elements for a xi coordinate.
Definition: types.f90:382
types::list_ptr_type
Buffer type to allow arrays of pointers to a list.
Definition: types.f90:108
lists::list_initial_size_set
subroutine, public list_initial_size_set(LIST, INITIAL_SIZE, ERR, ERROR,)
Sets/changes the initial size for a list.
Definition: lists.f90:863
base_routines::number_of_computational_nodes
integer(intg), save number_of_computational_nodes
The number of computational nodes.
Definition: base_routines.f90:150
comp_environment::computational_node_number_get
integer(intg) function, public computational_node_number_get(ERR, ERROR)
Returns the number/rank of the computational nodes.
Definition: computational_environment.f90:640
types::meshelementstype
Contains the information for the elements of a mesh.
Definition: types.f90:403
kinds
This module contains all kind definitions.
Definition: kinds.f90:45
types::domain_lines_type
Contains the topology information for the lines of a domain.
Definition: types.f90:637
types::decomposition_element_type
Contains the information for an element in a decomposition.
Definition: types.f90:1004
cmiss_mpi::mpi_error_check
subroutine, public mpi_error_check(ROUTINE, MPI_ERR_CODE, ERR, ERROR,)
Checks to see if an MPI error has occured during an MPI call and flags a CMISS error it if it has...
Definition: cmiss_mpi.f90:84
input_output
This module handles all formating and input and output.
Definition: input_output.f90:45