OpenCMISS-Iron Internal API Documentation
node_routines.f90
Go to the documentation of this file.
1 
43 
45 MODULE node_routines
46 
47  USE base_routines
48  USE input_output
49  USE iso_varying_string
50  USE kinds
51  USE strings
52  USE trees
53  USE types
54 
55 #include "macros.h"
56 
57  IMPLICIT NONE
58 
59  PRIVATE
60 
61  !Module parameters
62 
63  !Module types
64 
65  !Module variables
66 
67  !Interfaces
68 
70  INTERFACE nodes_create_start
71  MODULE PROCEDURE nodes_create_start_region
72  MODULE PROCEDURE nodes_create_start_interface
73  END INTERFACE !NODES_CREATE_START
74 
76  INTERFACE nodes_initialise
77  MODULE PROCEDURE nodes_initialise_region
78  MODULE PROCEDURE nodes_initialise_interface
79  END INTERFACE !NODES_INITIALIES
80 
82  INTERFACE nodes_label_get
83  MODULE PROCEDURE nodes_label_get_c
84  MODULE PROCEDURE nodes_label_get_vs
85  END INTERFACE !NODES_LABEL_SET
86 
88  INTERFACE nodes_label_set
89  MODULE PROCEDURE nodes_label_set_c
90  MODULE PROCEDURE nodes_label_set_vs
91  END INTERFACE !NODES_LABEL_SET
92 
93  PUBLIC node_check_exists
94 
95  PUBLIC nodes_create_finish,nodes_create_start,nodes_destroy
96 
97  PUBLIC nodes_label_get,nodes_label_set
98 
99  PUBLIC nodes_number_of_nodes_get
100 
101  PUBLIC nodes_user_number_get,nodes_user_number_set
102 
103  PUBLIC nodesusernumbersallset
104 
105  !PUBLIC NODES_NUMBER_OF_VERSIONS_SET
106 
107 CONTAINS
108 
109  !
110  !================================================================================================================================
111  !
112 
114  SUBROUTINE node_check_exists(NODES,USER_NUMBER,NODE_EXISTS,GLOBAL_NUMBER,ERR,ERROR,*)
115 
116  !Argument variables
117  TYPE(nodes_type), POINTER :: nodes
118  INTEGER(INTG), INTENT(IN) :: user_number
119  LOGICAL, INTENT(OUT) :: node_exists
120  INTEGER(INTG), INTENT(OUT) :: global_number
121  INTEGER(INTG), INTENT(OUT) :: err
122  TYPE(varying_string), INTENT(OUT) :: error
123  !Local Variables
124  TYPE(tree_node_type), POINTER :: tree_node
125 
126  enters("NODE_CHECK_EXISTS",err,error,*999)
127 
128  node_exists=.false.
129  global_number=0
130  IF(ASSOCIATED(nodes)) THEN
131  NULLIFY(tree_node)
132  CALL tree_search(nodes%NODES_TREE,user_number,tree_node,err,error,*999)
133  IF(ASSOCIATED(tree_node)) THEN
134  CALL tree_node_value_get(nodes%NODES_TREE,tree_node,global_number,err,error,*999)
135  node_exists=.true.
136  ENDIF
137  ELSE
138  CALL flagerror("Nodes is not associated.",err,error,*999)
139  ENDIF
140 
141  exits("NODE_CHECK_EXISTS")
142  RETURN
143 999 errorsexits("NODE_CHECK_EXISTS",err,error)
144  RETURN 1
145  END SUBROUTINE node_check_exists
146 
147  !
148  !================================================================================================================================
149  !
150 
152  SUBROUTINE node_finalise(NODE,ERR,ERROR,*)
153 
154  !Argument variables
155  TYPE(node_type),INTENT(OUT) :: node
156  INTEGER(INTG), INTENT(OUT) :: err
157  TYPE(varying_string), INTENT(OUT) :: error
158  !Local Variables
159 
160  enters("NODE_FINALISE",err,error,*999)
161 
162  node%GLOBAL_NUMBER=0
163  node%USER_NUMBER=0
164  node%LABEL=""
165 
166  exits("NODE_FINALISE")
167  RETURN
168 999 errorsexits("NODE_FINALISE",err,error)
169  RETURN 1
170  END SUBROUTINE node_finalise
171 
172  !
173  !================================================================================================================================
174  !
175 
177  SUBROUTINE nodes_create_finish(NODES,ERR,ERROR,*)
178 
179  !Argument variables
180  TYPE(nodes_type), POINTER :: nodes
181  INTEGER(INTG), INTENT(OUT) :: err
182  TYPE(varying_string), INTENT(OUT) :: error
183  !Local Variables
184  INTEGER(INTG) :: np
185 
186  enters("NODES_CREATE_FINISH",err,error,*999)
187 
188  IF(ASSOCIATED(nodes)) THEN
189  IF(nodes%NODES_FINISHED) THEN
190  CALL flagerror("Nodes have already been finished.",err,error,*999)
191  ELSE
192  nodes%NODES_FINISHED=.true.
193  ENDIF
194  ELSE
195  CALL flagerror("Nodes is not associated.",err,error,*999)
196  ENDIF
197 
198  IF(diagnostics1) THEN
199  CALL write_string_value(diagnostic_output_type,"Number of nodes = ",nodes%NUMBER_OF_NODES,err,error,*999)
200  DO np=1,nodes%NUMBER_OF_NODES
201  CALL write_string_value(diagnostic_output_type," Node = ",np,err,error,*999)
202  CALL write_string_value(diagnostic_output_type," Global number = ",nodes%NODES(np)%GLOBAL_NUMBER, &
203  & err,error,*999)
204  CALL write_string_value(diagnostic_output_type," User number = ",nodes%NODES(np)%USER_NUMBER, &
205  & err,error,*999)
206  CALL write_string_value(diagnostic_output_type," Label = ",nodes%NODES(np)%LABEL, &
207  & err,error,*999)
208  ENDDO !np
209  CALL write_string(diagnostic_output_type,"User->Global number tree",err,error,*999)
210  CALL tree_output(diagnostic_output_type,nodes%NODES_TREE,err,error,*999)
211  ENDIF
212 
213  exits("NODES_CREATE_FINISH")
214  RETURN
215 999 errorsexits("NODES_CREATE_FINISH",err,error)
216  RETURN 1
217 
218  END SUBROUTINE nodes_create_finish
219 
220  !
221  !================================================================================================================================
222  !
223 
225  SUBROUTINE nodes_create_start_generic(NODES,NUMBER_OF_NODES,ERR,ERROR,*)
226 
227  !Argument variables
228  TYPE(nodes_type), POINTER :: nodes
229  INTEGER(INTG), INTENT(IN) :: number_of_nodes
230  INTEGER(INTG), INTENT(OUT) :: err
231  TYPE(varying_string), INTENT(OUT) :: error
232  !Local Variables
233  INTEGER(INTG) :: insert_status,np
234  TYPE(varying_string) :: local_error
235 
236  enters("NODES_CREATE_START_GENERIC",err,error,*999)
237 
238  IF(ASSOCIATED(nodes)) THEN
239  IF(number_of_nodes>0) THEN
240  ALLOCATE(nodes%NODES(number_of_nodes),stat=err)
241  IF(err/=0) CALL flagerror("Could not allocate nodes nodes.",err,error,*999)
242  nodes%NUMBER_OF_NODES=number_of_nodes
243  CALL tree_create_start(nodes%NODES_TREE,err,error,*999)
244  CALL tree_insert_type_set(nodes%NODES_TREE,tree_no_duplicates_allowed,err,error,*999)
245  CALL tree_create_finish(nodes%NODES_TREE,err,error,*999)
246  !Set default node numbers
247  DO np=1,nodes%NUMBER_OF_NODES
248  nodes%NODES(np)%GLOBAL_NUMBER=np
249  nodes%NODES(np)%USER_NUMBER=np
250  nodes%NODES(np)%LABEL=""
251  CALL tree_item_insert(nodes%NODES_TREE,np,np,insert_status,err,error,*999)
252  ENDDO !np
253  ELSE
254  local_error="The specified number of nodes of "//trim(number_to_vstring(number_of_nodes,"*",err,error))// &
255  & " is invalid. The number of nodes must be > 0."
256  CALL flagerror(local_error,err,error,*999)
257  ENDIF
258  ELSE
259  CALL flagerror("Nodes is not associated.",err,error,*999)
260  ENDIF
261 
262  exits("NODES_CREATE_GENERIC")
263  RETURN
264 999 errorsexits("NODES_CREATE_START_GENERIC",err,error)
265  RETURN 1
266 
267  END SUBROUTINE nodes_create_start_generic
268 
269  !
270  !================================================================================================================================
271  !
272 
274  SUBROUTINE nodes_create_start_interface(INTERFACE,NUMBER_OF_NODES,NODES,ERR,ERROR,*)
275 
276  !Argument variables
277  TYPE(interface_type), POINTER :: interface
278  INTEGER(INTG), INTENT(IN) :: number_of_nodes
279  TYPE(nodes_type), POINTER :: nodes
280  INTEGER(INTG), INTENT(OUT) :: err
281  TYPE(varying_string), INTENT(OUT) :: error
282  !Local Variables
283  INTEGER(INTG) :: dummy_err
284  TYPE(varying_string) :: dummy_error
285 
286  enters("NODES_CREATE_START_INTERFACE",err,error,*998)
287 
288  IF(ASSOCIATED(interface)) THEN
289  IF(ASSOCIATED(nodes)) THEN
290  CALL flagerror("Nodes is already associated.",err,error,*999)
291  ELSE
292  IF(ASSOCIATED(interface%NODES)) THEN
293  CALL flagerror("Interface already has nodes associated.",err,error,*998)
294  ELSE
295  !Initialise the nodes for the interface
296  CALL nodes_initialise(interface,err,error,*999)
297  !Create the nodes
298  CALL nodes_create_start_generic(interface%NODES,number_of_nodes,err,error,*999)
299  !Return the pointer
300  nodes=>interface%NODES
301  ENDIF
302  ENDIF
303  ELSE
304  CALL flagerror("Interface is not associated.",err,error,*998)
305  ENDIF
306 
307  exits("NODES_CREATE_START_INTERFACE")
308  RETURN
309 999 CALL nodes_finalise(interface%NODES,dummy_err,dummy_error,*998)
310 998 errorsexits("NODES_CREATE_START_INTERFACE",err,error)
311  RETURN 1
312 
313  END SUBROUTINE nodes_create_start_interface
314 
315  !
316  !================================================================================================================================
317  !
318 
320  SUBROUTINE nodes_create_start_region(REGION,NUMBER_OF_NODES,NODES,ERR,ERROR,*)
321 
322  !Argument variables
323  TYPE(region_type), POINTER :: region
324  INTEGER(INTG), INTENT(IN) :: number_of_nodes
325  TYPE(nodes_type), POINTER :: nodes
326  INTEGER(INTG), INTENT(OUT) :: err
327  TYPE(varying_string), INTENT(OUT) :: error
328  !Local Variables
329  INTEGER(INTG) :: dummy_err
330  TYPE(varying_string) :: dummy_error
331 
332  enters("NODES_CREATE_START_REGION",err,error,*998)
333 
334  NULLIFY(nodes)
335  IF(ASSOCIATED(region)) THEN
336  IF(ASSOCIATED(region%NODES)) THEN
337  CALL flagerror("Region already has nodes associated.",err,error,*998)
338  ELSE
339  IF(ASSOCIATED(nodes)) THEN
340  CALL flagerror("Nodes is already associated.",err,error,*998)
341  ELSE
342  !Initialise the nodes for the region
343  CALL nodes_initialise(region,err,error,*999)
344  !Create the generic nodes
345  CALL nodes_create_start_generic(region%NODES,number_of_nodes,err,error,*999)
346  !Return the pointer
347  nodes=>region%NODES
348  ENDIF
349  ENDIF
350  ELSE
351  CALL flagerror("Region is not associated.",err,error,*998)
352  ENDIF
353 
354  exits("NODES_CREATE_START_REGION")
355  RETURN
356 999 CALL nodes_finalise(region%NODES,dummy_err,dummy_error,*998)
357 998 errorsexits("NODES_CREATE_START_REGION",err,error)
358  RETURN 1
359 
360  END SUBROUTINE nodes_create_start_region
361 
362  !
363  !================================================================================================================================
364  !
365 
367  SUBROUTINE nodes_destroy(NODES,ERR,ERROR,*)
368 
369  !Argument variables
370  TYPE(nodes_type), POINTER :: nodes
371  INTEGER(INTG), INTENT(OUT) :: err
372  TYPE(varying_string), INTENT(OUT) :: error
373  !Local Variables
374 
375  enters("NODES_DESTROY",err,error,*999)
376 
377  IF(ASSOCIATED(nodes)) THEN
378  IF(ASSOCIATED(nodes%REGION)) THEN
379  NULLIFY(nodes%REGION%NODES)
380  ELSE
381  IF(ASSOCIATED(nodes%INTERFACE)) THEN
382  NULLIFY(nodes%INTERFACE%NODES)
383  ELSE
384  CALL flagerror("Nodes region and interface are not associated.",err,error,*999)
385  ENDIF
386  ENDIF
387  CALL nodes_finalise(nodes,err,error,*999)
388  ELSE
389  CALL flagerror("Nodes is not associated.",err,error,*999)
390  ENDIF
391 
392  exits("NODES_DESTROY")
393  RETURN
394 999 errorsexits("NODES_DESTROY",err,error)
395  RETURN 1
396 
397  END SUBROUTINE nodes_destroy
398 
399  !
400  !===============================================================================================================================
401  !
402 
404  SUBROUTINE nodes_finalise(NODES,ERR,ERROR,*)
405 
406  !Argument variables
407  TYPE(nodes_type), POINTER :: nodes
408  INTEGER(INTG), INTENT(OUT) :: err
409  TYPE(varying_string), INTENT(OUT) :: error
410  !Local Variables
411  INTEGER(INTG) :: np
412 
413  enters("NODES_FINALISE",err,error,*999)
414 
415  IF(ASSOCIATED(nodes)) THEN
416  IF(ALLOCATED(nodes%NODES)) THEN
417  DO np=1,SIZE(nodes%NODES,1)
418  CALL node_finalise(nodes%NODES(np),err,error,*999)
419  ENDDO !np
420  DEALLOCATE(nodes%NODES)
421  ENDIF
422  IF(ASSOCIATED(nodes%NODES_TREE)) CALL tree_destroy(nodes%NODES_TREE,err,error,*999)
423  DEALLOCATE(nodes)
424  ENDIF
425 
426  exits("NODES_FINALISE")
427  RETURN
428 999 errorsexits("NODES_FINALISE",err,error)
429  RETURN 1
430  END SUBROUTINE nodes_finalise
431 
432  !
433  !================================================================================================================================
434  !
435 
437  SUBROUTINE nodes_initialise_generic(NODES,ERR,ERROR,*)
438 
439  !Argument variables
440  TYPE(nodes_type), POINTER :: nodes
441  INTEGER(INTG), INTENT(OUT) :: err
442  TYPE(varying_string), INTENT(OUT) :: error
443  !Local Variables
444 
445  enters("NODES_INITIALISE_GENERIC",err,error,*999)
446 
447  IF(ASSOCIATED(nodes)) THEN
448  NULLIFY(nodes%REGION)
449  NULLIFY(nodes%INTERFACE)
450  nodes%NODES_FINISHED=.false.
451  nodes%NUMBER_OF_NODES=0
452  NULLIFY(nodes%NODES_TREE)
453  ELSE
454  CALL flagerror("Nodes is not associated.",err,error,*999)
455  ENDIF
456 
457  exits("NODES_INITIALISE_GENERIC")
458  RETURN
459 999 errorsexits("NODES_INITIALISE_GENERIC",err,error)
460  RETURN 1
461  END SUBROUTINE nodes_initialise_generic
462 
463  !
464  !================================================================================================================================
465  !
466 
468  SUBROUTINE nodes_initialise_interface(INTERFACE,ERR,ERROR,*)
469 
470  !Argument variables
471  TYPE(interface_type), POINTER :: interface
472  INTEGER(INTG), INTENT(OUT) :: err
473  TYPE(varying_string), INTENT(OUT) :: error
474  !Local Variables
475 
476  enters("NODES_INITIALISE_INTERFACE",err,error,*999)
477 
478  IF(ASSOCIATED(interface)) THEN
479  IF(ASSOCIATED(interface%NODES)) THEN
480  CALL flagerror("Interface already has associated nodes.",err,error,*999)
481  ELSE
482  ALLOCATE(interface%NODES,stat=err)
483  IF(err/=0) CALL flagerror("Could not allocate interface nodes.",err,error,*999)
484  CALL nodes_initialise_generic(interface%NODES,err,error,*999)
485  interface%NODES%INTERFACE=>INTERFACE
486  ENDIF
487  ELSE
488  CALL flagerror("Interface is not associated.",err,error,*999)
489  ENDIF
490 
491  exits("NODES_INITIALISE_INTERFACE")
492  RETURN
493 999 errorsexits("NODES_INITIALISE_INTERFACE",err,error)
494  RETURN 1
495 
496  END SUBROUTINE nodes_initialise_interface
497 
498  !
499  !================================================================================================================================
500  !
501 
503  SUBROUTINE nodes_initialise_region(REGION,ERR,ERROR,*)
504 
505  !Argument variables
506  TYPE(region_type), POINTER :: region
507  INTEGER(INTG), INTENT(OUT) :: err
508  TYPE(varying_string), INTENT(OUT) :: error
509  !Local Variables
510 
511  enters("NODES_INITIALISE_REGION",err,error,*999)
512 
513  IF(ASSOCIATED(region)) THEN
514  IF(ASSOCIATED(region%NODES)) THEN
515  CALL flagerror("Region has associated nodes.",err,error,*999)
516  ELSE
517  ALLOCATE(region%NODES,stat=err)
518  IF(err/=0) CALL flagerror("Could not allocate region nodes.",err,error,*999)
519  CALL nodes_initialise_generic(region%NODES,err,error,*999)
520  region%NODES%REGION=>region
521  ENDIF
522  ELSE
523  CALL flagerror("Region is not associated.",err,error,*999)
524  ENDIF
525 
526  exits("NODES_INITIALISE_REGION")
527  RETURN
528 999 errorsexits("NODES_INITIALISE_REGION",err,error)
529  RETURN 1
530  END SUBROUTINE nodes_initialise_region
531 
532  !
533  !================================================================================================================================
534  !
535 
537  SUBROUTINE nodes_label_get_c(NODES,GLOBAL_NUMBER,LABEL,ERR,ERROR,*)
538 
539  !Argument variables
540  TYPE(nodes_type), POINTER :: nodes
541  INTEGER(INTG), INTENT(IN) :: global_number
542  CHARACTER(LEN=*), INTENT(OUT) :: label
543  INTEGER(INTG), INTENT(OUT) :: err
544  TYPE(varying_string), INTENT(OUT) :: error
545  !Local Variables
546  INTEGER :: c_length,vs_length
547  TYPE(varying_string) :: local_error
548 
549  enters("NODES_LABEL_GET_C",err,error,*999)
550 
551  IF(ASSOCIATED(nodes)) THEN
552  IF(nodes%NODES_FINISHED) THEN
553  IF(global_number>=1.AND.global_number<=nodes%NUMBER_OF_NODES) THEN
554  c_length=len(label)
555  vs_length=len_trim(nodes%NODES(global_number)%LABEL)
556  IF(c_length>vs_length) THEN
557  label=char(len_trim(nodes%NODES(global_number)%LABEL))
558  ELSE
559  label=char(nodes%NODES(global_number)%LABEL,c_length)
560  ENDIF
561  ELSE
562  local_error="The specified global node number of "//trim(number_to_vstring(global_number,"*",err,error))// &
563  & " is invalid. The global node number should be between 1 and "// &
564  & trim(number_to_vstring(nodes%NUMBER_OF_NODES,"*",err,error))//"."
565  CALL flagerror(local_error,err,error,*999)
566  ENDIF
567  ELSE
568  CALL flagerror("Nodes have not been finished.",err,error,*999)
569  ENDIF
570  ELSE
571  CALL flagerror("Nodes is not associated.",err,error,*999)
572  ENDIF
573 
574  exits("NODES_LABEL_GET_C")
575  RETURN
576 999 errorsexits("NODES_LABEL_GET_C",err,error)
577  RETURN 1
578 
579  END SUBROUTINE nodes_label_get_c
580 
581  !
582  !================================================================================================================================
583  !
584 
586  SUBROUTINE nodes_label_get_vs(NODES,GLOBAL_NUMBER,LABEL,ERR,ERROR,*)
587 
588  !Argument variables
589  TYPE(nodes_type), POINTER :: nodes
590  INTEGER(INTG), INTENT(IN) :: global_number
591  TYPE(varying_string), INTENT(OUT) :: label
592  INTEGER(INTG), INTENT(OUT) :: err
593  TYPE(varying_string), INTENT(OUT) :: error
594  !Local Variables
595  TYPE(varying_string) :: local_error
596 
597  enters("NODES_LABEL_GET_VS",err,error,*999)
598 
599  IF(ASSOCIATED(nodes)) THEN
600  IF(nodes%NODES_FINISHED) THEN
601  IF(global_number>=1.AND.global_number<=nodes%NUMBER_OF_NODES) THEN
602  label=nodes%NODES(global_number)%LABEL
603  ELSE
604  local_error="The specified global node number of "//trim(number_to_vstring(global_number,"*",err,error))// &
605  & " is invalid. The global node number should be between 1 and "// &
606  & trim(number_to_vstring(nodes%NUMBER_OF_NODES,"*",err,error))//"."
607  CALL flagerror(local_error,err,error,*999)
608  ENDIF
609  ELSE
610  CALL flagerror("Nodes have not been finished.",err,error,*999)
611  ENDIF
612  ELSE
613  CALL flagerror("Nodes is not associated.",err,error,*999)
614  ENDIF
615 
616  exits("NODES_LABEL_GET_VS")
617  RETURN
618 999 errorsexits("NODES_LABEL_GET_VS",err,error)
619  RETURN 1
620 
621  END SUBROUTINE nodes_label_get_vs
622 
623  !
624  !================================================================================================================================
625  !
626 
628  SUBROUTINE nodes_label_set_c(NODES,GLOBAL_NUMBER,LABEL,ERR,ERROR,*)
629 
630  !Argument variables
631  TYPE(nodes_type), POINTER :: nodes
632  INTEGER(INTG), INTENT(IN) :: global_number
633  CHARACTER(LEN=*), INTENT(IN) :: label
634  INTEGER(INTG), INTENT(OUT) :: err
635  TYPE(varying_string), INTENT(OUT) :: error
636  !Local Variables
637  TYPE(varying_string) :: local_error
638 
639  enters("NODES_LABEL_SET_C",err,error,*999)
640 
641  IF(ASSOCIATED(nodes)) THEN
642  IF(nodes%NODES_FINISHED) THEN
643  CALL flagerror("Nodes have been finished.",err,error,*999)
644  ELSE
645  IF(global_number>=1.AND.global_number<=nodes%NUMBER_OF_NODES) THEN
646  nodes%NODES(global_number)%LABEL=label
647  ELSE
648  local_error="The specified global node number of "//trim(number_to_vstring(global_number,"*",err,error))// &
649  & " is invalid. The global node number should be between 1 and "// &
650  & trim(number_to_vstring(nodes%NUMBER_OF_NODES,"*",err,error))//"."
651  CALL flagerror(local_error,err,error,*999)
652  ENDIF
653  ENDIF
654  ELSE
655  CALL flagerror("Nodes is not associated.",err,error,*999)
656  ENDIF
657 
658  exits("NODES_LABEL_SET_C")
659  RETURN
660 999 errorsexits("NODES_LABEL_SET_C",err,error)
661  RETURN 1
662 
663  END SUBROUTINE nodes_label_set_c
664 
665  !
666  !================================================================================================================================
667  !
668 
670  SUBROUTINE nodes_label_set_vs(NODES,GLOBAL_NUMBER,LABEL,ERR,ERROR,*)
671 
672  !Argument variables
673  TYPE(nodes_type), POINTER :: nodes
674  INTEGER(INTG), INTENT(IN) :: global_number
675  TYPE(varying_string), INTENT(IN) :: label
676  INTEGER(INTG), INTENT(OUT) :: err
677  TYPE(varying_string), INTENT(OUT) :: error
678  !Local Variables
679  TYPE(varying_string) :: local_error
680 
681  enters("NODES_LABEL_SET_VS",err,error,*999)
682 
683  IF(ASSOCIATED(nodes)) THEN
684  IF(nodes%NODES_FINISHED) THEN
685  CALL flagerror("Nodes have been finished.",err,error,*999)
686  ELSE
687  IF(global_number>=1.AND.global_number<=nodes%NUMBER_OF_NODES) THEN
688  nodes%NODES(global_number)%LABEL=label
689  ELSE
690  local_error="The specified global node number of "//trim(number_to_vstring(global_number,"*",err,error))// &
691  & " is invalid. The global node number should be between 1 and "// &
692  & trim(number_to_vstring(nodes%NUMBER_OF_NODES,"*",err,error))//"."
693  CALL flagerror(local_error,err,error,*999)
694  ENDIF
695  ENDIF
696  ELSE
697  CALL flagerror("Nodes is not associated.",err,error,*999)
698  ENDIF
699 
700  exits("NODES_LABEL_SET_VS")
701  RETURN
702 999 errorsexits("NODES_LABEL_SET_VS",err,error)
703  RETURN 1
704 
705  END SUBROUTINE nodes_label_set_vs
706 
707  !
708  !================================================================================================================================
709  !
710 
712  SUBROUTINE nodes_number_of_nodes_get(NODES,NUMBER_OF_NODES,ERR,ERROR,*)
713 
714  !Argument variables
715  TYPE(nodes_type), POINTER :: nodes
716  INTEGER(INTG), INTENT(OUT) :: number_of_nodes
717  INTEGER(INTG), INTENT(OUT) :: err
718  TYPE(varying_string), INTENT(OUT) :: error
719  !Local Variables
720 
721  enters("NODES_NUMBER_OF_NODES_GET",err,error,*999)
722 
723  IF(ASSOCIATED(nodes)) THEN
724  IF(nodes%NODES_FINISHED) THEN
725  number_of_nodes=nodes%NUMBER_OF_NODES
726  ELSE
727  CALL flagerror("Nodes have not been finished.",err,error,*999)
728  ENDIF
729  ELSE
730  CALL flagerror("Nodes is not associated.",err,error,*999)
731  ENDIF
732 
733  exits("NODES_NUMBER_OF_NODES_GET")
734  RETURN
735 999 errorsexits("NODES_NUMBER_OF_NODES_GET",err,error)
736  RETURN 1
737 
738  END SUBROUTINE nodes_number_of_nodes_get
739 
740  !
741  !================================================================================================================================
742  !
743 
745  SUBROUTINE nodes_user_number_get(NODES,GLOBAL_NUMBER,USER_NUMBER,ERR,ERROR,*)
746 
747  !Argument variables
748  TYPE(nodes_type), POINTER :: nodes
749  INTEGER(INTG), INTENT(IN) :: global_number
750  INTEGER(INTG), INTENT(OUT) :: user_number
751  INTEGER(INTG), INTENT(OUT) :: err
752  TYPE(varying_string), INTENT(OUT) :: error
753  !Local Variables
754  TYPE(varying_string) :: local_error
755 
756  enters("NODES_USER_NUMBER_GET",err,error,*999)
757 
758  IF(ASSOCIATED(nodes)) THEN
759  IF(nodes%NODES_FINISHED) THEN
760  IF(global_number>=1.AND.global_number<=nodes%NUMBER_OF_NODES) THEN
761  user_number=nodes%NODES(global_number)%USER_NUMBER
762  ELSE
763  local_error="The specified global node number of "//trim(number_to_vstring(global_number,"*",err,error))// &
764  & " is invalid. The global node number should be between 1 and "// &
765  & trim(number_to_vstring(nodes%NUMBER_OF_NODES,"*",err,error))//"."
766  CALL flagerror(local_error,err,error,*999)
767  ENDIF
768  ELSE
769  CALL flagerror("Nodes have not been finished.",err,error,*999)
770  ENDIF
771  ELSE
772  CALL flagerror("Nodes is not associated.",err,error,*999)
773  ENDIF
774 
775  exits("NODES_USER_NUMBER_GET")
776  RETURN
777 999 errorsexits("NODES_USER_NUMBER_GET",err,error)
778  RETURN 1
779 
780  END SUBROUTINE nodes_user_number_get
781 
782  !
783  !================================================================================================================================
784  !
785 
787  SUBROUTINE nodes_user_number_set(NODES,GLOBAL_NUMBER,USER_NUMBER,ERR,ERROR,*)
788 
789  !Argument variables
790  TYPE(nodes_type), POINTER :: nodes
791  INTEGER(INTG), INTENT(IN) :: global_number
792  INTEGER(INTG), INTENT(IN) :: user_number
793  INTEGER(INTG), INTENT(OUT) :: err
794  TYPE(varying_string), INTENT(OUT) :: error
795  !Local Variables
796  INTEGER(INTG) :: insert_status,old_global_number
797  LOGICAL :: node_exists
798  TYPE(varying_string) :: local_error
799 
800  enters("NODES_USER_NUMBER_SET",err,error,*999)
801 
802  IF(ASSOCIATED(nodes)) THEN
803  IF(nodes%NODES_FINISHED) THEN
804  CALL flagerror("Nodes have been finished.",err,error,*999)
805  ELSE
806  IF(global_number>=1.AND.global_number<=nodes%NUMBER_OF_NODES) THEN
807  !Check the node user number is not already used
808  CALL node_check_exists(nodes,user_number,node_exists,old_global_number,err,error,*999)
809  IF(node_exists) THEN
810  IF(old_global_number/=global_number) THEN
811  local_error="The specified node user number of "//trim(number_to_vstring(user_number,"*",err,error))// &
812  & " is already used by global node number "//trim(number_to_vstring(old_global_number,"*",err,error))// &
813  & ". User node numbers must be unique."
814  CALL flagerror(local_error,err,error,*999)
815  ENDIF
816  ELSE
817  CALL tree_item_delete(nodes%NODES_TREE,nodes%NODES(global_number)%USER_NUMBER,err,error,*999)
818  CALL tree_item_insert(nodes%NODES_TREE,user_number,global_number,insert_status,err,error,*999)
819  IF(insert_status/=tree_node_insert_sucessful) CALL flagerror("Unsucessful nodes tree insert.",err,error,*999)
820  nodes%NODES(global_number)%USER_NUMBER=user_number
821  ENDIF
822  ELSE
823  local_error="The specified global node number of "//trim(number_to_vstring(global_number,"*",err,error))// &
824  & " is invalid. The global node number should be between 1 and "// &
825  & trim(number_to_vstring(nodes%NUMBER_OF_NODES,"*",err,error))//"."
826  CALL flagerror(local_error,err,error,*999)
827  ENDIF
828  ENDIF
829  ELSE
830  CALL flagerror("Nodes is not associated.",err,error,*999)
831  ENDIF
832 
833  exits("NODE_USER_NUMBER_SET")
834  RETURN
835 999 errorsexits("NODE_USER_NUMBER_SET",err,error)
836  RETURN 1
837 
838  END SUBROUTINE nodes_user_number_set
839 
840  !
841  !================================================================================================================================
842  !
843 
845  SUBROUTINE nodesusernumbersallset(nodes,userNumbers,err,error,*)
846 
847  !Argument variables
848  TYPE(nodes_type), POINTER :: nodes
849  INTEGER(INTG), INTENT(IN) :: usernumbers(:)
850  INTEGER(INTG), INTENT(OUT) :: err
851  TYPE(varying_string), INTENT(OUT) :: error
852  !Local Variables
853  INTEGER(INTG) :: nodeidx,insertstatus
854  TYPE(tree_type), POINTER :: newnodestree
855  TYPE(varying_string) :: localerror
856 
857  NULLIFY(newnodestree)
858 
859  enters("NodesUserNumbersAllSet",err,error,*999)
860 
861  IF(ASSOCIATED(nodes)) THEN
862  IF(nodes%NODES_FINISHED) THEN
863  CALL flagerror("Nodes have been finished.",err,error,*999)
864  ELSE
865  IF(nodes%NUMBER_OF_NODES==SIZE(usernumbers,1)) THEN
866  !Check the users numbers to ensure that there are no duplicates
867  CALL tree_create_start(newnodestree,err,error,*999)
868  CALL tree_insert_type_set(newnodestree,tree_no_duplicates_allowed,err,error,*999)
869  CALL tree_create_finish(newnodestree,err,error,*999)
870  DO nodeidx=1,nodes%NUMBER_OF_NODES
871  CALL tree_item_insert(newnodestree,usernumbers(nodeidx),nodeidx,insertstatus,err,error,*999)
872  IF(insertstatus/=tree_node_insert_sucessful) THEN
873  localerror="The specified user number of "//trim(numbertovstring(usernumbers(nodeidx),"*",err,error))// &
874  & " for global node number "//trim(numbertovstring(nodeidx,"*",err,error))// &
875  & " is a duplicate. The user node numbers must be unique."
876  CALL flagerror(localerror,err,error,*999)
877  ENDIF
878  ENDDO !nodeIdx
879  CALL tree_destroy(nodes%NODES_TREE,err,error,*999)
880  nodes%NODES_TREE=>newnodestree
881  NULLIFY(newnodestree)
882  DO nodeidx=1,nodes%NUMBER_OF_NODES
883  nodes%NODES(nodeidx)%GLOBAL_NUMBER=nodeidx
884  nodes%NODES(nodeidx)%USER_NUMBER=usernumbers(nodeidx)
885  ENDDO !nodesIdx
886  ELSE
887  localerror="The number of specified node user numbers ("// &
888  trim(numbertovstring(SIZE(usernumbers,1),"*",err,error))// &
889  ") does not match number of nodes ("// &
890  trim(numbertovstring(nodes%NUMBER_OF_NODES,"*",err,error))//")."
891  CALL flagerror(localerror,err,error,*999)
892  ENDIF
893  ENDIF
894  ELSE
895  CALL flagerror("Nodes is not associated.",err,error,*999)
896  ENDIF
897 
898  exits("NodesUserNumbersAllSet")
899  RETURN
900 999 IF(ASSOCIATED(newnodestree)) CALL tree_destroy(newnodestree,err,error,*998)
901 998 errorsexits("NodesUserNumbersAllSet",err,error)
902  RETURN 1
903 
904  END SUBROUTINE nodesusernumbersallset
905 
906  !
907  !================================================================================================================================
908  !
909 
910 END MODULE node_routines
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
types::region_type
Contains information for a region.
Definition: types.f90:3252
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
trees::tree_node_insert_sucessful
integer(intg), parameter, public tree_node_insert_sucessful
Successful insert status.
Definition: trees.f90:73
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::node_type
Contains information about a node.
Definition: types.f90:352
trees::tree_node_type
Definition: trees.f90:87
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
trees::tree_output
subroutine, public tree_output(ID, TREE, ERR, ERROR,)
Outputs a tree to the specified output stream ID.
Definition: trees.f90:1133
iso_varying_string::varying_string
Definition: iso_varying_string.f90:75
iso_varying_string::len
Definition: iso_varying_string.f90:162
base_routines::exits
subroutine, public exits(NAME)
Records the exit out of the named procedure.
Definition: base_routines.f90:504
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
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
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
iso_varying_string::trim
Definition: iso_varying_string.f90:204
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
trees::tree_no_duplicates_allowed
integer(intg), parameter, public tree_no_duplicates_allowed
No duplicate keys allowed tree type.
Definition: trees.f90:82
base_routines::diagnostics1
logical, save, public diagnostics1
.TRUE. if level 1 diagnostic output is active in the current routine
Definition: base_routines.f90:153
trees::tree_destroy
subroutine, public tree_destroy(TREE, ERR, ERROR,)
Destroys a tree.
Definition: trees.f90:265
iso_varying_string::char
Definition: iso_varying_string.f90:138
iso_varying_string::len_trim
Definition: iso_varying_string.f90:166
base_routines::diagnostic_output_type
integer(intg), parameter, public diagnostic_output_type
Diagnostic output type.
Definition: base_routines.f90:67
types::nodes_type
Contains information on the nodes defined on a region.
Definition: types.f90:359
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
types::interface_type
Contains information for the interface data.
Definition: types.f90:2228
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
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
kinds
This module contains all kind definitions.
Definition: kinds.f90:45
input_output
This module handles all formating and input and output.
Definition: input_output.f90:45