OpenCMISS-Iron Internal API Documentation
field_IO_routines.f90
Go to the documentation of this file.
1 
44 
47  USE base_routines
48  USE lists
49  USE basis_routines
50  USE mesh_routines
51  USE node_routines
56  USE kinds
57  USE field_routines
59  !USE, INTRINSIC :: ISO_C_BINDING
60  USE strings
61  USE types
62  USE constants
63 #ifndef NOMPIMOD
64  USE mpi
65 #endif
66  USE cmiss_mpi
67  USE input_output
69 
70 #include "macros.h"
71 
72  IMPLICIT NONE
73 
74 #ifdef NOMPIMOD
75 #include "mpif.h"
76 #endif
77 #include "FieldExportConstants.h"
78 
79  PRIVATE
80 
81  !Module parameters
82 
84  INTEGER(INTG), PARAMETER :: shape_size=3
85 
87  INTEGER(INTG), PARAMETER :: field_io_field_label=1
88  INTEGER(INTG), PARAMETER :: field_io_variable_label=2
89  INTEGER(INTG), PARAMETER :: field_io_component_label=3
90  INTEGER(INTG), PARAMETER :: field_io_derivative_label=4
91 
93  INTEGER(INTG), PARAMETER :: field_io_scale_factors_number_type=5
94  INTEGER(INTG), PARAMETER :: field_io_scale_factors_property_type=6
95 
96  !Module types
97 
100  TYPE(meshelementstype), POINTER :: ptr
102 
107 
110  LOGICAL :: same_header
111  INTEGER(INTG) :: number_of_components
112  !attention: the pointers in COMPONENTS(:) point to those nodal components which are in the same local domain in current implementation
113  !it may be replaced in the future implementation
114  TYPE(field_variable_component_ptr_type), ALLOCATABLE:: components(:)
115  INTEGER(INTG), ALLOCATABLE:: component_versions(:)
117 
121 
124  TYPE(fields_type), POINTER :: fields
125  INTEGER(INTG) :: number_of_entries
126  !Interesting thing: pointer here, also means dymanically allocated attibute
127  INTEGER(INTG), ALLOCATABLE:: list_of_global_number(:)
128  TYPE(field_io_component_info_set_ptr_type), ALLOCATABLE:: component_info_set(:)
129  END TYPE field_io_info_set
130 
131  !Module variables
132 
133  !Interfaces
134  INTERFACE
135  FUNCTION fieldexport_opensession( exportType, filename, handle ) &
136  & bind(c,name="FieldExport_OpenSession")
137  USE types
138  USE iso_c_binding
139  INTEGER(C_INT), VALUE :: exportType
140  CHARACTER(C_CHAR), INTENT(IN) :: filename(*)
141  INTEGER(C_INT), INTENT(OUT) :: handle
142  INTEGER(C_INT) :: FieldExport_OpenSession
143  END FUNCTION fieldexport_opensession
144 
145  FUNCTION fieldexport_group( handle, groupName ) &
146  & bind(c,name="FieldExport_Group")
147  USE types
148  USE iso_c_binding
149  INTEGER(C_INT), VALUE :: handle
150  CHARACTER(C_CHAR), INTENT(IN) :: groupName(*)
151  INTEGER(C_INT) :: FieldExport_Group
152  END FUNCTION fieldexport_group
153 
154  FUNCTION fieldexport_meshdimensions( handle, meshDimensions , basisType) &
155  & bind(c,name="FieldExport_MeshDimensions")
156  USE types
157  USE iso_c_binding
158  INTEGER(C_INT), VALUE :: handle
159  INTEGER(C_INT), VALUE :: meshDimensions
160  INTEGER(C_INT), VALUE :: basisType
161  INTEGER(C_INT) :: FieldExport_MeshDimensions
162  END FUNCTION fieldexport_meshdimensions
163 
164  FUNCTION fieldexport_scalingfactorcount( handle, scalingFactorCount ) &
165  & bind(c,name="FieldExport_ScalingFactorCount")
166  USE types
167  USE iso_c_binding
168  INTEGER(C_INT), VALUE :: handle
169  INTEGER(C_INT), VALUE :: scalingFactorCount
170  INTEGER(C_INT) :: FieldExport_ScalingFactorCount
171  END FUNCTION fieldexport_scalingfactorcount
172 
173  FUNCTION fieldexport_scalefactors( handle, numberOfXi, interpolationXi, numberOfScaleFactors ) &
174  & bind(c,name="FieldExport_ScaleFactors")
175  USE types
176  USE iso_c_binding
177  INTEGER(C_INT), VALUE :: handle
178  INTEGER(C_INT), VALUE :: numberOfXi
179  TYPE(c_ptr), VALUE :: interpolationXi
180  INTEGER(C_INT), VALUE :: numberOfScaleFactors
181  INTEGER(C_INT) :: FieldExport_ScaleFactors
182  END FUNCTION fieldexport_scalefactors
183 
184  FUNCTION fieldexport_nodecount( handle, nodeCount ) &
185  & bind(c,name="FieldExport_NodeCount")
186  USE types
187  USE iso_c_binding
188  INTEGER(C_INT), VALUE :: handle
189  INTEGER(C_INT), VALUE :: nodeCount
190  INTEGER(C_INT) :: FieldExport_NodeCount
191  END FUNCTION fieldexport_nodecount
192 
193  FUNCTION fieldexport_fieldcount( handle, fieldCount ) &
194  & bind(c,name="FieldExport_FieldCount")
195  USE types
196  USE iso_c_binding
197  INTEGER(C_INT), VALUE :: handle
198  INTEGER(C_INT), VALUE :: fieldCount
199  INTEGER(C_INT) :: FieldExport_FieldCount
200  END FUNCTION fieldexport_fieldcount
201 
202  FUNCTION fieldexport_coordinatevariable( handle, variableName, variableNumber, coordinateSystemType, componentCount ) &
203  & bind(c,name="FieldExport_CoordinateVariable")
204  USE types
205  USE iso_c_binding
206  INTEGER(C_INT), VALUE :: handle
207  CHARACTER(LEN=1, KIND=C_CHAR) :: variableName(*)
208  INTEGER(C_INT), VALUE :: variableNumber
209  INTEGER(C_INT), VALUE :: coordinateSystemType
210  INTEGER(C_INT), VALUE :: componentCount
211  INTEGER(C_INT) :: FieldExport_CoordinateVariable
212  END FUNCTION fieldexport_coordinatevariable
213 
214  FUNCTION fieldexport_variable( handle, variableName, variableNumber, fieldType, variableType, componentCount ) &
215  & bind(c,name="FieldExport_Variable")
216  USE types
217  USE iso_c_binding
218  INTEGER(C_INT), VALUE :: handle
219  CHARACTER(LEN=1, KIND=C_CHAR) :: variableName(*)
220  INTEGER(C_INT), VALUE :: variableNumber
221  INTEGER(C_INT), VALUE :: fieldType
222  INTEGER(C_INT), VALUE :: variableType
223  INTEGER(C_INT), VALUE :: componentCount
224  INTEGER(C_INT) :: FieldExport_Variable
225  END FUNCTION fieldexport_variable
226 
227  FUNCTION fieldexport_coordinatecomponent( handle, coordinateSystemType, componentNumber, interpType, &
228  & numberofxi, interpolationxi ) &
229  & bind(c,name="FieldExport_CoordinateComponent")
230  USE types
231  USE iso_c_binding
232  INTEGER(C_INT), VALUE :: handle
233  INTEGER(C_INT), VALUE :: coordinateSystemType
234  INTEGER(C_INT), VALUE :: componentNumber
235  INTEGER(C_INT), VALUE :: interpType
236  INTEGER(C_INT), VALUE :: numberOfXi
237  TYPE(c_ptr), VALUE :: interpolationXi
238  INTEGER(C_INT) :: FieldExport_CoordinateComponent
240 
241  FUNCTION fieldexport_component( handle, componentNumber, interpType, numberOfXi, interpolationXi ) &
242  & bind(c,name="FieldExport_Component")
243  USE types
244  USE iso_c_binding
245  INTEGER(C_INT), VALUE :: handle
246  INTEGER(C_INT), VALUE :: componentNumber
247  INTEGER(C_INT), VALUE :: interpType
248  INTEGER(C_INT), VALUE :: numberOfXi
249  TYPE(c_ptr), VALUE :: interpolationXi
250  INTEGER(C_INT) :: FieldExport_Component
251  END FUNCTION fieldexport_component
252 
253  FUNCTION fieldexport_elementgridsize( handle, headerType, numberOfXi, numberGauss ) &
254  & bind(c,name="FieldExport_ElementGridSize")
255  USE types
256  USE iso_c_binding
257  INTEGER(C_INT), VALUE :: handle
258  INTEGER(C_INT), VALUE :: headerType
259  INTEGER(C_INT), VALUE :: numberOfXi
260  TYPE(c_ptr), VALUE :: numberGauss
261  INTEGER(C_INT) :: FieldExport_ElementGridSize
262  END FUNCTION fieldexport_elementgridsize
263 
264  FUNCTION fieldexport_nodescaleindexes( handle, nodeCount, derivativeCount, elementDerivatives, nodeIndexes, &
265  & scaleindexes ) &
266  & bind(c,name="FieldExport_NodeScaleIndexes")
267  USE types
268  USE iso_c_binding
269  INTEGER(C_INT), VALUE :: handle
270  INTEGER(C_INT), VALUE :: nodeCount
271  TYPE(c_ptr), VALUE :: derivativeCount
272  TYPE(c_ptr), VALUE :: elementDerivatives
273  TYPE(c_ptr), VALUE :: nodeIndexes
274  TYPE(c_ptr), VALUE :: scaleIndexes
275  INTEGER(C_INT) :: FieldExport_NodeScaleIndexes
276  END FUNCTION fieldexport_nodescaleindexes
277 
278  FUNCTION fieldexport_elementindex( handle, dimensionCount, elementIndex ) &
279  & bind(c,name="FieldExport_ElementIndex")
280  USE types
281  USE iso_c_binding
282  INTEGER(C_INT), VALUE :: handle
283  INTEGER(C_INT), VALUE :: dimensionCount
284  INTEGER(C_INT), VALUE :: elementIndex
285  INTEGER(C_INT) :: FieldExport_ElementIndex
286  END FUNCTION fieldexport_elementindex
287 
288  FUNCTION fieldexport_elementnodeindices( handle, nodeCount, nodeIndices ) &
289  & bind(c,name="FieldExport_ElementNodeIndices")
290  USE types
291  USE iso_c_binding
292  INTEGER(C_INT), VALUE :: handle
293  INTEGER(C_INT), VALUE :: nodeCount
294  TYPE(c_ptr), VALUE :: nodeIndices
295  INTEGER(C_INT) :: FieldExport_ElementNodeIndices
296  END FUNCTION fieldexport_elementnodeindices
297 
298  FUNCTION fieldexport_elementnodescales( handle, isFirstSet, scaleCount, scales ) &
299  & bind(c,name="FieldExport_ElementNodeScales")
300  USE types
301  USE iso_c_binding
302  INTEGER(C_INT), VALUE :: handle
303  INTEGER(C_INT), VALUE :: isFirstSet
304  INTEGER(C_INT), VALUE :: scaleCount
305  TYPE(c_ptr), VALUE :: scales
306  INTEGER(C_INT) :: FieldExport_ElementNodeScales
307  END FUNCTION fieldexport_elementnodescales
308 
309  FUNCTION fieldexport_elementgridvalues( handle, isFirstSet, numberOfXi, elementValue ) &
310  & bind(c,name="FieldExport_ElementGridValues")
311  USE types
312  USE iso_c_binding
313  INTEGER(C_INT), VALUE :: handle
314  INTEGER(C_INT), VALUE :: isFirstSet
315  INTEGER(C_INT), VALUE :: numberOfXi
316  REAL(DP), VALUE :: elementValue
317  INTEGER(C_INT) :: FieldExport_ElementGridValues
318  END FUNCTION fieldexport_elementgridvalues
319 
320  FUNCTION fieldexport_nodevalues( handle, nodeNumber, valueCount, nodeValues ) &
321  & bind(c,name="FieldExport_NodeValues")
322  USE types
323  USE iso_c_binding
324  INTEGER(C_INT), VALUE :: handle
325  INTEGER(C_INT), VALUE :: nodeNumber
326  INTEGER(C_INT), VALUE :: valueCount
327  TYPE(c_ptr), VALUE :: nodeValues
328  INTEGER(C_INT) :: FieldExport_NodeValues
329  END FUNCTION fieldexport_nodevalues
330 
331  FUNCTION fieldexport_closesession( handle ) &
332  & bind(c,name="FieldExport_CloseSession")
333  USE types
334  USE iso_c_binding
335  INTEGER(C_INT), VALUE :: handle
336  INTEGER(C_INT) :: FieldExport_CloseSession
337  END FUNCTION fieldexport_closesession
338 
339  FUNCTION fieldexport_coordinatederivativeindices( handle, componentNumber, coordinateSystemType, numberOfDerivatives, &
340  & derivatives, valueindex ) bind(c,name="FieldExport_CoordinateDerivativeIndices")
341  USE types
342  USE iso_c_binding
343  INTEGER(C_INT), VALUE :: handle
344  INTEGER(C_INT), VALUE :: componentNumber
345  INTEGER(C_INT), VALUE :: coordinateSystemType
346  INTEGER(C_INT), VALUE :: numberOfDerivatives
347  TYPE(c_ptr), VALUE :: derivatives
348  INTEGER(C_INT), VALUE :: valueIndex
349  INTEGER(C_INT) :: FieldExport_CoordinateDerivativeIndices
350  END FUNCTION fieldexport_coordinatederivativeindices
351 
352  FUNCTION fieldexport_derivativeindices( handle, componentNumber, fieldType, variableType, numberOfDerivatives, &
353  & derivatives, valueindex ) bind(c,name="FieldExport_DerivativeIndices")
354  USE types
355  USE iso_c_binding
356  INTEGER(C_INT), VALUE :: handle
357  INTEGER(C_INT), VALUE :: componentNumber
358  INTEGER(C_INT), VALUE :: fieldType
359  INTEGER(C_INT), VALUE :: variableType
360  INTEGER(C_INT), VALUE :: numberOfDerivatives
361  TYPE(c_ptr), VALUE :: derivatives
362  INTEGER(C_INT), VALUE :: valueIndex
363  INTEGER(C_INT) :: FieldExport_DerivativeIndices
364  END FUNCTION fieldexport_derivativeindices
365 
366  FUNCTION fieldexport_endcomponent(handle) BIND(C,NAME="FieldExport_EndComponent")
367  USE types
368  USE iso_c_binding
369  INTEGER(C_INT), VALUE :: handle
370  INTEGER(C_INT) :: FieldExport_EndComponent
371  END FUNCTION fieldexport_endcomponent
372 
373  FUNCTION fieldexport_versioninfo(handle, numberOfVersions) BIND(C,NAME="FieldExport_VersionInfo")
374  USE types
375  USE iso_c_binding
376  INTEGER(C_INT), VALUE :: handle
377  INTEGER(C_INT), VALUE :: numberOfVersions
378  INTEGER(C_INT) :: FieldExport_VersionInfo
379  END FUNCTION fieldexport_versioninfo
380 
381  END INTERFACE
382 
383  INTERFACE reallocate
384  MODULE PROCEDURE reallocate_int
385  MODULE PROCEDURE reallocate_real
386  MODULE PROCEDURE reallocate_string
387  MODULE PROCEDURE reallocate_elements
388  MODULE PROCEDURE reallocate_components
389  MODULE PROCEDURE reallocate_basis
390  MODULE PROCEDURE reallocate_field
391  END INTERFACE !REALLOCATE
392 
393  INTERFACE grow_array
394  MODULE PROCEDURE grow_array_int
395  MODULE PROCEDURE grow_array_real
396  MODULE PROCEDURE grow_array_components
397  END INTERFACE !GROW_ARRAY
398 
400  MODULE PROCEDURE checked_deallocate_int
401  MODULE PROCEDURE checked_deallocate_real
402  MODULE PROCEDURE checked_deallocate_2d_int
403  MODULE PROCEDURE checked_deallocate_str
404  MODULE PROCEDURE checked_deallocate_components
405  MODULE PROCEDURE checked_deallocate_elements
406  MODULE PROCEDURE checked_deallocate_basis
407  MODULE PROCEDURE checked_deallocate_field
408  END INTERFACE !CHECKED_DEALLOCATE
409 
411 
412 
413 CONTAINS
414 
415  !
416  !================================================================================================================================
417  !
418 
419  SUBROUTINE reallocate_int( array, newSize, errorMessage, ERR, ERROR, * )
420  INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: array(:)
421  INTEGER(INTG), INTENT(IN) :: newSize
422  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
423  INTEGER(INTG), INTENT(OUT) :: ERR
424  TYPE(varying_string), INTENT(OUT) :: ERROR
425 
426  enters("REALLOCATE_INT",err,error,*999)
427 
428  IF( ALLOCATED( array ) ) THEN
429  DEALLOCATE( array )
430  ENDIF
431 
432  ALLOCATE( array( newsize ), stat = err )
433  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
434 
435  array(:) = 0
436 
437  exits("REALLOCATE_INT")
438  RETURN
439 999 errorsexits("REALLOCATE_INT",err,error)
440  RETURN 1
441  END SUBROUTINE reallocate_int
442 
443  !
444  !================================================================================================================================
445  !
446 
447  SUBROUTINE reallocate_real( array, newSize, errorMessage, ERR, ERROR, * )
448  REAL(DP), ALLOCATABLE, INTENT(INOUT) :: array(:)
449  INTEGER(INTG), INTENT(IN) :: newSize
450  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
451  INTEGER(INTG), INTENT(OUT) :: ERR
452  TYPE(varying_string), INTENT(OUT) :: ERROR
453 
454  enters("REALLOCATE_REAL",err,error,*999)
455 
456  IF( ALLOCATED( array ) ) THEN
457  DEALLOCATE( array )
458  ENDIF
459 
460  ALLOCATE( array( newsize ), stat = err )
461  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
462 
463  array(:) = 0
464 
465  exits("REALLOCATE_REAL")
466  RETURN
467 999 errorsexits("REALLOCATE_REAL",err,error)
468  RETURN 1
469  END SUBROUTINE reallocate_real
470 
471  !
472  !================================================================================================================================
473  !
474 
475  SUBROUTINE reallocate_string( array, newSize, errorMessage, ERR, ERROR, * )
476  TYPE(varying_string), ALLOCATABLE, INTENT(INOUT) :: array(:)
477  INTEGER(INTG), INTENT(IN) :: newSize
478  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
479  INTEGER(INTG), INTENT(OUT) :: ERR
480  TYPE(varying_string), INTENT(OUT) :: ERROR
481 
482  enters("REALLOCATE_STRING",err,error,*999)
483 
484  IF( ALLOCATED( array ) ) THEN
485  DEALLOCATE( array )
486  ENDIF
487 
488  ALLOCATE( array( newsize ), stat = err )
489  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
490 
491  exits("REALLOCATE_STRING")
492  RETURN
493 999 errorsexits("REALLOCATE_STRING",err,error)
494  RETURN 1
495  END SUBROUTINE reallocate_string
496 
497  !
498  !================================================================================================================================
499  !
500 
501  SUBROUTINE reallocate_components( array, newSize, errorMessage, ERR, ERROR, * )
502  TYPE(field_variable_component_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
503  INTEGER(INTG), INTENT(IN) :: newSize
504  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
505  INTEGER(INTG), INTENT(OUT) :: ERR
506  TYPE(varying_string), INTENT(OUT) :: ERROR
507 
508  enters("REALLOCATE_COMPONENTS",err,error,*999)
509 
510  IF( ALLOCATED( array ) ) THEN
511  DEALLOCATE( array )
512  ENDIF
513 
514  ALLOCATE( array( newsize ), stat = err )
515  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
516 
517  exits("REALLOCATE_COMPONENTS")
518  RETURN
519 999 errorsexits("REALLOCATE_COMPONENTS",err,error)
520  RETURN 1
521  END SUBROUTINE reallocate_components
522 
523  !
524  !================================================================================================================================
525  !
526 
527  SUBROUTINE reallocate_basis( array, newSize, errorMessage, ERR, ERROR, * )
528  TYPE(basis_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
529  INTEGER(INTG), INTENT(IN) :: newSize
530  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
531  INTEGER(INTG), INTENT(OUT) :: ERR
532  TYPE(varying_string), INTENT(OUT) :: ERROR
533 
534  enters("REALLOCATE_BASIS",err,error,*999)
535 
536  IF( ALLOCATED( array ) ) THEN
537  DEALLOCATE( array )
538  ENDIF
539 
540  ALLOCATE( array( newsize ), stat = err )
541  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
542 
543  exits("REALLOCATE_BASIS")
544  RETURN
545 999 errorsexits("REALLOCATE_BASIS",err,error)
546  RETURN 1
547  END SUBROUTINE reallocate_basis
548 
549  !
550  !================================================================================================================================
551  !
552 
553  SUBROUTINE reallocate_field( array, newSize, errorMessage, ERR, ERROR, * )
554  TYPE(field_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
555  INTEGER(INTG), INTENT(IN) :: newSize
556  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
557  INTEGER(INTG), INTENT(OUT) :: ERR
558  TYPE(varying_string), INTENT(OUT) :: ERROR
559 
560  enters("REALLOCATE_FIELD",err,error,*999)
561 
562  IF( ALLOCATED( array ) ) THEN
563  DEALLOCATE( array )
564  ENDIF
565 
566  ALLOCATE( array( newsize ), stat = err )
567  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
568 
569  exits("REALLOCATE_FIELD")
570  RETURN
571 999 errorsexits("REALLOCATE_FIELD",err,error)
572  RETURN 1
573  END SUBROUTINE reallocate_field
574 
575  !
576  !================================================================================================================================
577  !
578 
579  SUBROUTINE reallocate_elements( array, newSize, errorMessage, ERR, ERROR, * )
580  TYPE(mesh_elements_type_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
581  INTEGER(INTG), INTENT(IN) :: newSize
582  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
583  INTEGER(INTG), INTENT(OUT) :: ERR
584  TYPE(varying_string), INTENT(OUT) :: ERROR
585 
586  enters("REALLOCATE_ELEMENTS",err,error,*999)
587 
588  IF( ALLOCATED( array ) ) THEN
589  DEALLOCATE( array )
590  ENDIF
591 
592  ALLOCATE( array( newsize ), stat = err )
593  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
594 
595  exits("REALLOCATE_ELEMENTS")
596  RETURN
597 999 errorsexits("REALLOCATE_ELEMENTS",err,error)
598  RETURN 1
599  END SUBROUTINE reallocate_elements
600 
601  !
602  !================================================================================================================================
603  !
604 
605  SUBROUTINE reallocate_2d( array, newSize1, newSize2, errorMessage, ERR, ERROR, * )
606  INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: array(:,:)
607  INTEGER(INTG), INTENT(IN) :: newSize1
608  INTEGER(INTG), INTENT(IN) :: newSize2
609  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
610  INTEGER(INTG), INTENT(OUT) :: ERR
611  TYPE(varying_string), INTENT(OUT) :: ERROR
612 
613  enters("REALLOCATE_2D",err,error,*999)
614 
615  IF( ALLOCATED( array ) ) THEN
616  DEALLOCATE( array )
617  ENDIF
618 
619  ALLOCATE( array( newsize1, newsize2 ), stat = err )
620  IF( err /= 0 ) CALL flagerror( errormessage, err, error, *999)
621 
622  array(:,:) = 0
623 
624  exits("REALLOCATE_2D")
625  RETURN
626 999 errorsexits("REALLOCATE_2D",err,error)
627  RETURN 1
628  END SUBROUTINE reallocate_2d
629 
630  !
631  !================================================================================================================================
632  !
633 
634  SUBROUTINE grow_array_int( array, delta, errorMessage, ERR, ERROR, * )
635  INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: array(:)
636  INTEGER(INTG), INTENT(IN) :: delta
637  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
638  INTEGER(INTG), INTENT(OUT) :: ERR
639  TYPE(varying_string), INTENT(OUT) :: ERROR
640 
641  INTEGER(INTG), ALLOCATABLE :: tempArray(:)
642  INTEGER(INTG) :: oldSize
643 
644  enters("GROW_ARRAY_INT",err,error,*999)
645 
646  IF( .NOT.ALLOCATED( array ) ) THEN
647  CALL reallocate( array, delta, errormessage, err, error, *999 )
648  RETURN
649  ENDIF
650 
651  oldsize = SIZE( array )
652 
653  CALL reallocate( temparray, oldsize, errormessage, err, error, *999 )
654 
655  temparray(:) = array(:)
656 
657  CALL reallocate( array, oldsize + delta, errormessage, err, error, *999 )
658 
659  array(1:oldsize) = temparray(:)
660 
661  DEALLOCATE( temparray )
662 
663  exits("GROW_ARRAY_INT")
664  RETURN
665 999 errorsexits("GROW_ARRAY_INT",err,error)
666  RETURN 1
667  END SUBROUTINE grow_array_int
668 
669  !
670  !================================================================================================================================
671  !
672 
673  SUBROUTINE grow_array_real( array, delta, errorMessage, ERR, ERROR, * )
674  REAL(C_DOUBLE), ALLOCATABLE, INTENT(INOUT) :: array(:)
675  INTEGER(INTG), INTENT(IN) :: delta
676  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
677  INTEGER(INTG), INTENT(OUT) :: ERR
678  TYPE(varying_string), INTENT(OUT) :: ERROR
679 
680  REAL(C_DOUBLE), ALLOCATABLE :: tempArray(:)
681  INTEGER(INTG) :: oldSize
682 
683  enters("GROW_ARRAY_REAL",err,error,*999)
684 
685  IF( .NOT.ALLOCATED( array ) ) THEN
686  CALL reallocate( array, delta, errormessage, err, error, *999 )
687  RETURN
688  ENDIF
689 
690  oldsize = SIZE( array )
691 
692  CALL reallocate( temparray, oldsize, errormessage, err, error, *999 )
693 
694  temparray(:) = array(:)
695 
696  CALL reallocate( array, oldsize + delta, errormessage, err, error, *999 )
697 
698  array(1:oldsize) = temparray(:)
699 
700  DEALLOCATE( temparray )
701 
702  exits("GROW_ARRAY_REAL")
703  RETURN
704 999 errorsexits("GROW_ARRAY_REAL",err,error)
705  RETURN 1
706  END SUBROUTINE grow_array_real
707 
708  !
709  !================================================================================================================================
710  !
711 
712  SUBROUTINE grow_array_components( array, delta, errorMessage, ERR, ERROR, * )
713  TYPE(field_variable_component_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
714  INTEGER(INTG), INTENT(IN) :: delta
715  CHARACTER(LEN=*), INTENT(IN) :: errorMessage
716  INTEGER(INTG), INTENT(OUT) :: ERR
717  TYPE(varying_string), INTENT(OUT) :: ERROR
718 
719  TYPE(field_variable_component_ptr_type), ALLOCATABLE :: tempArray(:)
720  INTEGER(INTG) :: oldSize
721 
722  enters("GROW_ARRAY_COMPONENTS",err,error,*999)
723 
724  IF( .NOT.ALLOCATED( array ) ) THEN
725  CALL reallocate( array, delta, errormessage, err, error, *999 )
726  RETURN
727  ENDIF
728 
729  oldsize = SIZE( array )
730 
731  CALL reallocate( temparray, oldsize, errormessage, err, error, *999 )
732 
733  temparray(:) = array(:)
734 
735  CALL reallocate( array, oldsize + delta, errormessage, err, error, *999 )
736 
737  array(1:oldsize) = temparray(:)
738 
739  DEALLOCATE( temparray )
740 
741  exits("GROW_ARRAY_COMPONENTS")
742  RETURN
743 999 errorsexits("GROW_ARRAY_COMPONENTS",err,error)
744  RETURN 1
745  END SUBROUTINE grow_array_components
746 
747  !
748  !================================================================================================================================
749  !
750 
751  SUBROUTINE checked_deallocate_int( array )
752  INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: array(:)
753 
754  IF( ALLOCATED( array ) ) THEN
755  DEALLOCATE( array )
756  ENDIF
757 
758  END SUBROUTINE checked_deallocate_int
759 
760  !
761  !================================================================================================================================
762  !
763 
764  SUBROUTINE checked_deallocate_real( array )
765  REAL(DP), ALLOCATABLE, INTENT(INOUT) :: array(:)
766 
767  IF( ALLOCATED( array ) ) THEN
768  DEALLOCATE( array )
769  ENDIF
770 
771  END SUBROUTINE checked_deallocate_real
772 
773  !
774  !================================================================================================================================
775  !
776 
777  SUBROUTINE checked_deallocate_2d_int( array )
778  INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: array(:,:)
779 
780  IF( ALLOCATED( array ) ) THEN
781  DEALLOCATE( array )
782  ENDIF
783 
784  END SUBROUTINE checked_deallocate_2d_int
785 
786  !
787  !================================================================================================================================
788  !
789 
790  SUBROUTINE checked_deallocate_components( array )
791  TYPE(field_variable_component_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
792 
793  IF( ALLOCATED( array ) ) THEN
794  DEALLOCATE( array )
795  ENDIF
796 
797  END SUBROUTINE checked_deallocate_components
798 
799  !
800  !================================================================================================================================
801  !
802 
803  SUBROUTINE checked_deallocate_str( array )
804  TYPE(varying_string), ALLOCATABLE, INTENT(INOUT) :: array(:)
805 
806  IF( ALLOCATED( array ) ) THEN
807  DEALLOCATE( array )
808  ENDIF
809 
810  END SUBROUTINE checked_deallocate_str
811 
812  !
813  !================================================================================================================================
814  !
815 
816  SUBROUTINE checked_deallocate_elements( array )
817  TYPE(mesh_elements_type_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
818 
819  IF( ALLOCATED( array ) ) THEN
820  DEALLOCATE( array )
821  ENDIF
822 
823  END SUBROUTINE checked_deallocate_elements
824 
825  !
826  !================================================================================================================================
827  !
828 
829  SUBROUTINE checked_deallocate_basis( array )
830  TYPE(basis_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
831 
832  IF( ALLOCATED( array ) ) THEN
833  DEALLOCATE( array )
834  ENDIF
835 
836  END SUBROUTINE checked_deallocate_basis
837 
838  !================================================================================================================================
839  !
840 
841  SUBROUTINE checked_deallocate_field( array )
842  TYPE(field_ptr_type), ALLOCATABLE, INTENT(INOUT) :: array(:)
843 
844  IF( ALLOCATED( array ) ) THEN
845  DEALLOCATE( array )
846  ENDIF
847 
848  END SUBROUTINE checked_deallocate_field
849 
850  !
851  !================================================================================================================================
852  !
853 
855  SUBROUTINE field_io_field_info(STRING, LABEL_TYPE, FIELD_TYPE , ERR, ERROR, *)
856  !Argument variables
857  TYPE(varying_string), INTENT(IN) :: STRING
858  INTEGER(INTG), INTENT(IN) :: LABEL_TYPE
859  INTEGER(INTG), INTENT(INOUT) :: FIELD_TYPE
860  !REAL(DP), OPTIONAL, INTENT(INOUT) :: FOCUS
861  INTEGER(INTG), INTENT(OUT) :: ERR
862  TYPE(varying_string), INTENT(OUT) :: ERROR
863  !Local Variables
864  INTEGER(INTG) :: pos
865  TYPE(varying_string) :: LINE, KEYWORD
866 
867  enters("FIELD_IO_FIELD_INFO",err,error,*999)
868 
869  line=string
870 
871  SELECT CASE(label_type)
873  pos=index(line, ",")
874  line=remove(line, 1, pos)
875  pos=index(line, ",")
876  keyword=extract(line, 1, pos-1)
877  line=remove(line, 1,pos)
878  keyword=adjustl(keyword)
879  keyword=trim(keyword)
880  IF(keyword=="coordinate") THEN
881  field_type=field_geometric_type
882  ELSE IF (keyword=="anatomical") THEN
883  field_type=field_fibre_type
884  ELSE
885  field_type=-1
886  CALL flagerror("Cannot find corresponding field type from input string",err,error,*999)
887  ENDIF
888  CASE DEFAULT
889  CALL flagerror("Cannot find any information from input string",err,error,*999)
890  END SELECT !CASE(LABEL_TYPE)
891 
892  exits("FIELD_IO_FIELD_INFO")
893  RETURN
894 999 errorsexits("FIELD_IO_FIELD_INFO",err,error)
895  RETURN 1
896  END SUBROUTINE field_io_field_info
897 
898 
899  !
900  !================================================================================================================================
901  !
902 
904  FUNCTION field_io_derivative_info(LINE, ERR, ERROR)
905  !Argument variables
906  TYPE(varying_string), INTENT(IN) :: LINE
907  INTEGER(INTG), INTENT(OUT) :: ERR
908  TYPE(varying_string), INTENT(OUT) :: ERROR
909  !Local Variables
910  INTEGER(INTG) ::FIELD_IO_DERIVATIVE_INFO
911 
912  enters("FIELD_IO_DERIVATIVE_INFO",err,error,*999)
913 
914  IF("d/ds1"==line) THEN
915  field_io_derivative_info=part_deriv_s1
916  ELSE IF("d2/ds1ds1"==line) THEN
917  field_io_derivative_info=part_deriv_s1_s1
918  ELSE IF("d/ds2"==line) THEN
919  field_io_derivative_info=part_deriv_s2
920  ELSE IF("d2/ds2ds2"==line) THEN
921  field_io_derivative_info=part_deriv_s2_s2
922  ELSE IF("d/ds3"==line) THEN
923  field_io_derivative_info=part_deriv_s1_s2
924  ELSE IF("d2/ds3ds3"==line) THEN
925  field_io_derivative_info=part_deriv_s3
926  ELSE IF("d2/ds3ds3"==line) THEN
927  field_io_derivative_info=part_deriv_s3_s3
928  ELSE IF("d2/ds1ds3"==line) THEN
929  field_io_derivative_info=part_deriv_s1_s3
930  ELSE IF("d2/ds2ds3"==line) THEN
931  field_io_derivative_info=part_deriv_s2_s3
932  ELSE IF("d3/ds1ds2ds3"==line) THEN
933  field_io_derivative_info=part_deriv_s1_s2_s3
934  ELSE IF("d/ds4"==line) THEN
935  field_io_derivative_info=part_deriv_s4
936  ELSE IF("d2/ds4ds4"==line) THEN
937  field_io_derivative_info=part_deriv_s4_s4
938  ELSE IF("d2/ds1ds4"==line) THEN
939  field_io_derivative_info=part_deriv_s1_s4
940  ELSE IF("d2/ds2ds4"==line) THEN
941  field_io_derivative_info=part_deriv_s2_s4
942  ELSE IF("d2/ds3ds4"==line) THEN
943  field_io_derivative_info=part_deriv_s3_s4
944  ELSE IF("d3/ds1ds2ds4"==line) THEN
945  field_io_derivative_info=part_deriv_s1_s2_s4
946  ELSE IF("d3/ds1ds3ds4"==line) THEN
947  field_io_derivative_info=part_deriv_s1_s3_s4
948  ELSE IF("d3/ds2ds3ds4"==line) THEN
949  field_io_derivative_info=part_deriv_s2_s3_s4
950  ELSE IF("d3/ds1ds4ds4"==line) THEN
951  field_io_derivative_info=part_deriv_s1_s4_s4
952  ELSE IF("d3/ds2ds4ds4"==line) THEN
953  field_io_derivative_info=part_deriv_s2_s4_s4
954  ELSE IF("d3/ds3ds4ds4"==line) THEN
955  field_io_derivative_info=part_deriv_s3_s4_s4
956  ELSE IF("d3/ds4ds4ds4"==line) THEN
957  field_io_derivative_info=part_deriv_s4_s4_s4
958  ELSE
959  field_io_derivative_info=-1
960  CALL flagerror("Could not recognize derivatives from input string",err,error,*999)
961  ENDIF
962 
963  exits("FIELD_IO_DERIVATIVE_INFO")
964  RETURN
965 999 errorsexits("FIELD_IO_DERIVATIVE_INFO",err,error)
966  END FUNCTION field_io_derivative_info
967 
968  !
969  !================================================================================================================================
970  !
971 
973  FUNCTION field_io_element_derivative_index(ELEMENT, DERIVATIVE_NUMBER, NODE_NUMBER, ERR, ERROR)
974  !Argument variables
975  TYPE(domain_element_type), INTENT(IN) :: ELEMENT
976  INTEGER(INTG), INTENT(IN) :: DERIVATIVE_NUMBER
977  INTEGER(INTG), INTENT(IN) :: NODE_NUMBER
978  INTEGER(INTG), INTENT(OUT) :: ERR
979  TYPE(varying_string), INTENT(OUT) :: ERROR
980  !Return variable
981  INTEGER(INTG) :: FIELD_IO_ELEMENT_DERIVATIVE_INDEX
982  !Local Variables
983  INTEGER(INTG) :: VERSION_NUMBER,NUMBER_OF_DERIVATIVES
984 
985  enters("FIELD_IO_ELEMENT_DERIVATIVE_INDEX", err, error, *999)
986 
987  version_number=element%elementVersions(derivative_number, node_number)
988  number_of_derivatives=element%BASIS%NUMBER_OF_DERIVATIVES(node_number)
989  field_io_element_derivative_index=(version_number-1)*number_of_derivatives + &
990  & element%ELEMENT_DERIVATIVES(derivative_number, node_number)
991 
992  exits("FIELD_IO_ELEMENT_DERIVATIVE_INDEX")
993  RETURN
994 999 errorsexits("FIELD_IO_ELEMENT_DERIVATIVE_INDEX",err,error)
996 
997  !
998  !================================================================================================================================
999  !
1000 
1002  SUBROUTINE field_io_create_fields(NAME, REGION, DECOMPOSITION, FIELD_VALUES_SET_TYPE, NUMBER_OF_FIELDS, &
1003  !&USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER,
1004  &mesh_components_of_field_components, components_in_fields, number_of_exnode_files, &
1005  &master_computational_number, my_computational_node_number, field_scaling_type, err, error, *)
1006  !Argument variables
1007  TYPE(varying_string), INTENT(IN) :: NAME
1008  TYPE(region_type), POINTER :: REGION
1009  TYPE(decomposition_type), POINTER :: DECOMPOSITION
1010  INTEGER(INTG), INTENT(IN) :: FIELD_VALUES_SET_TYPE
1011  INTEGER(INTG), INTENT(IN) :: NUMBER_OF_FIELDS
1012  !INTEGER(INTG), INTENT(IN) :: USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(:)
1013  INTEGER(INTG), INTENT(IN) :: MESH_COMPONENTS_OF_FIELD_COMPONENTS(:)
1014  INTEGER(INTG), INTENT(IN) :: COMPONENTS_IN_FIELDS(:)
1015  INTEGER(INTG), INTENT(IN) :: NUMBER_OF_EXNODE_FILES
1016  INTEGER(INTG), INTENT(IN) :: MASTER_COMPUTATIONAL_NUMBER
1017  INTEGER(INTG), INTENT(IN) :: my_computational_node_number
1018  INTEGER(INTG), INTENT(IN) :: FIELD_SCALING_TYPE
1019  INTEGER(INTG), INTENT(OUT) :: ERR
1020  TYPE(varying_string), INTENT(OUT) :: ERROR
1021  !Local Variables
1022  TYPE(field_type), POINTER :: FIELD
1023  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES
1024  TYPE(varying_string), ALLOCATABLE :: LIST_STR(:)
1025  TYPE(varying_string) :: FILE_NAME, FILE_STATUS, LINE, LINE1
1026  TYPE(varying_string) :: CMISS_KEYWORD_FIELDS, CMISS_KEYWORD_NODE, CMISS_KEYWORD_COMPONENTS
1027  TYPE(varying_string) :: CMISS_KEYWORD_VALUE_INDEX, CMISS_KEYWORD_DERIVATIVE
1028  INTEGER(INTG), ALLOCATABLE :: tmp_pointer(:), LIST_DEV(:), LIST_DEV_POS(:)
1029  INTEGER(INTG) :: FILE_ID
1030  !INTEGER(INTG) :: NUMBER_FIELDS
1031  INTEGER(INTG) :: NODAL_USER_NUMBER, NODAL_LOCAL_NUMBER, FIELDTYPE, NUMBER_NODAL_VALUE_LINES, NUMBER_OF_LINES, &
1032  & NUMBER_OF_COMPONENTS !, LABEL_TYPE, FOCUS
1033  INTEGER(INTG) :: MPI_IERROR
1034  INTEGER(INTG) :: idx_comp, idx_comp1, pos, idx_field, idx_exnode, idx_nodal_line, idx_node
1035  INTEGER(INTG) :: idx_variable, idx_dev, idx_dev1, total_number_of_comps, total_number_of_devs, number_of_devs !idx_variable1
1036  INTEGER(INTG) :: number_of_comps, VARIABLE_IDX,variable_type
1037  REAL(DP), ALLOCATABLE :: LIST_DEV_VALUE(:)
1038  LOGICAL :: SECTION_START, FILE_END, NODE_SECTION, FILE_OPEN, NODE_IN_DOMAIN
1039 
1040 
1041  enters("FIELD_IO_CREATE_FIELDS",err,error,*999)
1042 
1043  IF(.NOT.ASSOCIATED(decomposition)) THEN
1044  CALL flagerror("decomposition is NOT associated before importing data",err,error,*999)
1045  GOTO 999
1046  ENDIF
1047 
1048  IF(.NOT.ASSOCIATED(region)) THEN
1049  CALL flagerror("region is NOT associated before importing data",err,error,*999)
1050  GOTO 999
1051  ENDIF
1052 
1053  cmiss_keyword_fields="#Fields="
1054  cmiss_keyword_components="#Components="
1055  cmiss_keyword_value_index="Value index="
1056  cmiss_keyword_derivative="#Derivatives="
1057  cmiss_keyword_node="Node:"
1058 
1059  file_end=.false.
1060  idx_exnode=0
1061  file_id=1030
1062  file_status="OLD"
1063  total_number_of_comps=0
1064  number_nodal_value_lines=5
1065  number_of_components=sum(components_in_fields)
1066 
1067  !checking the field strings in exnode files
1068  IF(master_computational_number==my_computational_node_number) THEN
1069 
1070  CALL reallocate( list_str, number_of_fields, "can not allocate list of strings for fields", err, error, *999 )
1071 
1072  DO WHILE(idx_exnode<number_of_exnode_files)
1073 
1074  file_id=1030+idx_exnode
1075  !checking the next file
1076  file_name=name//".part"//trim(number_to_vstring(idx_exnode,"*",err,error))//".exnode"
1077  !INQUIRE(FILE=CHAR(FILE_NAME), OPENED=FILE_OPEN)
1078  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
1079  section_start=.false.
1080  file_end=.false.
1081 
1082  DO WHILE(.NOT.file_end)
1083  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1084 
1085  !check the beginning of field section in exnode files
1086  IF((.NOT.section_start).AND.(verify(cmiss_keyword_fields,line)==0)) THEN
1087  section_start=.true.
1088  ENDIF
1089 
1090  !check whether it is a new header for another group of elements
1091  IF(section_start.AND.(verify(cmiss_keyword_fields,line)==0)) THEN
1092 
1093  !collect header information
1094  pos=index(line,cmiss_keyword_fields)
1095  line=remove(line,1, pos+len_trim(cmiss_keyword_fields)-1)
1096  idx_field=string_to_integer(line, err,error)
1097  IF(idx_field/=number_of_fields) CALL flagerror("find different field number in exnode files",err,error,*999)
1098  idx_comp=0
1099  DO idx_field=1,number_of_fields
1100  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1101  IF(idx_exnode==0) THEN
1102  list_str(idx_field)=line
1103  pos=index(line,cmiss_keyword_components)
1104  line=remove(line, 1, pos+len_trim(cmiss_keyword_components)-1)
1105  number_of_comps=string_to_integer(line, err,error)
1106  total_number_of_comps=total_number_of_comps+number_of_comps
1107  ELSE
1108  IF(list_str(idx_field)/=line) CALL flagerror("find different field information in exnode files", &
1109  & err,error,*999)
1110  ENDIF
1111  pos=index(line,cmiss_keyword_components)
1112  line=remove(line,1, pos+len_trim(cmiss_keyword_components)-1)
1113  number_of_comps=string_to_integer(line, err,error)
1114  DO idx_comp=1,number_of_comps
1115  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1116  ENDDO !idx_comp1
1117  ENDDO !idx_field
1118  ENDIF !START_OF_FIELD_SECTION==.TRUE..AND.(VERIFY(CMISS_KEYWORD_FIELD,LINE)==0)
1119  ENDDO !(FILE_END==.FALSE.)
1120  CALL field_io_fortran_file_close(file_id, err,error,*999)
1121  idx_exnode=idx_exnode+1
1122  ENDDO !idx_exnode<NUMBER_OF_EXNODE_FILES
1123  ENDIF !MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number
1124 
1125  idx_comp1=0
1126  DO idx_field=1,number_of_fields
1127  IF(ASSOCIATED(field)) NULLIFY(field)
1128  !Start to create a default (geometric) field on the region
1129  CALL field_create_start(idx_field,region,field,err,error,*999)
1130  !always has one field variable in one field during reading
1131  CALL field_number_of_variables_set(field,1,err,error,*999)
1132  !Set the decomposition to use
1133  CALL field_mesh_decomposition_set(field,decomposition,err,error,*999)
1134  !Set the number of components for this field
1135  CALL field_number_of_components_set(field,field_u_variable_type,components_in_fields(idx_field),err,error,*999)
1136  DO idx_comp=1, components_in_fields(idx_field)
1137  idx_comp1=idx_comp1+1
1138  !Set the domain to be used by the field components
1139  CALL field_component_mesh_component_set(field,1,idx_comp,mesh_components_of_field_components(idx_comp1),err,error,*999)
1140  ENDDO
1141  !Set the scaling factor
1142  CALL field_scaling_type_set(field, field_scaling_type, err, error, *999)
1143 
1144  IF(master_computational_number==my_computational_node_number) THEN
1145  CALL field_io_field_info(list_str(idx_field), field_io_field_label, fieldtype, err, error, *999)
1146  ENDIF
1147  CALL mpi_bcast(fieldtype,1,mpi_logical,master_computational_number,mpi_comm_world,mpi_ierror)
1148  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1149  !Set FIELD TYPE
1150  CALL field_type_set(field, fieldtype, err, error, *999)
1151  !Finish creating the field
1152  CALL field_create_finish(field,err,error,*999)
1153  ENDDO
1154 
1155  IF(master_computational_number==my_computational_node_number) THEN
1156  CALL checked_deallocate( list_str )
1157  ENDIF
1158 
1159  file_end=.true.
1160  idx_exnode=-1
1161  file_id=1030
1162  file_status="OLD"
1163 
1164  !broadcasting total_number_of_comps
1165  CALL mpi_bcast(total_number_of_comps,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1166  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1167 
1168  CALL reallocate( list_dev_pos, total_number_of_comps, &
1169  & "Could not allocate memory for nodal derivative position in field components", err, error, *999 )
1170 
1171  DO WHILE(idx_exnode<number_of_exnode_files)
1172 
1173  CALL mpi_bcast(file_end,1,mpi_logical,master_computational_number,mpi_comm_world,mpi_ierror)
1174  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1175 
1176  IF(file_end) THEN
1177  idx_exnode=idx_exnode+1
1178  INQUIRE(unit=file_id, opened=file_open)
1179  IF(file_open) CALL field_io_fortran_file_close(file_id, err,error,*999)
1180  IF(idx_exnode>=number_of_exnode_files) EXIT
1181  ENDIF
1182 
1183  !IF(MASTER_COMPUTATIONAL_NUMBER/=my_computational_node_number) PRINT * , idx_exnode
1184 
1185  !goto the start of mesh part
1186  IF(master_computational_number==my_computational_node_number) THEN
1187 
1188  IF(file_end) THEN
1189  file_id=1030+idx_exnode
1190  !checking the next file
1191  file_name=name//".part"//trim(number_to_vstring(idx_exnode,"*",err,error))//".exnode"
1192  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
1193  file_end=.false.
1194  section_start=.false.
1195  node_section=.false.
1196  !idx_exnode=idx_exnode+1
1197  ENDIF
1198 
1199  IF((.NOT.file_end).AND.(.NOT.section_start)) THEN
1200  !find a new header
1201  DO WHILE(verify(cmiss_keyword_fields,line)/=0)
1202  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1203  ENDDO
1204  section_start=.true.
1205  ENDIF
1206 
1207  !have not touched the end
1208  IF((.NOT.file_end).AND.section_start.AND.(.NOT.node_section)) THEN
1209  pos=index(line,cmiss_keyword_fields)
1210  line=remove(line,1, pos+len_trim(cmiss_keyword_fields)-1)
1211  !number_of_fields=STRING_TO_INTEGER(LINE, ERR, ERROR)
1212  total_number_of_devs=0
1213  idx_comp1=0
1214  idx_dev1=0
1215  DO idx_field=1, number_of_fields
1216  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1217  pos=index(line,cmiss_keyword_components)
1218  line=remove(line,1, pos+len_trim(cmiss_keyword_components)-1)
1219  number_of_comps=string_to_integer(line, err, error)
1220  !total_number_of_comps=total_number_of_comps+number_of_comps
1221 
1222  DO idx_comp=1, number_of_comps
1223  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1224  pos=index(line,".")
1225  line=remove(line,1, pos+1)
1226  pos=index(line,cmiss_keyword_value_index)
1227  line=remove(line,1, pos+len_trim(cmiss_keyword_value_index)-1)
1228  pos=index(line,",")
1229  line1=extract(line,1,pos-1)
1230  idx_comp1=idx_comp1+1
1231  list_dev_pos(idx_comp1)=string_to_integer(line1, err, error)
1232 
1233  pos=index(line,cmiss_keyword_derivative)
1234  line=remove(line,1, pos+len_trim(cmiss_keyword_derivative)-1)
1235  pos=index(line,"(")
1236  line1=extract(line,1,pos-1)
1237  number_of_devs=string_to_integer(line, err, error)+1
1238  total_number_of_devs=total_number_of_devs+number_of_devs
1239 
1240  IF(ALLOCATED(list_dev)) THEN
1241  CALL reallocate( tmp_pointer, total_number_of_devs-number_of_devs, &
1242  & "Could not allocate temporary memory for nodal derivative index in master node", err,error,*999)
1243  tmp_pointer(:)=list_dev(:)
1244 
1245  CALL reallocate( list_dev, total_number_of_devs, &
1246  & "Could not allocate temporary memory for nodal derivative index in master node", err,error,*999)
1247  list_dev(1:total_number_of_devs-number_of_devs)=tmp_pointer(:)
1248 
1249  DEALLOCATE(tmp_pointer)
1250  ELSE
1251  CALL reallocate( list_dev, total_number_of_devs, &
1252  & "Could not allocate memory for nodal derivative index", err, error, *999)
1253  ENDIF
1254 
1255  !print *, idx_dev1, NO_PART_DERIV, LIST_DEV
1256 
1257  IF(number_of_devs<=1) THEN
1258  idx_dev1=idx_dev1+1
1259  list_dev(idx_dev1)=no_part_deriv
1260  !print *, idx_dev1, NO_PART_DERIV, LIST_DEV
1261  ELSE
1262  pos=index(line,"(")
1263  line=remove(line,1, pos)
1264  pos=index(line,")")
1265  line=remove(line,pos, len(line))
1266  idx_dev1=idx_dev1+1
1267  list_dev(idx_dev1)=no_part_deriv
1268  DO idx_dev=2, number_of_devs-1
1269  idx_dev1=idx_dev1+1
1270  pos=index(line,",")
1271  line1=extract(line, 1, pos-1)
1272  line=remove(line, 1, pos)
1273  list_dev(idx_dev1)=field_io_derivative_info(line1, err,error)
1274  ENDDO
1275  idx_dev1=idx_dev1+1
1276  list_dev(idx_dev1)=field_io_derivative_info(line, err,error)
1277  ENDIF
1278  ENDDO !idx_comp
1279  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1280  node_section=.true.
1281  ENDDO !idx_field
1282  ENDIF !FILE_END==.FALSE..AND.SECTION_START=.TRUE..AND.NODE_SECTION=.FALSE.
1283  ENDIF !MASTER_COMPUTATIONAL_NUMBER
1284 
1285  !broadcasting total_number_of_devs
1286  CALL mpi_bcast(total_number_of_devs,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1287  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1288 
1289  IF(master_computational_number/=my_computational_node_number) THEN
1290  CALL reallocate( list_dev, total_number_of_devs, &
1291  & "Could not allocate memory for nodal derivative index in non-master node", err, error, *999 )
1292  ENDIF
1293 
1294  CALL reallocate( list_dev_value, total_number_of_devs, &
1295  & "Could not allocate memory for nodal derivative index in non-master node", err, error, *999 )
1296 
1297  !broadcasting total_number_of_comps
1298  CALL mpi_bcast(list_dev_pos,total_number_of_comps,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1299  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1300  !broadcasting total_number_of_devs
1301  CALL mpi_bcast(list_dev,total_number_of_devs,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1302  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1303 
1304  !goto the start of mesh part
1305  IF(master_computational_number==my_computational_node_number) THEN
1306 
1307  !have not touched the end
1308  IF((.NOT.file_end).AND.section_start.AND.node_section) THEN
1309 
1310  IF(verify(cmiss_keyword_node, line)==0) THEN
1311  pos=index(line,cmiss_keyword_node)
1312  line=remove(line,1, pos+len_trim(cmiss_keyword_node)-1)
1313  nodal_user_number=string_to_integer(line, err, error)
1314  idx_comp1=1
1315  DO idx_comp=1, number_of_comps-1
1316  IF(list_dev_pos(idx_comp+1)-list_dev_pos(idx_comp)<=number_nodal_value_lines) THEN
1317  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1318  CALL string_to_muti_reals_vs(line, list_dev_pos(idx_comp+1)-list_dev_pos(idx_comp), list_dev_value, &
1319  & list_dev_pos(idx_comp), err,error, *999)
1320  ELSE
1321  number_of_lines=(list_dev_pos(idx_comp+1)-list_dev_pos(idx_comp))/number_nodal_value_lines
1322  DO idx_nodal_line=1, number_of_lines
1323  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1324  CALL string_to_muti_reals_vs(line, number_nodal_value_lines, list_dev_value, list_dev_pos(idx_comp)+ &
1325  & (idx_nodal_line-1)*number_nodal_value_lines, err,error, *999)
1326  ENDDO
1327  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1328  CALL string_to_muti_reals_vs(line, (list_dev_pos(idx_comp+1)-list_dev_pos(idx_comp))- &
1329  & number_nodal_value_lines*number_of_lines, list_dev_value, list_dev_pos(idx_comp)+ &
1330  & (idx_nodal_line-1)*number_nodal_value_lines, err,error, *999)
1331  ENDIF
1332  ENDDO
1333  !IF((total_number_of_devs-LIST_DEV_POS(idx_comp)+1)<=NUMBER_NODAL_VALUE_LINES) THEN
1334  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR, ERROR,*999)
1335  ! CALL STRING_TO_MUTI_REALS_VS(LINE, total_number_of_devs-LIST_DEV_POS(idx_comp)+1, LIST_DEV_VALUE, LIST_DEV_POS(idx_comp), ERR,ERROR, *999)
1336  !ELSE
1337  ! NUMBER_OF_LINES=(total_number_of_devs-LIST_DEV_POS(idx_comp)+1)/NUMBER_NODAL_VALUE_LINES
1338  ! DO idx_nodal_line=1, NUMBER_OF_LINES
1339  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR, ERROR,*999)
1340  ! CALL STRING_TO_MUTI_REALS_VS(LINE, NUMBER_NODAL_VALUE_LINES, LIST_DEV_VALUE, LIST_DEV_POS(idx_comp)+(idx_nodal_line-1)*NUMBER_NODAL_VALUE_LINES, ERR,ERROR, *999)
1341  ! ENDDO
1342  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR, ERROR,*999)
1343  ! CALL STRING_TO_MUTI_REALS_VS(LINE, (LIST_DEV_POS(idx_comp+1)-LIST_DEV_POS(idx_comp))-NUMBER_NODAL_VALUE_LINES*NUMBER_OF_LINES, LIST_DEV_VALUE, LIST_DEV_POS(idx_comp)+(idx_nodal_line-1)*NUMBER_NODAL_VALUE_LINES, ERR,ERROR, *999)
1344  !ENDIF
1345  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1346  CALL string_to_muti_reals_vs(line, total_number_of_devs-list_dev_pos(idx_comp)+1, list_dev_value, &
1347  & list_dev_pos(idx_comp), err,error, *999)
1348  ELSE
1349  CALL flagerror("The position of nodal information in exenode files is not correct",err, error,*999)
1350  node_section=.false.
1351  ENDIF !(VERIFY(CMISS_KEYWORD_NODE , LINE)==0)
1352  IF(.NOT.file_end) THEN
1353  CALL field_io_fortran_file_read_string(file_id, line, file_end, err, error,*999)
1354  IF(verify(cmiss_keyword_node, line)/=0) node_section=.false.
1355  ENDIF
1356  ENDIF !FILE_END==.FALSE..AND.SECTION_START=.TRUE..AND.NODE_SECTION=.TRUE.
1357  ENDIF !(MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number)
1358 
1359  !broadcasting total_number_of_devs
1360  CALL mpi_bcast(list_dev_value,total_number_of_devs,mpi_real8,master_computational_number,mpi_comm_world,mpi_ierror)
1361  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1362  CALL mpi_bcast(nodal_user_number,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1363  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1364 
1365  !IF(MASTER_COMPUTATIONAL_NUMBER/=my_computational_node_number) THEN
1366  print *, "user number:"
1367  print *, nodal_user_number
1368  print *, list_dev_value
1369  !ENDIF
1370 
1371 
1372  idx_comp1=0
1373  idx_dev1=0
1374  idx_variable=1
1375  DO idx_field=1,number_of_fields
1376  IF(ASSOCIATED(field)) NULLIFY(field)
1377  field=>region%FIELDS%FIELDS(idx_field)%PTR
1378  DO idx_comp=1, components_in_fields(idx_field)
1379  idx_comp1=idx_comp1+1
1380  domain_nodes=>field%VARIABLES(idx_variable)%COMPONENTS(idx_comp)%DOMAIN%TOPOLOGY%NODES
1381  node_in_domain=.false.
1382  DO idx_node=1,domain_nodes%NUMBER_OF_NODES
1383  !IF(DOMAIN_NODES%NODES(idx_node)%GLOBAL_NUMBER==USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(NODAL_USER_NUMBER)) THEN
1384  IF(domain_nodes%NODES(idx_node)%USER_NUMBER==nodal_user_number) THEN
1385  node_in_domain=.true.
1386  nodal_local_number=idx_node
1387  ENDIF
1388  ENDDO
1389 
1390  IF(node_in_domain) THEN
1391  IF(idx_comp1>=number_of_components) THEN
1392  DO idx_dev=1, total_number_of_devs-list_dev_pos(idx_comp1)+1
1393  idx_dev1=idx_dev1+1
1394  !Set the domain to be used by the field components
1395  !Default to version 1 of each node derivative
1396  CALL field_parameter_set_update_node(field,field_values_set_type,1, list_dev(idx_dev1), &
1397  &nodal_local_number, idx_comp, idx_variable, list_dev_value(idx_dev1),&
1398  &err, error, *999)
1399  !print *, "n--n"
1400  ENDDO !idx_dev
1401  ELSE
1402  DO idx_dev=1, list_dev_pos(idx_comp1+1)-list_dev_pos(idx_comp1)
1403  idx_dev1=idx_dev1+1
1404  !Set the domain to be used by the field components
1405  !Default to version 1 of each node derivative
1406  CALL field_parameter_set_update_node(field,field_values_set_type,1, list_dev(idx_dev1), &
1407  &nodal_local_number, idx_comp, idx_variable, list_dev_value(idx_dev1),&
1408  &err, error, *999)
1409  !print *, "n--n"
1410  ENDDO !idx_dev
1411  ENDIF !idx_comp1
1412  ENDIF !NODE_IN_DOMAIN
1413  ENDDO !idx_comp
1414  ENDDO !idx_field
1415  ENDDO !idx_exnode<NUMBER_OF_EXELEM_FILES
1416 
1417  !print *, "out of loop"
1418 
1419  DO idx_field=1,number_of_fields
1420  IF(ASSOCIATED(field)) NULLIFY(field)
1421  field=>region%FIELDS%FIELDS(idx_field)%PTR
1422  DO variable_idx=1,field%NUMBER_OF_VARIABLES
1423  variable_type=field%VARIABLES(variable_idx)%VARIABLE_TYPE
1424  CALL field_parameter_set_update_start(field,variable_type,field_values_set_type,err,error,*999)
1425  CALL field_parameter_set_update_finish(field,variable_type,field_values_set_type,err,error,*999)
1426  ENDDO !variable_idx
1427  ENDDO
1428 
1429  IF(ALLOCATED(tmp_pointer)) DEALLOCATE(tmp_pointer)
1430  IF(ALLOCATED(list_dev_value)) DEALLOCATE(list_dev_value)
1431  IF(ALLOCATED(list_dev)) DEALLOCATE(list_dev)
1432  IF(ALLOCATED(list_dev_pos)) DEALLOCATE(list_dev_pos)
1433  IF(ALLOCATED(list_str)) DEALLOCATE(list_str)
1434 
1435  exits("FIELD_IO_CREATE_FIELDS")
1436  RETURN
1437 999 errorsexits("FIELD_IO_CREATE_FIELDS",err,error)
1438  RETURN 1
1439  END SUBROUTINE field_io_create_fields
1440 
1441 
1442  !
1443  !================================================================================================================================
1444  !
1445 
1447  SUBROUTINE field_io_create_decompistion(DECOMPOSITION, DECOMPOSITION_USER_NUMBER, DECOMPOSITION_METHOD, MESH, &
1448  & number_of_domains, err, error, *)
1449  !Argument variables
1450  TYPE(decomposition_type), POINTER :: DECOMPOSITION
1451  INTEGER(INTG), INTENT(IN) :: DECOMPOSITION_USER_NUMBER
1452  INTEGER(INTG), INTENT(IN) :: DECOMPOSITION_METHOD
1453  TYPE(mesh_type), POINTER :: MESH
1454  INTEGER(INTG), INTENT(IN) :: NUMBER_OF_DOMAINS
1455  INTEGER(INTG), INTENT(OUT) :: ERR
1456  TYPE(varying_string), INTENT(OUT) :: ERROR
1457  !Local Variables
1458 
1459  IF(.NOT.ASSOCIATED(mesh)) THEN
1460  CALL flagerror("mesh is NOT associated before decomposing the mesh",err,error,*999)
1461  GOTO 999
1462  ENDIF
1463 
1464  enters("FIELD_IO_CREATE_DECOMPISTION",err,error,*999)
1465  !Create a decomposition
1466  CALL decomposition_create_start(decomposition_user_number,mesh,decomposition,err,error,*999)
1467  !Set the decomposition to be a general decomposition with the specified number of domains
1468  CALL decomposition_type_set(decomposition,decomposition_method,err,error,*999)
1469  CALL decomposition_number_of_domains_set(decomposition,number_of_domains,err,error,*999)
1470  CALL decomposition_create_finish(decomposition,err,error,*999)
1471 
1472  exits("FIELD_IO_CREATE_DECOMPISTION")
1473  RETURN
1474 999 errorsexits("FIELD_IO_CREATE_DECOMPISTION",err,error)
1475  RETURN 1
1476  END SUBROUTINE field_io_create_decompistion
1477 
1478 
1479  !
1480  !================================================================================================================================
1481  !
1482 
1484  SUBROUTINE field_io_fields_import(NAME, METHOD, REGION, MESH, MESH_USER_NUMBER, DECOMPOSITION, DECOMPOSITION_USER_NUMBER, &
1485  &decomposition_method, field_values_set_type, field_scaling_type, err, error, *)
1486  !Argument variables
1487  TYPE(varying_string), INTENT(IN) :: NAME
1488  TYPE(varying_string), INTENT(IN) :: METHOD
1489  TYPE(region_type), POINTER :: REGION
1490  TYPE(mesh_type), POINTER :: MESH
1491  INTEGER(INTG), INTENT(IN) :: MESH_USER_NUMBER
1492  TYPE(decomposition_type), POINTER :: DECOMPOSITION
1493  INTEGER(INTG), INTENT(IN) :: DECOMPOSITION_USER_NUMBER
1494  INTEGER(INTG), INTENT(IN) :: DECOMPOSITION_METHOD
1495  INTEGER(INTG), INTENT(IN) :: FIELD_VALUES_SET_TYPE
1496  INTEGER(INTG), INTENT(IN) :: FIELD_SCALING_TYPE
1497  !TYPE(BASIS_FUNCTIONS_TYPE), POINTER :: BASES !< bases function
1498  INTEGER(INTG), INTENT(OUT) :: ERR
1499  TYPE(varying_string), INTENT(OUT) :: ERROR
1500  !Local Variables
1501  INTEGER(INTG) :: my_computational_node_number !local process number
1502  INTEGER(INTG) :: computational_node_numbers !total process numbers
1503  INTEGER(INTG) :: MASTER_COMPUTATIONAL_NUMBER !master computational number
1504  INTEGER(INTG) :: NUMBER_OF_FIELDS
1505  INTEGER(INTG) :: NUMBER_OF_EXNODE_FILES
1506  !INTEGER(INTG), ALLOCATABLE :: USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(:)
1507  INTEGER(INTG), ALLOCATABLE :: MESH_COMPONENTS_OF_FIELD_COMPONENTS(:)
1508  INTEGER(INTG), ALLOCATABLE :: COMPONENTS_IN_FIELDS(:)
1509 
1510  enters("FIELD_IO_FIELDS_IMPORT",err,error,*999)
1511 
1512  !Get the number of computational nodes
1513  computational_node_numbers=computational_nodes_number_get(err,error)
1514  IF(err/=0) GOTO 999
1515  !Get my computational node number
1516  my_computational_node_number=computational_node_number_get(err,error)
1517  IF(err/=0) GOTO 999
1518 
1519  master_computational_number=0
1520 
1521  IF(method=="FORTRAN") THEN
1522  CALL field_io_import_global_mesh(name, region, mesh, mesh_user_number, master_computational_number, &
1523  & my_computational_node_number, &!USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER,
1524  &mesh_components_of_field_components, &
1525  & components_in_fields, number_of_fields, number_of_exnode_files, err, error, *999)
1526 
1527  CALL field_io_create_decompistion(decomposition, decomposition_user_number, decomposition_method, mesh, &
1528  &computational_node_numbers, err, error, *999)
1529 
1530  CALL field_io_create_fields(name, region, decomposition, field_values_set_type, number_of_fields, &
1531  !&USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER,
1532  &mesh_components_of_field_components, components_in_fields, &
1533  & number_of_exnode_files, master_computational_number, my_computational_node_number, field_scaling_type, &
1534  & err, error, *999)
1535  ELSE IF(method=="MPIIO") THEN
1536  CALL flagerror("MPI IO has not been implemented",err,error,*999)
1537  ELSE
1538  CALL flagerror("Unknown method!",err,error,*999)
1539  ENDIF
1540 
1541  !IF(ALLOCATED(USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER)) DEALLOCATE(USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER)
1542  CALL checked_deallocate( mesh_components_of_field_components )
1543  CALL checked_deallocate( components_in_fields )
1544  !IF(ALLOCATED(LIST_FIELD_TYPE)) DEALLOCATE(LIST_FIELD_TYPE)
1545 
1546  exits("FIELD_IO_FIELDS_IMPORT")
1547  RETURN
1548 999 errorsexits("FIELD_IO_FIELDS_IMPORT",err,error)
1549  RETURN 1
1550  END SUBROUTINE field_io_fields_import
1551 
1552  !
1553  !================================================================================================================================
1554  !
1555 
1557  SUBROUTINE field_io_fill_basis_info(INTERPOLATION_XI, LIST_STR, NUMBER_OF_COMPONENTS, ERR, ERROR, *)
1558  !Argument variables
1559  INTEGER(INTG), INTENT(INOUT) :: INTERPOLATION_XI(:,:)
1560  TYPE(varying_string), INTENT(INOUT) :: LIST_STR(:)
1561  INTEGER(INTG), INTENT(IN) :: NUMBER_OF_COMPONENTS ! number of components
1562  INTEGER(INTG), INTENT(OUT) :: ERR
1563  TYPE(varying_string), INTENT(OUT) :: ERROR
1564  !Local Variables
1565  TYPE(varying_string) :: LINE, LINE1
1566  INTEGER(INTG) :: idx_comp, pos
1567  INTEGER(INTG) :: num_interp, INTERPOLATION_TYPE
1568 
1569  enters("FIELD_IO_FILL_BASIS_INFO",err,error,*999)
1570 
1571  DO idx_comp=1,number_of_components
1572  num_interp=0
1573  line=list_str(idx_comp)
1574  DO WHILE(verify("*",line)==0)
1575  num_interp=num_interp+1
1576  pos=index(line,"*")
1577  line1=extract(line, 1, pos)
1578  line=remove(line,1,pos)
1579  CALL fieldio_translatelabelintointerpolationtype(interpolation_type, line, err, error, *999)
1580  interpolation_xi(idx_comp, num_interp)=interpolation_type
1581  ENDDO
1582  num_interp=num_interp+1
1583  line1=extract(line, 1, pos)
1584  line=remove(line,1,pos)
1585  CALL fieldio_translatelabelintointerpolationtype(interpolation_type, line, err, error, *999)
1586  interpolation_xi(idx_comp, num_interp)=interpolation_type
1587  ENDDO
1588 
1589  exits("FIELD_IO_FILL_BASIS_INFO")
1590  RETURN
1591 999 errorsexits("FIELD_IO_FILL_BASIS_INFO",err,error)
1592  RETURN 1
1593  END SUBROUTINE field_io_fill_basis_info
1594 
1595 
1596  !
1597  !================================================================================================================================
1598  !
1599 
1601  SUBROUTINE field_io_import_global_mesh(NAME, REGION, MESH, MESH_USER_NUMBER, MASTER_COMPUTATIONAL_NUMBER, &
1602  & my_computational_node_number, &!USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER,
1603  &mesh_components_of_field_components, &
1604  & components_in_fields, number_of_fields, number_of_exnode_files, err, error, *)
1605  !Argument variables
1606  TYPE(varying_string), INTENT(IN):: NAME
1607  TYPE(mesh_type), POINTER :: MESH
1608  TYPE(region_type), POINTER :: REGION
1609  INTEGER(INTG), INTENT(IN) :: MESH_USER_NUMBER
1610  INTEGER(INTG), INTENT(IN) :: MASTER_COMPUTATIONAL_NUMBER
1611  INTEGER(INTG), INTENT(IN) :: my_computational_node_number
1612  !INTEGER(INTG), INTENT(INOUT), ALLOCATABLE :: USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(:)
1613  INTEGER(INTG), INTENT(INOUT), ALLOCATABLE :: MESH_COMPONENTS_OF_FIELD_COMPONENTS(:)
1614  INTEGER(INTG), INTENT(INOUT), ALLOCATABLE :: COMPONENTS_IN_FIELDS(:)
1615  INTEGER(INTG), INTENT(INOUT) :: NUMBER_OF_FIELDS
1616  INTEGER(INTG), INTENT(INOUT) :: NUMBER_OF_EXNODE_FILES
1617  INTEGER(INTG), INTENT(OUT) :: ERR
1618  TYPE(varying_string), INTENT(OUT) :: ERROR
1619  !Local Variables
1620  TYPE(varying_string), ALLOCATABLE :: LIST_STR(:)
1621  TYPE(basis_type), POINTER :: BASIS
1622  TYPE(nodes_type), POINTER :: NODES
1623  TYPE(mesh_elements_type_ptr_type), ALLOCATABLE :: ELEMENTS_PTR(:)
1624  TYPE(varying_string) :: FILE_NAME, FILE_STATUS, LINE
1625  TYPE(varying_string) :: CMISS_KEYWORD_FIELDS, CMISS_KEYWORD_ELEMENT, CMISS_KEYWORD_NODE, CMISS_KEYWORD_COMPONENTS
1626  TYPE(varying_string) :: CMISS_KEYWORD_SHAPE, CMISS_KEYWORD_SCALE_FACTOR_SETS, CMISS_KEYWORD_NODES, CMISS_KEYWORD_SCALE_FACTORS
1627  INTEGER(INTG), PARAMETER :: NUMBER_NODAL_LINES=3, number_scaling_factors_in_line=5
1628  INTEGER(INTG), ALLOCATABLE :: LIST_ELEMENT_NUMBER(:), LIST_ELEMENTAL_NODES(:), LIST_COMP_NODAL_INDEX(:,:)
1629  INTEGER(INTG), ALLOCATABLE :: MESH_COMPONENT_LOOKUP(:,:), INTERPOLATION_XI(:,:), LIST_COMP_NODES(:)!LIST_FIELD_COMPONENTS(:),
1630  INTEGER(INTG), ALLOCATABLE :: USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(:)
1631  INTEGER(INTG) :: FILE_ID, NUMBER_OF_EXELEM_FILES, NUMBER_OF_ELEMENTS, NUMBER_OF_NODES, NUMBER_OF_DIMENSIONS
1632  INTEGER(INTG) :: NUMBER_OF_MESH_COMPONENTS, NUMBER_OF_COMPONENTS, NUMBER_SCALING_FACTOR_LINES
1633  INTEGER(INTG) :: GLOBAL_ELEMENT_NUMBER
1634  INTEGER(INTG) :: MPI_IERROR
1635  INTEGER(INTG) :: SHAPE_INDEX(shape_size)
1636  INTEGER(INTG) :: idx_comp, idx_comp1, pos, idx_node, idx_node1, idx_field, idx_elem, idx_exnode, idx_exelem, number_of_comp
1637  INTEGER(INTG) :: idx_basis, number_of_node, number_of_scalesets, idx_scl, idx_mesh_comp, current_mesh_comp, num_scl,&
1638  & num_scl_line
1639  LOGICAL :: FILE_EXIST, START_OF_ELEMENT_SECTION, FIELD_SECTION, SECTION_START, FILE_END, FILE_OPEN
1640 
1641  enters("FIELD_IO_IMPORT_GLOBAL_MESH",err,error,*999)
1642 
1643  !checking region pointer
1644  IF(.NOT.ASSOCIATED(region)) THEN
1645  CALL flagerror("region is not associated",err,error,*999)
1646  GOTO 999
1647  ENDIF
1648 
1649  !checking mesh pointer
1650  IF(ASSOCIATED(mesh)) THEN
1651  CALL flagerror("mesh is associated, pls release the memory first",err,error,*999)
1652  GOTO 999
1653  ENDIF
1654 
1655  IF(.NOT.region%REGION_FINISHED) THEN
1656  CALL flagerror("region is not finished",err,error,*999)
1657  GOTO 999
1658  ENDIF
1659 
1660  !IF(ASSOCIATED(BASES%BASES)) THEN
1661  ! CALL FlagError("bases are associated, pls release the memory first",ERR,ERROR,*999)
1662  ! GOTO 999
1663  !ENDIF
1664  !BASES%NUMBER_BASIS_FUNCTIONS=0
1665  number_of_dimensions=region%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
1666  file_status="OLD"
1667  cmiss_keyword_shape="Shape. Dimension="//trim(number_to_vstring(number_of_dimensions,"*",err,error))
1668  cmiss_keyword_element="Element:"
1669  cmiss_keyword_components="#Components="
1670  cmiss_keyword_node="Node:"
1671  cmiss_keyword_nodes="#Nodes="
1672  cmiss_keyword_fields="#Fields="
1673  cmiss_keyword_scale_factor_sets="#Scale factor sets="
1674  cmiss_keyword_scale_factors="#Scale factors="
1675 
1676  CALL mesh_create_start(mesh_user_number,region,number_of_dimensions,mesh,err,error,*999)
1677 
1678  !calculate the number of elements, number of fields and number of field components
1679  IF(master_computational_number==my_computational_node_number) THEN
1680 
1681  !the file name has to start from zero in an ascended order without break
1682  idx_exelem=0
1683  idx_elem=0
1684  number_of_components=0
1685  file_name=name//".part"//trim(number_to_vstring(idx_exelem,"*",err,error))//".exelem"
1686  INQUIRE(file=char(file_name), exist=file_exist)
1687  IF(.NOT.file_exist) THEN
1688  CALL flagerror("exelem files can be found, pls check again",err,error,*999)
1689  !GOTO 999
1690  ENDIF
1691  DO WHILE(file_exist)
1692 
1693  file_id=1030+idx_exelem
1694  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
1695  start_of_element_section=.false.
1696  field_section=.false.
1697 
1698  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error,*999)
1699  DO WHILE(.NOT.file_end)
1700 
1701  !check the beginning of element section
1702  IF((.NOT.start_of_element_section).AND.(verify(cmiss_keyword_shape,line)==0)) THEN
1703  start_of_element_section=.true.
1704  ENDIF
1705 
1706  !count how many elements
1707  IF(start_of_element_section.AND.(verify(cmiss_keyword_element,line)==0)) idx_elem=idx_elem+1
1708 
1709  !check whether they have same numbers of fields
1710  IF(start_of_element_section.AND.(verify(cmiss_keyword_fields,line)==0)) THEN
1711  idx_field=0
1712  idx_comp=0
1713  field_section=.true.
1714  pos=index(line,cmiss_keyword_fields)
1715  line=remove(line,1, pos+len_trim(cmiss_keyword_fields)-1)
1716  IF(idx_exelem==0) THEN
1717  number_of_fields=string_to_integer(line, err,error)
1718  ELSE
1719  IF(number_of_fields/=string_to_integer(line, err,error)) THEN
1720  CALL flagerror("find different number of fields in the exelem files",err,error,*999)
1721  !GOTO 999
1722  ENDIF
1723  ENDIF
1724 
1725  IF(.NOT.ALLOCATED(components_in_fields)) THEN
1726  CALL reallocate( components_in_fields, number_of_fields, &
1727  & "can not allocate the memory for outputing components in field", err, error, *999 )
1728  ENDIF
1729  ENDIF !START_OF_ELEMENT_SECTION==.TRUE..AND.VERIFY(CMISS_KEYWORD_FIELDS,LINE)==0
1730 
1731  !check whether they have same numbers of field components
1732  IF(field_section.AND.start_of_element_section.AND.(verify(cmiss_keyword_components,line)==0)) THEN
1733  idx_field=idx_field+1
1734  pos=index(line,cmiss_keyword_components)
1735  line=remove(line,1, pos+len_trim(cmiss_keyword_components)-1)
1736  idx_comp1=string_to_integer(line, err,error)
1737  idx_comp=idx_comp+idx_comp1
1738  IF(idx_field>=number_of_fields) THEN
1739  IF(idx_exelem==0) THEN
1740  number_of_components=idx_comp
1741  components_in_fields(idx_field)=idx_comp
1742  ELSE
1743  IF(number_of_components/=idx_comp) THEN
1744  CALL flagerror("find different total number of components in the exelem files",err,error,*999)
1745  !GOTO 999
1746  ENDIF
1747  ENDIF
1748  field_section=.false.
1749  ENDIF
1750  IF(idx_exelem==0) THEN
1751  components_in_fields(idx_field)=idx_comp1
1752  ELSE
1753  IF(components_in_fields(idx_field)/=idx_comp1) THEN
1754  CALL flagerror("find different number of components in one field in the exelem files",err,error,*999)
1755  !GOTO 999
1756  ENDIF
1757  ENDIF
1758  ENDIF !FIELD_SECTION==.TRUE..AND.START_OF_ELEMENT_SECTION==.TRUE..AND.VERIFY(CMISS_KEYWORD_COMPONENTS,LINE
1759  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error,*999)
1760  ENDDO !(FILE_END==.FALSE.)
1761 
1762  CALL field_io_fortran_file_close(file_id, err,error,*999)
1763  !checking the next file
1764  idx_exelem=idx_exelem+1
1765  file_name=name//".part"//trim(number_to_vstring(idx_exelem,"*",err,error))//".exelem"
1766  INQUIRE(file=char(file_name), exist=file_exist)
1767  ENDDO !FILE_EXIST==.TRUE.
1768  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE," Total number of exelment files = ",idx_exelem, ERR,ERROR,*999)
1769  number_of_elements=idx_elem
1770  number_of_exelem_files=idx_exelem
1771  ENDIF !MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number
1772 
1773  !broadcasting the number of components in each field
1774  CALL mpi_bcast(number_of_fields,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1775  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1776  IF(master_computational_number/=my_computational_node_number) THEN
1777  CALL reallocate( components_in_fields, number_of_fields, &
1778  & "can not allocate the memory for outputing components in field", err, error, *999 )
1779  !IF(ALLOCATED(LIST_FIELD_TYPE)) DEALLOCATE(LIST_FIELD_TYPE)
1780  !ALLOCATE(LIST_FIELD_TYPE(NUMBER_OF_FIELDS), STAT=ERR)
1781  !IF(ERR/=0) CALL FlagError("can not allocate the memory for list of field types",ERR,ERROR,*999)
1782  !LIST_FIELD_TYPE(:)=0
1783  ENDIF
1784  CALL mpi_bcast(components_in_fields,number_of_fields,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1785  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1786  !CALL MPI_BCAST(LIST_FIELD_TYPE,NUMBER_OF_FIELDS,MPI_INTEGER,MASTER_COMPUTATIONAL_NUMBER,MPI_COMM_WORLD,MPI_IERROR)
1787  !CALL MPI_ERROR_CHECK("MPI_BCAST",MPI_IERROR,ERR,ERROR,*999)
1788  !broadcasting the number of elements
1789  CALL mpi_bcast(number_of_elements,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1790  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1791  CALL mesh_number_of_elements_set(mesh,number_of_elements,err,error,*999)
1792 
1793  !calculate the number of nodes
1794  IF(master_computational_number==my_computational_node_number) THEN
1795  !the file name has to start from zero in a ascended order without break
1796  idx_exnode=0
1797  idx_node=0
1798  file_name=name//".part"//trim(number_to_vstring(idx_exnode,"*",err,error))//".exnode"
1799  INQUIRE(file=char(file_name), exist=file_exist)
1800  IF(.NOT.file_exist) THEN
1801  CALL flagerror("exnode files can be found, pls check again",err,error,*999)
1802  !GOTO 999
1803  ENDIF
1804  DO WHILE(file_exist)
1805  file_id=1030+idx_exnode
1806  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
1807  file_end=.false.
1808 
1809  DO WHILE(.NOT.file_end)
1810  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1811  IF((.NOT.file_end).AND.verify(cmiss_keyword_node,line)==0) idx_node=idx_node+1
1812  ENDDO !(FILE_END==.FALSE.)
1813 
1814  CALL field_io_fortran_file_close(file_id, err,error,*999)
1815  !checking the next file
1816  idx_exnode=idx_exnode+1
1817  file_name=name//".part"//trim(number_to_vstring(idx_exnode,"*",err,error))//".exnode"
1818  INQUIRE(file=char(file_name), exist=file_exist)
1819  ENDDO !FILE_EXIST==.TRUE.
1820  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE," Total number of exnode files = ",idx_exnode, ERR,ERROR,*999)
1821  number_of_nodes=idx_node
1822  number_of_exnode_files=idx_exnode
1823  ENDIF !MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number
1824 
1825  CALL mpi_bcast(number_of_exnode_files,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1826  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1827  !broadcasting the number of nodes
1828  CALL mpi_bcast(number_of_nodes,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
1829  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1830  NULLIFY(nodes)
1831  CALL nodes_create_start(region,number_of_nodes,nodes,err,error,*999)
1832 
1833  !collect the nodal numberings (nodal labels) to change the nodal user number by reading exnode files
1834  CALL reallocate( user_nodal_number_map_global_nodal_number, number_of_nodes, &
1835  & "can not allocate list of nodal number.", err, error, *999 )
1836  IF(master_computational_number==my_computational_node_number) THEN
1837  !the file name has to start from zero in a ascended order without break
1838  idx_node=1
1839  DO idx_exnode=0, number_of_exnode_files-1
1840  file_id=1030+idx_exnode
1841  file_name=name//".part"//trim(number_to_vstring(idx_exnode,"*",err,error))//".exnode"
1842  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
1843  file_end=.false.
1844  DO WHILE(.NOT.file_end)
1845  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1846  IF((.NOT.file_end).AND.verify(cmiss_keyword_node,line)==0) THEN
1847  pos=index(line,cmiss_keyword_node)
1848  line=remove(line,1, pos+len_trim(cmiss_keyword_node)-1)
1849  user_nodal_number_map_global_nodal_number(idx_node)=string_to_integer(line, err, error)
1850  idx_node=idx_node+1
1851  ENDIF !VERIFY(CMISS_KEYWORD,LINE)==0
1852  ENDDO !(FILE_END==.FALSE.)
1853  CALL field_io_fortran_file_close(file_id, err,error,*999)
1854  ENDDO !FILE_EXIST==.TRUE.
1855  CALL list_sort(user_nodal_number_map_global_nodal_number, err, error, *999)
1856  ENDIF !MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number
1857 
1858  !broadcast the nodal numberings (nodal labels)
1859  CALL mpi_bcast(user_nodal_number_map_global_nodal_number,number_of_nodes,mpi_integer,master_computational_number, &
1860  & mpi_comm_world,mpi_ierror)
1861  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
1862  DO idx_node=1, number_of_nodes
1863  IF(idx_node/=user_nodal_number_map_global_nodal_number(idx_node)) CALL nodes_user_number_set(nodes,idx_node, &
1864  & user_nodal_number_map_global_nodal_number(idx_node),err,error,*999)
1865  ENDDO
1866  CALL nodes_create_finish(nodes,err,error,*999)
1867  CALL checked_deallocate( user_nodal_number_map_global_nodal_number )
1868 
1869  !IF(ALLOCATED(USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER)) DEALLOCATE(USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER)
1870  !ALLOCATE(USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(NUMBER_OF_NODES), STAT=ERR)
1871  !IF(ERR/=0) CALL FlagError("can not allocate nodal number mapping for output",ERR,ERROR,*999)
1872  !USER_NODAL_NUMBER_MAP_GLOBAL_NODAL_NUMBER(:)=LIST_NODAL_NUMBER(:)
1873  !IF(ALLOCATED(LIST_NODAL_NUMBER)) DEALLOCATE(LIST_NODAL_NUMBER)
1874 
1875  !calculate the number of mesh components
1876  IF(master_computational_number==my_computational_node_number) THEN
1877 
1878  !MESH_COMPONENT_LOOKUP is used to store the difference between field components in term of basis property.
1879  CALL reallocate_2d( mesh_component_lookup, number_of_components, number_of_components, &
1880  & "can not allocate list of mesh components", err, error, *999 )
1881 
1882  CALL reallocate( list_str, number_of_components, &
1883  & "can not allocate list of str", err, error, *999 )
1884  !initialize MESH_COMPONENT_LOOKUP and assume each field component has the same mesh component
1885 
1886  DO idx_comp=1,number_of_components
1887  mesh_component_lookup(idx_comp,idx_comp)=1
1888  ENDDO
1889  idx_exelem=0
1890 
1891  !checking field component's mesh component by checking the basis
1892  DO WHILE(idx_exelem<number_of_exelem_files)
1893 
1894  file_id=1030+idx_exelem
1895  !checking the next file
1896  file_name=name//".part"//trim(number_to_vstring(idx_exelem,"*",err,error))//".exelem"
1897  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
1898  field_section=.false.
1899  file_end=.false.
1900 
1901  DO WHILE(.NOT.file_end)
1902  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1903 
1904  !check the beginning of element section
1905  IF((.NOT.start_of_element_section).AND.(verify(cmiss_keyword_shape,line)==0)) THEN
1906  start_of_element_section=.true.
1907  ENDIF
1908 
1909  !check whether it is a new header for another group of elements
1910  IF(start_of_element_section.AND.(verify(cmiss_keyword_fields,line)==0)) THEN
1911 
1912  !collect header information
1913  pos=index(line,cmiss_keyword_fields)
1914  line=remove(line,1, pos+len_trim(cmiss_keyword_fields)-1)
1915  number_of_fields=string_to_integer(line, err,error)
1916  idx_comp=0
1917  DO idx_field=1,number_of_fields
1918  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1919  pos=index(line,cmiss_keyword_components)
1920  line=remove(line,1, pos+len_trim(cmiss_keyword_components)-1)
1921  number_of_comp=string_to_integer(line, err,error)
1922  DO idx_comp1=1,number_of_comp
1923  idx_comp=idx_comp+1
1924  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1925  pos=index(line,".")
1926  line=remove(line,1, pos)
1927  line=trim(adjustl(line))
1928  pos=index(line,",")
1929  line=remove(line,pos, len(line))
1930  list_str(idx_comp)= line
1931  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1932  pos=index(line, cmiss_keyword_nodes)
1933  line=remove(line,1, pos+len_trim(cmiss_keyword_nodes)-1)
1934  number_of_node=string_to_integer(line, err,error)
1935  DO idx_node1=1, number_of_node*number_nodal_lines
1936  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
1937  ENDDO !idx_node1
1938  ENDDO !idx_comp1
1939  ENDDO !idx_field
1940 
1941  !compare the bases. Since the geometrical topology is same, if the bases are the same in the same topology,
1942  !they should be in the same mesh component
1943  IF(sum(mesh_component_lookup)<number_of_components*number_of_components) THEN
1944  DO idx_comp=1, number_of_components
1945  DO idx_comp1=idx_comp+1, number_of_components
1946  IF(mesh_component_lookup(idx_comp1,idx_comp)==0) THEN
1947  IF(list_str(idx_comp1)/=list_str(idx_comp)) THEN
1948  mesh_component_lookup(idx_comp1,idx_comp)=1
1949  mesh_component_lookup(idx_comp,idx_comp1)=1
1950  ENDIF
1951  ENDIF
1952  ENDDO !idx_comp1
1953  ENDDO !idx_comp
1954  ELSE
1955  idx_exelem=number_of_exelem_files !jump out of the loop
1956  ENDIF
1957  ENDIF !START_OF_ELEMENT_SECTION==.TRUE..AND.VERIFY(CMISS_KEYWORD_FIELDS,LINE)==0
1958 
1959  !!check whether they have same numbers of field components
1960  !IF(FIELD_SECTION==.TRUE..AND.START_OF_ELEMENT_SECTION==.TRUE..AND.(VERIFY(CMISS_KEYWORD_COMPONENTS,LINE)==0)) THEN
1961  ! IF(idx_field>=NUMBER_OF_FIELDS) THEN
1962  ! FIELD_SECTION=.FALSE.
1963  ! ENDIF
1964  !ENDIF !FIELD_SECTION==.TRUE..AND.START_OF_ELEMENT_SECTION==.TRUE..AND.VERIFY(CMISS_KEYWORD_COMPONENTS,LINE
1965  ENDDO !(FILE_END==.FALSE.)
1966  CALL field_io_fortran_file_close(file_id, err,error,*999)
1967  idx_exelem=idx_exelem+1
1968  ENDDO !idx_exelem=0, NUMBER_OF_EXELEM_FILES-1
1969 
1970  !calculate the number of mesh components
1971  CALL reallocate( mesh_components_of_field_components, number_of_components, &
1972  & "can not allocate list of field components", err, error, *999 )
1973 
1974  DO idx_comp=1, number_of_components
1975  mesh_components_of_field_components(idx_comp)=idx_comp
1976  ENDDO
1977  DO idx_comp=1, number_of_components
1978  DO idx_comp1=idx_comp+1, number_of_components
1979  IF(mesh_components_of_field_components(idx_comp)==idx_comp) THEN
1980  IF(mesh_component_lookup(idx_comp1,idx_comp)==0) mesh_components_of_field_components(idx_comp1)=idx_comp
1981  ENDIF
1982  ENDDO !idx_comp1
1983  ENDDO !idx_comp
1984  CALL checked_deallocate( mesh_component_lookup )
1985  number_of_mesh_components=0
1986  idx_comp1=0
1987  DO idx_comp=1,number_of_components
1988  IF(mesh_components_of_field_components(idx_comp)==idx_comp) THEN
1989  idx_comp1=idx_comp1+1
1990  mesh_components_of_field_components(idx_comp)=idx_comp1
1991  number_of_mesh_components=number_of_mesh_components+1
1992  ENDIF
1993  ENDDO
1994  !IF(ALLOCATED(MESH_COMPONENTS_OF_FIELD_COMPONENTS)) DEALLOCATE(MESH_COMPONENTS_OF_FIELD_COMPONENTS)
1995  !ALLOCATE(MESH_COMPONENTS_OF_FIELD_COMPONENTS(NUMBER_OF_COMPONENTS),STAT=ERR)
1996  !IF(ERR/=0) CALL FlagError("can not allocate mesh components of field components for output",ERR,ERROR,*999)
1997  !MESH_COMPONENTS_OF_FIELD_COMPONENTS(:)=LIST_FIELD_COMPONENTS(:)
1998  !ALLOCATE(LIST_MESH_COMPONENTS(NUMBER_OF_MESH_COMPONENTS),STAT=ERR)
1999  !IF(ERR/=0) CALL FlagError("ALLOCATEDcan not allocate list of mesh components",ERR,ERROR,*999)
2000  !idx_comp1=0
2001  !DO idx_comp=1,NUMBER_OF_COMPONENTS
2002  ! IF(LIST_FIELD_COMPONENTS(idx_comp)==idx_comp) THEN
2003  ! idx_comp1=idx_comp1+1
2004  ! LIST_MESH_COMPONENTS(idx_comp1)=idx_comp
2005  ! ENDIF
2006  !ENDDO
2007  ENDIF !MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number
2008 
2009  !broadcasting the number of mesh components
2010  CALL mpi_bcast(number_of_components,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2011  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2012  CALL mpi_bcast(number_of_mesh_components,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2013  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2014  CALL mesh_number_of_components_set(mesh,number_of_mesh_components,err,error,*999)
2015 
2016  CALL reallocate( elements_ptr, number_of_mesh_components, &
2017  & "can not allocate list of mesh element pointers", err, error, *999 )
2018 
2019  IF(basis_functions%NUMBER_BASIS_FUNCTIONS<=0) THEN
2020  CALL basis_create_start(1,basis,err,error,*999)
2021  CALL basis_number_of_xi_set(basis,number_of_dimensions,err,error,*999)
2022  CALL basis_create_finish(basis,err,error,*999)
2023  ENDIF
2024 
2025  DO idx_comp=1, number_of_mesh_components
2026  CALL mesh_topology_elements_create_start(mesh,idx_comp,basis_functions%BASES(1)%PTR,elements_ptr(idx_comp)%PTR, &
2027  & err,error,*999)
2028  ENDDO
2029 
2030  !Collect the elemental numberings (elemental labels)
2031  CALL reallocate( list_element_number, number_of_elements, &
2032  & "can not allocate list of elemental number", err, error, *999 )
2033 
2034  IF(master_computational_number==my_computational_node_number) THEN
2035  !the file name has to start from zero in a ascended order without break
2036  idx_elem=1
2037  DO idx_exelem=0, number_of_exelem_files-1
2038 
2039  file_id=1030+idx_exelem
2040  file_name=name//".part"//trim(number_to_vstring(idx_exelem,"*",err,error))//".exelem"
2041  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
2042  start_of_element_section=.false.
2043  file_end=.false.
2044 
2045 
2046  DO WHILE(.NOT.file_end)
2047  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2048 
2049  IF((.NOT.start_of_element_section).AND.(verify(cmiss_keyword_shape,line)==0)) THEN
2050  start_of_element_section=.true.
2051  ENDIF
2052 
2053  IF(start_of_element_section.AND.(verify(cmiss_keyword_element,line)==0)) THEN
2054  pos=index(line,cmiss_keyword_element)
2055  line=remove(line,1, pos+len_trim(cmiss_keyword_element)-1)
2056  shape_index(:)=0
2057  CALL string_to_muti_integers_vs(line, shape_size, shape_index(:), err,error, *999)
2058  IF(number_of_dimensions==3) THEN
2059  list_element_number(idx_elem)=shape_index(1)
2060  ELSE IF(number_of_dimensions==2) THEN
2061  list_element_number(idx_elem)=shape_index(2)
2062  ELSE IF(number_of_dimensions==1) THEN
2063  list_element_number(idx_elem)=shape_index(3)
2064  ELSE
2065  CALL flagerror("Non recognized dimension size during reading elemental numbering",err,error,*999)
2066  ENDIF
2067  idx_elem=idx_elem+1
2068  ENDIF
2069  ENDDO !(FILE_END==.FALSE.)
2070 
2071  CALL field_io_fortran_file_close(file_id, err,error,*999)
2072  ENDDO !idx_exelem=0
2073  CALL list_sort(list_element_number, err, error, *999)
2074  ENDIF !MASTER_COMPUTATIONAL_NUMBER==my_computational_node_number
2075 
2076  !broadcast the list of elements for mapping gloabl numbers and user numbers (elemental labels)
2077  CALL mpi_bcast(list_element_number,number_of_elements,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2078  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2079  !change the mapping between global elemental numbering and user elemental numbering
2080 
2081  DO idx_elem=1,number_of_elements
2082  DO idx_comp=1, number_of_mesh_components
2083  IF(idx_elem/=list_element_number(idx_elem)) &
2084  & CALL meshelements_elementusernumberset(idx_elem,list_element_number(idx_elem), &
2085  & elements_ptr(idx_comp)%PTR,err,error,*999)
2086  ENDDO
2087  ENDDO
2088 
2089  !creating topological information for each mesh component
2090  CALL mpi_bcast(number_of_exelem_files,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2091  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2092  !ALLOCATE(LIST_BASES(NUMBER_OF_COMPONENTS),STAT=ERR)
2093  !IF(ERR/=0) CALL FlagError("can not allocate list of bases",ERR,ERROR,*999)
2094 
2095  CALL reallocate( list_comp_nodes, number_of_components, &
2096  & "Could not allocate list of component nodal index ", err, error, *999 )
2097 
2098  file_end=.true.
2099  idx_exelem=-1
2100  file_id=1030
2101 
2102  DO WHILE(idx_exelem<number_of_exelem_files)
2103 
2104  CALL mpi_bcast(file_end,1,mpi_logical,master_computational_number,mpi_comm_world,mpi_ierror)
2105  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2106 
2107  IF(file_end) THEN
2108  idx_exelem=idx_exelem+1
2109  INQUIRE(unit=file_id, opened=file_open)
2110  IF(file_open) CALL field_io_fortran_file_close(file_id, err,error,*999)
2111  IF(idx_exelem>=number_of_exelem_files) EXIT
2112  ENDIF
2113 
2114  !goto the start of mesh part
2115  IF(master_computational_number==my_computational_node_number) THEN
2116 
2117  !IF(FILE_END==.FALSE..AND.START_OF_ELEMENT_SECTION==.FALSE.) THEN
2118  ! !check the beginning of element section
2119  ! DO WHILE(VERIFY(CMISS_KEYWORD_SHAPE,LINE)/=0)
2120  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR,ERROR, *999)
2121  ! ENDDO
2122  ! START_OF_ELEMENT_SECTION=.TRUE.
2123  !ENDIF
2124 
2125  IF(file_end) THEN
2126  file_id=1030+idx_exelem
2127  !checking the next file
2128  file_name=name//".part"//trim(number_to_vstring(idx_exelem,"*",err,error))//".exelem"
2129  CALL field_io_fortran_file_open(file_id, file_name, file_status, err,error,*999)
2130  file_end=.false.
2131  section_start=.false.
2132  start_of_element_section=.false.
2133  ENDIF
2134 
2135 
2136  IF((.NOT.file_end).AND.(.NOT.start_of_element_section)) THEN !..AND.SECTION_START==.FALSE.) THEN
2137  !find a new header
2138  DO WHILE(verify(cmiss_keyword_scale_factor_sets,line)/=0)
2139  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2140  ENDDO
2141  start_of_element_section=.true.
2142  ENDIF
2143 
2144  !have not touched the end
2145  IF((.NOT.file_end).AND.start_of_element_section.AND.(.NOT.section_start)) THEN
2146  section_start=.true.
2147  !CALL WRITE_STRING(GENERAL_OUTPUT_TYPE,LINE,ERR,ERROR,*999)
2148  !CALL WRITE_STRING(GENERAL_OUTPUT_TYPE,FILE_NAME,ERR,ERROR,*999)
2149 
2150  pos=index(line,cmiss_keyword_scale_factor_sets)
2151  line=remove(line,1, pos+len_trim(cmiss_keyword_scale_factor_sets)-1)
2152  number_of_scalesets=string_to_integer(line, err,error)
2153  idx_mesh_comp=1
2154  !skip factors
2155  number_scaling_factor_lines=0
2156  DO idx_scl=1,number_of_scalesets
2157  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2158  pos=index(line,cmiss_keyword_scale_factors)
2159  line=remove(line,1, pos+len_trim(cmiss_keyword_scale_factors)-1)
2160  num_scl=string_to_integer(line, err,error)
2161  num_scl_line=num_scl/number_scaling_factors_in_line
2162  IF(num_scl_line*number_scaling_factors_in_line/=num_scl) num_scl_line=num_scl_line+1
2163  number_scaling_factor_lines=number_scaling_factor_lines+num_scl_line
2164  ENDDO
2165  !skip nodes line
2166  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2167  pos=index(line,cmiss_keyword_nodes)
2168  line=remove(line,1, pos+len_trim(cmiss_keyword_nodes)-1)
2169  number_of_node=string_to_integer(line, err,error)
2170 
2171  CALL reallocate( list_elemental_nodes, number_of_node, &
2172  & "Could not allocate list of elemental nodes", err, error, *999 )
2173  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"number_of_node:",number_of_node,ERR,ERROR,*999)
2174 
2175  CALL reallocate_2d( list_comp_nodal_index, number_of_components,number_of_node, &
2176  & "Could not allocate list of component nodal index ", err, error, *999 )
2177 
2178  !read the header
2179  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2180  pos=index(line,cmiss_keyword_fields)
2181  line=remove(line,1, pos+len_trim(cmiss_keyword_fields)-1)
2182  number_of_fields=string_to_integer(line, err,error)
2183  idx_comp=0
2184  DO idx_field=1,number_of_fields
2185  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2186  pos=index(line,cmiss_keyword_components)
2187  line=remove(line,1, pos+len_trim(cmiss_keyword_components)-1)
2188  number_of_comp=string_to_integer(line, err,error)
2189  DO idx_comp1=1,number_of_comp
2190  idx_comp=idx_comp+1
2191  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2192  pos=index(line,".")
2193  line=remove(line,1, pos)
2194  line=trim(adjustl(line))
2195  pos=index(line,",")
2196  line=remove(line,pos, len(line))
2197  list_str(idx_comp)= line
2198  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2199  pos=index(line, cmiss_keyword_nodes)
2200  line=remove(line,1, pos+len_trim(cmiss_keyword_nodes)-1)
2201  number_of_node=string_to_integer(line, err,error)
2202  list_comp_nodes(idx_comp)=number_of_node
2203  DO idx_node1=1, number_of_node
2204  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2205  pos=index(line, ".")
2206  line=remove(line,pos, len(line))
2207  list_comp_nodal_index(idx_comp,idx_node1)=string_to_integer(line, err,error)
2208  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2209  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2210  ENDDO !idx_node1
2211  ENDDO !idx_comp1
2212  ENDDO !idx_field
2213 
2214  CALL reallocate_2d( interpolation_xi, number_of_components,number_of_dimensions, &
2215  & "Could not allocate list of interpolation types", err, error, *999 )
2216 
2217  CALL field_io_fill_basis_info(interpolation_xi, list_str, number_of_components, err,error,*999)
2218  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2219  !CALL WRITE_STRING(GENERAL_OUTPUT_TYPE,LINE,ERR,ERROR,*999)
2220  ENDIF !FILE_END==.FALSE..AND.START_OF_ELEMENT_SECTION==.TRUE..AND.SECTION_START==.TRUE.
2221 
2222  IF((.NOT.file_end).AND.start_of_element_section.AND.section_start) THEN
2223 
2224  pos=index(line,cmiss_keyword_element)
2225  line=remove(line,1, pos+len_trim(cmiss_keyword_element)-1)
2226  CALL string_to_muti_integers_vs(line, shape_size, shape_index(:), err,error, *999)
2227 
2228 
2229  DO WHILE(verify(cmiss_keyword_node,line)/=0)
2230  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2231  ENDDO
2232 
2233  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2234  CALL string_to_muti_integers_vs(line, number_of_node, list_elemental_nodes, err, error, *999)
2235 
2236  !skip scaling factors
2237  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2238  DO idx_scl=1, number_scaling_factor_lines
2239  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2240  ENDDO
2241 
2242  IF(.NOT.file_end) THEN
2243  CALL field_io_fortran_file_read_string(file_id, line, file_end, err,error, *999)
2244  IF(verify(cmiss_keyword_scale_factor_sets,line)==0) section_start=.true.
2245  ENDIF
2246  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"FILE_END:",FILE_END,ERR,ERROR,*999)
2247  ENDIF
2248  ENDIF !MASTER_COMPUTATIONAL_NUMBER
2249 
2250  CALL mpi_bcast(number_of_node,1,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2251  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2252  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"SIZE LIST_ELEMENTAL_NODES:",SIZE(LIST_ELEMENTAL_NODES),ERR,ERROR,*999)
2253 
2254  IF(master_computational_number/=my_computational_node_number) THEN
2255  CALL reallocate( list_elemental_nodes, number_of_node, &
2256  & "Could not allocate list of elemental nodes", err, error, *999 )
2257  CALL reallocate_2d( list_comp_nodal_index, number_of_components, number_of_node, &
2258  & "Could not allocate list of component nodal index ", err, error, *999 )
2259  CALL reallocate_2d( interpolation_xi, number_of_components,number_of_dimensions, &
2260  & "Could not allocate list of interpolation types", err, error, *999 )
2261  CALL reallocate( mesh_components_of_field_components, number_of_components, &
2262  & "Could not allocate list of mesh components of field", err, error, *999 )
2263  !DO idx_comp=1,NUMBER_OF_COMPONENTS
2264  ! DO idx_dim=1,NUMBER_OF_DIMENSIONS
2265  ! IF(idx_dim==NUMBER_OF_DIMENSIONS) THEN
2266  ! LINE=LIST_STR(idx_comp)
2267  ! ELSE
2268  ! pos=INDEX(LINE,"*")
2269  ! LINE=EXTRACT(LIST_STR(idx_comp),1, pos-1)
2270  ! LIST_STR(idx_comp)=REMOVE(LIST_STR(idx_comp),1,pos)
2271  ! ENDIF
2272  ! CALL FieldIO_TranslateLabelIntoInterpolationType(INTERPOLATION_XI(idx_comp, idx_dim), LINE, ERR, ERROR, *999)
2273  ! ENDDO
2274  !ENDDO
2275  ENDIF !MASTER_COMPUTATIONAL_NUMBER/=my_computational_node_number
2276 
2277  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"LIST_ELEMENTAL_NODES:",LIST_ELEMENTAL_NODES(1),ERR,ERROR,*999)
2278  CALL mpi_bcast(list_elemental_nodes,number_of_node,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2279  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2280  CALL mpi_bcast(list_comp_nodal_index,number_of_node*number_of_components,mpi_integer,master_computational_number, &
2281  & mpi_comm_world,mpi_ierror)
2282  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2283  CALL mpi_bcast(shape_index,shape_size,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2284  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2285  CALL mpi_bcast(list_comp_nodes,number_of_components,mpi_integer,master_computational_number,mpi_comm_world,mpi_ierror)
2286  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2287  CALL mpi_bcast(mesh_components_of_field_components,number_of_components,mpi_integer,master_computational_number, &
2288  & mpi_comm_world,mpi_ierror)
2289  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2290  CALL mpi_bcast(interpolation_xi,number_of_components*number_of_dimensions,mpi_integer,master_computational_number,&
2291  & mpi_comm_world,mpi_ierror)
2292  CALL mpi_error_check("MPI_BCAST",mpi_ierror,err,error,*999)
2293  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"LIST_ELEMENTAL_NODES:",LIST_ELEMENTAL_NODES(1),ERR,ERROR,*999)
2294  current_mesh_comp=1
2295  DO idx_comp=1, number_of_components
2296  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"LIST_ELEMENTAL_NODES:",LIST_ELEMENTAL_NODES(1),ERR,ERROR,*999)
2297  IF(number_of_dimensions==3) THEN
2298  CALL list_search(list_element_number, shape_index(1),global_element_number, err,error,*999)
2299  ELSE IF(number_of_dimensions==2) THEN
2300  CALL list_search(list_element_number, shape_index(2),global_element_number, err,error,*999)
2301  ELSE IF(number_of_dimensions==1) THEN
2302  CALL list_search(list_element_number, shape_index(3),global_element_number, err,error,*999)
2303  ELSE
2304  CALL flagerror("Non recognized dimension size during reading elemental numbering",err,error,*999)
2305  ENDIF
2306 
2307  IF(mesh_components_of_field_components(idx_comp)==current_mesh_comp) THEN
2308  !find out whether the basis has been created
2309  pos=0
2310  DO idx_basis=1, basis_functions%NUMBER_BASIS_FUNCTIONS
2311  IF(sum(basis_functions%BASES(idx_basis)%PTR%INTERPOLATION_XI(:)-interpolation_xi(idx_comp,:))==0) THEN
2312  pos=idx_basis
2313  EXIT
2314  ENDIF
2315  ENDDO
2316 
2317  IF(pos==0) THEN
2318  IF(ASSOCIATED(basis)) NULLIFY(basis)
2319  CALL basis_create_start(basis_functions%NUMBER_BASIS_FUNCTIONS+1,basis,err,error,*999)
2320  CALL basis_number_of_xi_set(basis,number_of_dimensions,err,error,*999)
2321  CALL basis_interpolation_xi_set(basis,interpolation_xi(idx_comp,:),err,error,*999)
2322  CALL basis_create_finish(basis,err,error,*999)
2323  ENDIF
2324 
2325  CALL mesh_topology_elements_element_basis_set(global_element_number,elements_ptr( &
2326  & mesh_components_of_field_components(idx_comp))%PTR,basis,err,error,*999)
2327  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"LIST_ELEMENTAL_NODES:",LIST_ELEMENTAL_NODES(1),ERR,ERROR,*999)
2328  CALL mesh_topology_elements_element_nodes_set(global_element_number,elements_ptr( &
2329  & mesh_components_of_field_components(idx_comp))%PTR,list_elemental_nodes(list_comp_nodal_index(idx_comp,:)), &
2330  & err,error,*999)
2331  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"LIST_ELEMENTAL_NODES:",LIST_ELEMENTAL_NODES(1),ERR,ERROR,*999)
2332  current_mesh_comp=current_mesh_comp+1
2333  ENDIF
2334  ENDDO !idx_comp
2335  !CALL WRITE_STRING_VALUE(GENERAL_OUTPUT_TYPE,"FILE_END:",FILE_END,ERR,ERROR,*999)
2336 
2337  ENDDO !idx_exelem<NUMBER_OF_EXELEM_FILES
2338 
2339  DO idx_comp=1, number_of_mesh_components
2340  CALL mesh_topology_elements_create_finish(elements_ptr(idx_comp)%PTR, err,error,*999)
2341  ENDDO
2342  CALL mesh_create_finish(mesh,err,error,*999)
2343 
2344  CALL checked_deallocate( list_element_number )
2345  CALL checked_deallocate( elements_ptr )
2346  !IF(ALLOCATED(LIST_NODAL_NUMBER)) DEALLOCATE(LIST_NODAL_NUMBER)
2347  CALL checked_deallocate( list_elemental_nodes )
2348  CALL checked_deallocate( list_str )
2349  CALL checked_deallocate( interpolation_xi )
2350  !IF(ALLOCATED(LIST_FIELD_COMPONENTS)) DEALLOCATE(LIST_FIELD_COMPONENTS)
2351  CALL checked_deallocate( mesh_component_lookup )
2352  CALL checked_deallocate( list_comp_nodal_index )
2353  CALL checked_deallocate( list_comp_nodes )
2354  CALL checked_deallocate( user_nodal_number_map_global_nodal_number )
2355  IF(ASSOCIATED(basis)) NULLIFY(basis)
2356 
2357  exits("FIELD_IO_IMPORT_GLOBAL_MESH")
2358  RETURN
2359 999 errorsexits("FIELD_IO_IMPORT_GLOBAL_MESH",err,error)
2360  RETURN 1
2361  END SUBROUTINE field_io_import_global_mesh
2362 
2363  !
2364  !================================================================================================================================
2365  !
2366 
2368  SUBROUTINE fieldio_translatelabelintointerpolationtype(INTERPOLATION, LABEL_TYPE, ERR, ERROR, *)
2369  !Argument variables
2370  INTEGER(INTG), INTENT(INOUT) :: INTERPOLATION
2371  TYPE(varying_string), INTENT(IN) :: LABEL_TYPE
2372  INTEGER(INTG), INTENT(OUT) :: ERR
2373  TYPE(varying_string), INTENT(OUT) :: ERROR
2374  !Local Variables
2375 
2376  enters("FieldIO_TranslateLabelIntoInterpolationType",err,error,*999)
2377 
2378  SELECT CASE(char(label_type))
2379  CASE("l.Lagrange")
2381  CASE("q.Lagrange")
2383  CASE("c.Lagrange")
2385  CASE("c.Hermite")
2386  interpolation=basis_cubic_hermite_interpolation
2387  CASE("LagrangeHermite")
2389  CASE("HermiteLagrange")
2391  CASE DEFAULT
2392  CALL flagerror("Invalid interpolation type",err,error,*999)
2393  END SELECT
2394 
2395  exits("FieldIO_TranslateLabelIntoInterpolationType")
2396  RETURN
2397 999 errorsexits("FieldIO_TranslateLabelIntoInterpolationType",err,error)
2398  RETURN 1
2399 
2401 
2402  !
2403  !================================================================================================================================
2404  !
2405 
2407  SUBROUTINE fieldio_calculatesimplexscaleandnodecounts(BASIS, num_scl, num_node, ERR, ERROR, * )
2408  !Argument variables
2409  TYPE(basis_type), INTENT(IN) :: BASIS
2410  INTEGER(INTG), INTENT(INOUT) :: num_scl
2411  INTEGER(INTG), INTENT(INOUT) :: num_node
2412  INTEGER(INTG), INTENT(OUT) :: ERR
2413  TYPE(varying_string), INTENT(OUT) :: ERROR
2414 
2415  !Local variables
2416  INTEGER(INTG) :: n
2417 
2418  enters("FieldIO_CalculateSimplexScaleAndNodeCounts",err,error,*999)
2419 
2420  IF(basis%NUMBER_OF_XI==0) CALL flagerror("number of xi in the basis is zero",err,error,*999)
2421 
2422  n = basis%NUMBER_OF_XI
2423 
2424  !Simplex-type interpolations must be the same in all xi.
2425  SELECT CASE(basis%INTERPOLATION_XI(1))
2427  num_node = n + 1
2429  num_node = ( n + 1 ) * ( n + 2 ) / 2
2431  num_node = ( n + 1 ) * ( n + 2 ) * ( n + 3 ) / 6
2432  CASE DEFAULT
2433  CALL flagerror( "Invalid interpolation type", err, error, *999 )
2434  END SELECT
2435 
2436  num_scl = num_node
2437 
2438  exits("FieldIO_CalculateSimplexScaleAndNodeCounts")
2439  RETURN
2440 999 errorsexits("FieldIO_CalculateSimplexScaleAndNodeCounts",err,error)
2441  RETURN 1
2443 
2444  !
2445  !================================================================================================================================
2446  !
2448  SUBROUTINE field_io_calculate_tp_scale_and_node_counts(BASIS, num_scl, num_node, ERR, ERROR, * )
2449  !Argument variables
2450  TYPE(basis_type), INTENT(IN) :: BASIS
2451  INTEGER(INTG), INTENT(INOUT) :: num_scl
2452  INTEGER(INTG), INTENT(INOUT) :: num_node
2453  INTEGER(INTG), INTENT(OUT) :: ERR
2454  TYPE(varying_string), INTENT(OUT) :: ERROR
2455  !Local Variables
2456  INTEGER(INTG) :: ni
2457 
2458  enters("FIELD_IO_CALCULATE_TP_SCALE_AND_NODE_COUNTS",err,error,*999)
2459 
2460  IF(basis%NUMBER_OF_XI==0) CALL flagerror("number of xi in the basis is zero",err,error,*999)
2461 
2462  num_scl=1;
2463  num_node=1
2464  DO ni=1,basis%NUMBER_OF_XI
2465  SELECT CASE(basis%INTERPOLATION_XI(ni))
2467  num_scl=num_scl*2
2468  num_node=num_node*2
2470  num_scl=num_scl*3
2471  num_node=num_node*3
2473  num_scl=num_scl*4
2474  num_node=num_node*4
2476  num_scl=num_scl*4
2477  num_node=num_node*2
2479  num_scl=num_scl*3
2480  num_node=num_node*2
2482  num_scl=num_scl*3
2483  num_node=num_node*2
2484  CASE DEFAULT
2485  CALL flagerror( "Invalid interpolation type", err, error, *999 )
2486  END SELECT
2487  ENDDO !ni
2488 
2489  exits("FIELD_IO_CALCULATE_TP_SCALE_AND_NODE_COUNTS")
2490  RETURN
2491 999 errorsexits("FIELD_IO_CALCULATE_TP_SCALE_AND_NODE_COUNTS",err,error)
2492  RETURN 1
2494 
2495  !
2496  !================================================================================================================================
2497  !
2498 
2499  FUNCTION findmylocaldomainnumber( mapping, myComputationalNodeNumber )
2501  INTEGER(INTG), INTENT(IN) :: myComputationalNodeNumber
2502 
2503  INTEGER(INTG) :: FindMyLocalDomainNumber
2504 
2505  INTEGER(INTG) :: domainIndex
2506  INTEGER(INTG) :: myDomainIndex
2507 
2508  DO domainindex = 1, mapping%NUMBER_OF_DOMAINS
2509  IF( mapping%DOMAIN_NUMBER( domainindex ) == mycomputationalnodenumber ) THEN
2510  mydomainindex = domainindex
2511  EXIT
2512  ENDIF
2513  ENDDO
2514 
2515  findmylocaldomainnumber = mapping%LOCAL_NUMBER( mydomainindex )
2516  END FUNCTION findmylocaldomainnumber
2517 
2518  !
2519  !================================================================================================================================
2520  !
2521 
2523  SUBROUTINE fieldio_exportelementalgroupheaderfortran( global_number, MAX_NODE_COMP_INDEX,NUM_OF_SCALING_FACTOR_SETS, &
2524  & list_comp_scale, my_computational_node_number, elementalinfoset, sessionhandle, err,error, *)
2525  !Argument variables
2526  INTEGER(INTG), INTENT(IN) :: global_number
2527  INTEGER(INTG), INTENT(INOUT) :: MAX_NODE_COMP_INDEX
2528  INTEGER(INTG), INTENT(INOUT) :: NUM_OF_SCALING_FACTOR_SETS
2529  INTEGER(INTG), INTENT(INOUT) :: LIST_COMP_SCALE(:)
2530  INTEGER(INTG), INTENT(IN) :: my_computational_node_number
2531  TYPE(field_io_component_info_set), INTENT(INOUT) :: elementalInfoSet
2532  INTEGER(INTG), INTENT(IN) :: sessionHandle
2533  INTEGER(INTG), INTENT(OUT) :: ERR
2534  TYPE(varying_string), INTENT(OUT) :: ERROR
2535  !Local Variables
2536  INTEGER(INTG) :: i,LENGTH
2537  INTEGER(INTG) :: NUMBER_OF_UNIQUE_NODES
2538  CHARACTER(LEN=MAXSTRLEN) :: fvar_name
2539  CHARACTER(LEN=1, KIND=C_CHAR) :: cvar_name(maxstrlen+1)
2540  TYPE(coordinate_system_type), POINTER :: COORDINATE_SYSTEM
2541  TYPE(field_ptr_type), ALLOCATABLE :: listScaleFields(:)
2542  TYPE(field_variable_type), POINTER :: variable_ptr
2543  TYPE(domain_type), POINTER :: componentDomain !The domain mapping to calculate nodal mappings
2544  TYPE(domain_elements_type), POINTER :: DOMAIN_ELEMENTS ! domain nodes
2545  TYPE(domain_element_type), POINTER :: MAX_NODE_ELEMENT
2546  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES,MAX_ELEMENT_DOMAIN_NODES ! domain nodes
2547  TYPE(basis_type), POINTER :: BASIS
2548  TYPE(basis_ptr_type), ALLOCATABLE :: listScaleBases(:)
2549  TYPE(field_variable_component_type), POINTER :: component
2550  INTEGER(INTG), ALLOCATABLE :: GROUP_LOCAL_NUMBER(:), GROUP_SCALE_FACTORS(:)
2551  INTEGER(INTG), ALLOCATABLE :: GROUP_NODE(:), GROUP_VARIABLES(:)
2552  !INTEGER(C_INT), TARGET :: INTERPOLATION_XI(3),ELEMENT_DERIVATIVES(64*64),NUMBER_OF_DERIVATIVES(64), NODE_INDEXES(128)
2553  INTEGER(C_INT), ALLOCATABLE, TARGET :: INTERPOLATION_XI(:),ELEMENT_DERIVATIVES(:),NUMBER_OF_DERIVATIVES(:), NODE_INDEXES(:)
2554  INTEGER(C_INT), ALLOCATABLE, TARGET :: SCALE_INDEXES(:) !Array for holding scale indexes, useful for collapsed nodes.
2555  INTEGER(INTG) :: nn, nx, ny, nz, NodesX, NodesY, NodesZ, mm, NUM_OF_VARIABLES, MAX_NUM_NODES !NUM_OF_NODES
2556  INTEGER(INTG) :: local_number, interpType, NODE_NUMBER, NODE_NUMBER_COUNTER, NODE_NUMBER_COLLAPSED, NUMBER_OF_ELEMENT_NODES
2557  INTEGER(INTG) :: num_scl, num_node, comp_idx, scaleIndex, scaleIndex1, var_idx, derivativeIndex !value_idx field_idx global_var_idx comp_idx1 ny2
2558  INTEGER(INTG) :: NODE_LOCAL_NUMBER,NODE_USER_NUMBER,MAX_ELEMENT_LOCAL_NUMBER,MAX_ELEMENT_USER_NUMBER
2559  LOGICAL :: SAME_SCALING_SET
2560 
2561  enters("FieldIO_ExportElementalGroupHeaderFortran",err,error,*999)
2562 
2563  !SANDER
2564  ALLOCATE(interpolation_xi(3), stat = err)
2565 
2566  !colllect nodal header information for IO first
2567 
2568  !collect maximum number of nodal derivatives, number of fields and variables
2569  num_of_scaling_factor_sets=0
2570  num_of_variables=0
2571  max_num_nodes=0
2572  max_node_comp_index=0
2573  NULLIFY(variable_ptr)
2574 
2575  CALL reallocate( group_local_number, elementalinfoset%NUMBER_OF_COMPONENTS, &
2576  & "Could not allocate GROUP_LOCAL_NUMBER in exelem header", err, error, *999 )
2577  CALL reallocate( listscalebases, elementalinfoset%NUMBER_OF_COMPONENTS, &
2578  & "Could not allocate listScaleBases in exelem header", err, error, *999 )
2579  CALL reallocate( listscalefields, elementalinfoset%NUMBER_OF_COMPONENTS, &
2580  & "Could not allocate listScaleFields in exelem header", err, error, *999 )
2581 
2582  !collect scale factor information
2583  DO comp_idx=1,elementalinfoset%NUMBER_OF_COMPONENTS
2584  !calculate the number of variables
2585  IF (.NOT.ASSOCIATED(variable_ptr, TARGET=elementalinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE)) THEN
2586  num_of_variables=num_of_variables+1
2587  variable_ptr=>elementalinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
2588  ENDIF
2589 
2590  !finding the local numbering through the global to local mapping
2591  componentdomain=>elementalinfoset%COMPONENTS(comp_idx)%PTR%DOMAIN
2592  !get the domain index for this variable component according to my own computional node number
2593  local_number = findmylocaldomainnumber( componentdomain%MAPPINGS%ELEMENTS%GLOBAL_TO_LOCAL_MAP( global_number ),&
2594  & my_computational_node_number )
2595  group_local_number(comp_idx)=local_number
2596  !use local domain information find the out the maximum number of derivatives
2597  domain_elements=>componentdomain%TOPOLOGY%ELEMENTS
2598  domain_nodes=>componentdomain%TOPOLOGY%NODES
2599  basis=>domain_elements%ELEMENTS(local_number)%BASIS
2600  IF(basis%NUMBER_OF_NODES>max_num_nodes) THEN
2601  max_node_comp_index=comp_idx
2602  max_node_element => domain_elements%ELEMENTS(local_number)
2603  max_num_nodes=basis%NUMBER_OF_NODES
2604  max_element_domain_nodes=>componentdomain%TOPOLOGY%NODES
2605  ENDIF
2606  !IF(.NOT.BASIS%DEGENERATE) THEN
2607  IF(comp_idx == 1) THEN
2608  num_of_scaling_factor_sets = num_of_scaling_factor_sets + 1
2609  listscalebases( num_of_scaling_factor_sets )%PTR => basis
2610  listscalefields( num_of_scaling_factor_sets )%PTR => variable_ptr%FIELD
2611  list_comp_scale(comp_idx)=num_of_scaling_factor_sets
2612  ELSE
2613  same_scaling_set=.false.
2614  DO scaleindex1=1, num_of_scaling_factor_sets
2615  IF(basis%GLOBAL_NUMBER == listscalebases(scaleindex1)%PTR%GLOBAL_NUMBER) THEN
2616  IF(variable_ptr%FIELD%SCALINGS%SCALING_TYPE /= listscalefields(scaleindex1)%PTR%SCALINGS%SCALING_TYPE) THEN
2617  CALL flag_warning("Fields "//trim(number_to_vstring(listscalefields(scaleindex1)%PTR%USER_NUMBER,"*",err,error))// &
2618  & " and "//trim(number_to_vstring(variable_ptr%FIELD%USER_NUMBER,"*",err,error))// &
2619  & " have components that use basis number "//trim(number_to_vstring(basis%GLOBAL_NUMBER,"*",err,error))// &
2620  & " but have different scaling types. ",err,error,*999)
2621  ENDIF
2622  IF(variable_ptr%FIELD%SCALINGS%SCALING_TYPE == listscalefields(scaleindex1)%PTR%SCALINGS%SCALING_TYPE) THEN
2623  same_scaling_set=.true.
2624  list_comp_scale(comp_idx)=scaleindex1
2625  EXIT
2626  ENDIF
2627  ENDIF
2628  ENDDO !scaleIndex1
2629  IF(.NOT.same_scaling_set) THEN
2630  num_of_scaling_factor_sets=num_of_scaling_factor_sets+1
2631  listscalebases( num_of_scaling_factor_sets )%PTR => basis
2632  listscalefields( num_of_scaling_factor_sets )%PTR => variable_ptr%FIELD
2633  list_comp_scale(comp_idx)=num_of_scaling_factor_sets
2634  ENDIF
2635  ENDIF
2636  !ENDIF !BASIS%DEGENERATE=.FALSE.
2637  ENDDO !comp_idx
2638  !!Allocate the memory for group of field components
2639  CALL reallocate( group_variables, num_of_variables, &
2640  & "Could not allocate temporary variable buffer in IO", err, error, *999 )
2641 
2642  !!Allocate the memory for group of maximum number of derivatives
2643  CALL reallocate( group_scale_factors, num_of_scaling_factor_sets, &
2644  & "Could not allocate temporary variable buffer in IO", err, error, *999 )
2645 
2646  CALL reallocate( group_node, num_of_scaling_factor_sets, &
2647  & "Could not allocate temporary variable buffer in IO", err, error, *999 )
2648 
2649  !fill information into the group of fields and variables
2650  NULLIFY(variable_ptr)
2651  num_of_variables=0
2652  DO comp_idx=1,elementalinfoset%NUMBER_OF_COMPONENTS
2653  !calculate the number of variables
2654  IF (.NOT.ASSOCIATED(variable_ptr, TARGET=elementalinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE)) THEN
2655  num_of_variables=num_of_variables+1
2656  variable_ptr=>elementalinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
2657  ENDIF
2658  group_variables(num_of_variables)=group_variables(num_of_variables)+1
2659  ENDDO !comp_idx
2660 
2661  DO scaleindex = 1, num_of_scaling_factor_sets
2662  basis => listscalebases( scaleindex )%PTR
2663  IF(.NOT.ASSOCIATED(basis)) THEN
2664  CALL flagerror("Basis is not associated",err,error,*999)
2665  ENDIF
2666 
2667  SELECT CASE( basis%TYPE )
2669  CALL field_io_calculate_tp_scale_and_node_counts(basis, num_scl, num_node, err, error, *999 )
2670  CASE( basis_simplex_type )
2671  CALL fieldio_calculatesimplexscaleandnodecounts(basis, num_scl, num_node, err, error, *999 )
2672  CASE DEFAULT
2673  CALL flagerror("Basis type "//trim(number_to_vstring(basis%TYPE,"*",err,error))//" is invalid or not implemented",&
2674  &err,error,*999)
2675  END SELECT
2676 
2677  group_scale_factors(scaleindex)=num_scl !numer of scale factors in scale factor set
2678  group_node(scaleindex)=num_node !numer of nodes in scale factor set
2679  ENDDO !scaleIndex
2680 
2681  !write out the scale factor set information
2682  err = fieldexport_scalingfactorcount( sessionhandle, num_of_scaling_factor_sets )
2683  IF(err/=0) THEN
2684  CALL flagerror( "File write error during field export", err, error,*999 )
2685  ENDIF
2686 
2687  CALL reallocate(interpolation_xi, basis%NUMBER_OF_XI, &
2688  & "Could not allocate temporary variable buffer in IO", err, error, *999)
2689  CALL reallocate(element_derivatives, sum(group_scale_factors(:)), &
2690  & "Could not allocate temporary variable buffer in IO", err, error, *999)
2691 
2692 
2693  DO scaleindex = 1, num_of_scaling_factor_sets
2694  basis => listscalebases( scaleindex )%PTR
2695  SELECT CASE( basis%TYPE )
2697  !!TEMP
2698  !ERR = FieldExport_ScaleFactors( sessionHandle, basis%NUMBER_OF_XI, C_LOC(basis%INTERPOLATION_XI) );
2699  !!Copy interpolation xi to a temporary array that has the target attribute. gcc bug 38813 prevents using C_LOC with
2700  !!the array directly. nb using a fixed length array here which is dangerous but should suffice for now.
2701  interpolation_xi(1:basis%NUMBER_OF_XI)=basis%INTERPOLATION_XI(1:basis%NUMBER_OF_XI)
2702  err = fieldexport_scalefactors( sessionhandle, basis%NUMBER_OF_XI, c_loc(interpolation_xi), &
2703  & basis%NUMBER_OF_ELEMENT_PARAMETERS );
2704  IF( err /= 0 ) THEN
2705  CALL flagerror( "can not get basis type of lagrange_hermite label" ,err, error, *999 )
2706  ENDIF
2707  CASE DEFAULT
2708  CALL flagerror( "Basis type "//trim(number_to_vstring(basis%TYPE, "*" , err, error ))//" is not implemented",&
2709  &err,error, *999)
2710  END SELECT
2711  ENDDO !scaleIndex
2712 
2713  err = fieldexport_nodecount( sessionhandle, max_num_nodes )
2714  IF(err/=0) THEN
2715  CALL flagerror( "File write error during field export", err, error,*999 )
2716  ENDIF
2717 
2718  err = fieldexport_fieldcount( sessionhandle, num_of_variables )
2719  IF(err/=0) THEN
2720  CALL flagerror( "File write error during field export", err, error,*999 )
2721  ENDIF
2722 
2723  !write out the nodal header
2724  var_idx=0
2725  NULLIFY(variable_ptr)
2726  DO comp_idx=1,elementalinfoset%NUMBER_OF_COMPONENTS
2727  component => elementalinfoset%COMPONENTS(comp_idx)%PTR
2728 
2729  !grouping field variables and components together
2730  IF(.NOT.ASSOCIATED(variable_ptr,TARGET=component%FIELD_VARIABLE)) THEN !different variables
2731  var_idx=var_idx+1
2732  variable_ptr=>component%FIELD_VARIABLE
2733  !write out the field information
2734 
2735  fvar_name = char(variable_ptr%variable_label)
2736  length=len_trim(fvar_name)
2737  DO i=1,length
2738  cvar_name(i)=fvar_name(i:i)
2739  ENDDO !i
2740  cvar_name(length+1)=c_null_char
2741 
2742  IF( variable_ptr%FIELD%TYPE == field_geometric_type .AND. &
2743  & variable_ptr%VARIABLE_TYPE == field_u_variable_type ) THEN
2744  NULLIFY(coordinate_system)
2745  CALL field_coordinate_system_get(variable_ptr%FIELD,coordinate_system,err,error,*999)
2746  err = fieldexport_coordinatevariable( sessionhandle, cvar_name, var_idx, coordinate_system%TYPE, &
2747  & group_variables(var_idx) )
2748  ELSE
2749  err = fieldexport_variable( sessionhandle, cvar_name, var_idx, variable_ptr%FIELD%TYPE, variable_ptr%VARIABLE_TYPE, &
2750  & group_variables(var_idx) )
2751  ENDIF
2752 
2753  IF( err /= 0 ) THEN
2754  CALL flagerror( "File write error during field export", err, error,*999 )
2755  ENDIF
2756  ENDIF
2757 
2758  componentdomain=>component%DOMAIN
2759  domain_elements=>componentdomain%TOPOLOGY%ELEMENTS
2760  basis=>domain_elements%ELEMENTS(group_local_number(comp_idx))%BASIS
2761 
2762  SELECT CASE( basis%TYPE )
2764  CALL field_io_calculate_tp_scale_and_node_counts(basis, num_scl, num_node, err, error, *999 )
2765  CASE( basis_simplex_type )
2766  CALL fieldio_calculatesimplexscaleandnodecounts(basis, num_scl, num_node, err, error, *999 )
2767  CASE DEFAULT
2768  CALL flagerror("Basis type "//trim(number_to_vstring(basis%TYPE,"*",err,error))//" is invalid or not implemented",&
2769  &err,error,*999)
2770  END SELECT
2771  CALL reallocate(number_of_derivatives, num_node, &
2772  & "Could not allocate temporary variable buffer in IO", err, error, *999)
2773  CALL reallocate(scale_indexes, num_scl, &
2774  & "Could not allocate temporary variable buffer in IO", err, error, *999)
2775  CALL reallocate(node_indexes, num_node, &
2776  & "Could not allocate temporary variable buffer in IO", err, error, *999)
2777 
2778  SELECT CASE(component%INTERPOLATION_TYPE)
2779  CASE(field_constant_interpolation)
2780  interptype = 1
2781  CASE(field_element_based_interpolation)
2782  interptype = 2
2783  CASE(field_node_based_interpolation)
2784  interptype = 3
2785  CASE(field_grid_point_based_interpolation)
2786  interptype = 4
2787  CASE(field_gauss_point_based_interpolation)
2788  interptype = 5
2789  CASE(field_data_point_based_interpolation)
2790  interptype = 6
2791  CASE DEFAULT
2792  interptype = 0
2793  END SELECT
2794 
2795  IF(component%INTERPOLATION_TYPE==field_gauss_point_based_interpolation) THEN
2796  !TEMP HACK. Fake gauss point export as regular grid. Use interpolation xi to pass in number of Gauss.
2797  interpolation_xi(1:basis%NUMBER_OF_XI)=basis%QUADRATURE%NUMBER_OF_GAUSS_XI(1:basis%NUMBER_OF_XI)
2798  ELSE
2799  !Copy interpolation xi to a temporary array that has the target attribute. gcc bug 38813 prevents using C_LOC with
2800  !the array directly. nb using a fixed length array here which is dangerous but should suffice for now.
2801  interpolation_xi(1:basis%NUMBER_OF_XI)=basis%INTERPOLATION_XI(1:basis%NUMBER_OF_XI)
2802  ENDIF
2803 
2804  IF( variable_ptr%FIELD%TYPE == field_geometric_type .AND. &
2805  & variable_ptr%VARIABLE_TYPE == field_u_variable_type ) THEN
2806  !!TEMP
2807  !ERR = FieldExport_CoordinateComponent( sessionHandle, variable_ptr%FIELD%REGION%COORDINATE_SYSTEM, &
2808  ! & component%COMPONENT_NUMBER, basis%NUMBER_OF_XI, C_LOC( basis%INTERPOLATION_XI ) )
2809  NULLIFY(coordinate_system)
2810  CALL field_coordinate_system_get(variable_ptr%FIELD,coordinate_system,err,error,*999)
2811  err = fieldexport_coordinatecomponent( sessionhandle, coordinate_system%TYPE, &
2812  & component%COMPONENT_NUMBER,interptype,basis%NUMBER_OF_XI, c_loc( interpolation_xi ))
2813  ELSE
2814  !!TEMP
2815  !ERR = FieldExport_Component( sessionHandle, &
2816  ! & component%COMPONENT_NUMBER, basis%NUMBER_OF_XI, C_LOC( basis%INTERPOLATION_XI ) )
2817  err = fieldexport_component( sessionhandle, &
2818  & component%COMPONENT_NUMBER,interptype,basis%NUMBER_OF_XI, c_loc( interpolation_xi ) )
2819  ENDIF
2820  IF(err/=0) THEN
2821  CALL flagerror( "File write error during field export", err, error,*999 )
2822  ENDIF
2823 
2824  IF( interptype /= 3 .AND. interptype /= 6) THEN
2825  err = fieldexport_elementgridsize( sessionhandle, interptype, basis%NUMBER_OF_XI, c_loc( interpolation_xi ) )
2826  ELSE
2827  ! IF(.NOT.BASIS%DEGENERATE) THEN
2828  IF(list_comp_scale(comp_idx)==1) THEN
2829  scaleindex=0
2830  ELSE
2831  scaleindex= sum(group_scale_factors(1:list_comp_scale(comp_idx)))-1
2832  ENDIF
2833 
2834  ! Fortran numbering instead of c numbering
2835  scaleindex1 = scaleindex + 1
2836 
2837  !!TEMP
2838  ! ERR = FieldExport_NodeScaleIndexes( sessionHandle, BASIS%NUMBER_OF_NODES, C_LOC( BASIS%NUMBER_OF_DERIVATIVES ), &
2839  ! & C_LOC( DOMAIN_ELEMENTS%ELEMENTS(GROUP_LOCAL_NUMBER(comp_idx))%ELEMENT_DERIVATIVES ), scaleIndex )
2840  !!Copy element derivatives etc. to a temporary array that has the target attribute. gcc bug 38813 prevents using C_LOC with
2841  !!the array directly. nb using a fixed length array here which is dangerous but should suffice for now.
2842  !!In order to correctly index the supplied array, the API needs to know in advance the dimensions of the array.
2843  !!To avoid having to pass in an extra 'size' parameter, we unroll the 2d derivative index array into a vector.
2844  derivativeindex = 1
2845  nn=0
2846  node_number=0
2847 
2848  ! For elements with collapsed nodes, the node indexes need to be changed
2849  IF (basis%NUMBER_OF_COLLAPSED_XI>0) THEN
2850  !!$ IF((.NOT.BASIS%COLLAPSED_XI(1).OR.BASIS%COLLAPSED_XI(2).OR.BASIS%COLLAPSED_XI(3)==BASIS_NOT_COLLAPSED)) THEN
2851  !!$ CALL FlagError("Pyramide elements output is not implemented",&
2852  !!$ &ERR,ERROR,*999)
2853 
2854  node_number_counter=0
2855  number_of_unique_nodes = 0
2856  IF(basis%INTERPOLATION_XI(1)>3) THEN
2857  nodesx=2
2858  ELSE
2859  nodesx=basis%INTERPOLATION_XI(1)+1
2860  ENDIF
2861  IF(basis%INTERPOLATION_XI(2)>3) THEN
2862  nodesy=2
2863  ELSE
2864  nodesy=basis%INTERPOLATION_XI(2)+1
2865  ENDIF
2866  IF(basis%INTERPOLATION_XI(3)>3) THEN
2867  nodesz=2
2868  ELSE
2869  nodesz=basis%INTERPOLATION_XI(3)+1
2870  ENDIF
2871 
2872  !The following if-sentences goes through all possible wedge formed elements and renumber the nodes in order to
2873  !attach the node_index and the number of derivatives to the numbering corresponding to not collapsed elements
2874  IF(basis%COLLAPSED_XI(1)==basis_xi_collapsed) THEN
2875  IF(basis%COLLAPSED_XI(2)==basis_collapsed_at_xi0) THEN
2876  DO nz=1,nodesz
2877  DO ny=1,nodesy
2878  DO nx=1,nodesx
2879  nn=nn+1
2880  IF (ny==1) THEN
2881  node_number_collapsed=(nz-1)*nodesx*(nodesy-1)+nz
2882  node_number=node_number_collapsed
2883  ELSE
2884  IF (node_number_counter<node_number_collapsed) THEN
2885  node_number_counter=node_number_collapsed+1
2886  ELSE
2887  node_number_counter=node_number_counter+1
2888  ENDIF
2889  node_number=node_number_counter
2890  ENDIF
2891  node_indexes(nn)=node_number
2892  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
2893  IF(node_number>number_of_unique_nodes) THEN
2894  DO mm=1,number_of_derivatives(nn)
2895  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
2896  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
2897  scale_indexes(derivativeindex)=scaleindex1
2898  derivativeindex=derivativeindex+1
2899  scaleindex1=scaleindex1+1
2900  ENDDO
2901  number_of_unique_nodes=number_of_unique_nodes+1
2902  ELSE
2903  DO mm=1,number_of_derivatives(nn)
2904  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
2905  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
2906  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
2907  & nn-number_of_unique_nodes-2))+mm)
2908  derivativeindex = derivativeindex + 1
2909  ENDDO
2910  ENDIF
2911  ENDDO
2912  ENDDO
2913  ENDDO
2914  ELSE IF(basis%COLLAPSED_XI(2)==basis_collapsed_at_xi1) THEN
2915  DO nz=1,nodesz
2916  DO ny=1,nodesy
2917  DO nx=1,nodesx
2918  nn=nn+1
2919  IF (ny==nodesy) THEN
2920  node_number_collapsed=(nz-1)*nodesx*(nodesy-1)+nodesx*(nodesy-1)+nz
2921  node_number=node_number_collapsed
2922  ELSE
2923  IF (node_number_counter<node_number_collapsed) THEN
2924  node_number_counter=node_number_collapsed+1
2925  ELSE
2926  node_number_counter=node_number_counter+1
2927  ENDIF
2928  node_number=node_number_counter
2929  ENDIF
2930  node_indexes(nn)=node_number
2931  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
2932  IF(node_number>number_of_unique_nodes) THEN
2933  DO mm=1,number_of_derivatives(nn)
2934  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
2935  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
2936  scale_indexes(derivativeindex)=scaleindex1
2937  derivativeindex=derivativeindex+1
2938  scaleindex1=scaleindex1+1
2939  ENDDO
2940  number_of_unique_nodes=number_of_unique_nodes+1
2941  ELSE
2942  DO mm=1,number_of_derivatives(nn)
2943  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
2944  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
2945  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
2946  & nn-number_of_unique_nodes-2))+mm)
2947  derivativeindex = derivativeindex + 1
2948  ENDDO
2949  ENDIF
2950  ENDDO
2951  ENDDO
2952  ENDDO
2953  ELSE IF(basis%COLLAPSED_XI(3)==basis_collapsed_at_xi0) THEN
2954  DO nz=1,nodesz
2955  DO ny=1,nodesy
2956  DO nx=1,nodesx
2957  nn=nn+1
2958  IF (nz==1) THEN
2959  node_number_collapsed=ny
2960  node_number=node_number_collapsed
2961  ELSE
2962  IF (node_number_counter<node_number_collapsed) THEN
2963  node_number_counter=node_number_collapsed+1
2964  ELSE
2965  node_number_counter=node_number_counter+1
2966  ENDIF
2967  node_number=node_number_counter
2968  ENDIF
2969  node_indexes(nn)=node_number
2970  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
2971  IF(node_number>number_of_unique_nodes) THEN
2972  DO mm=1,number_of_derivatives(nn)
2973  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
2974  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
2975  scale_indexes(derivativeindex)=scaleindex1
2976  derivativeindex=derivativeindex+1
2977  scaleindex1=scaleindex1+1
2978  ENDDO
2979  number_of_unique_nodes=number_of_unique_nodes+1
2980  ELSE
2981  DO mm=1,number_of_derivatives(nn)
2982  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
2983  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
2984  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
2985  & nn-number_of_unique_nodes-2))+mm)
2986  derivativeindex = derivativeindex + 1
2987  ENDDO
2988  ENDIF
2989  ENDDO
2990  ENDDO
2991  ENDDO
2992  ELSE IF(basis%COLLAPSED_XI(3)==basis_collapsed_at_xi1) THEN
2993  DO nz=1,nodesz
2994  DO ny=1,nodesy
2995  DO nx=1,nodesx
2996  nn=nn+1
2997  IF (nz==nodesz) THEN
2998  node_number_collapsed=(nodesz-1)*(nodesy*nodesx)+ny
2999  node_number=node_number_collapsed
3000  ELSE
3001  IF (node_number_counter<node_number_collapsed) THEN
3002  node_number_counter=node_number_collapsed+1
3003  ELSE
3004  node_number_counter=node_number_counter+1
3005  ENDIF
3006  node_number=node_number_counter
3007  ENDIF
3008  node_indexes(nn)=node_number
3009  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3010  IF(node_number>number_of_unique_nodes) THEN
3011  DO mm=1,number_of_derivatives(nn)
3012  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3013  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3014  scale_indexes(derivativeindex)=scaleindex1
3015  derivativeindex=derivativeindex+1
3016  scaleindex1=scaleindex1+1
3017  ENDDO
3018  number_of_unique_nodes=number_of_unique_nodes+1
3019  ELSE
3020  DO mm=1,number_of_derivatives(nn)
3021  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3022  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3023  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3024  & nn-number_of_unique_nodes-2))+mm)
3025  derivativeindex = derivativeindex + 1
3026  ENDDO
3027  ENDIF
3028  ENDDO
3029  ENDDO
3030  ENDDO
3031  ENDIF
3032  ELSE IF(basis%COLLAPSED_XI(2)==basis_xi_collapsed) THEN
3033  IF(basis%COLLAPSED_XI(1)==basis_collapsed_at_xi0) THEN
3034  DO nz=1,nodesz
3035  DO ny=1,nodesy
3036  DO nx=1,nodesx
3037  nn=nn+1
3038  IF (ny==1) THEN
3039  node_number_collapsed=(nz-1)*nodesx*(nodesy-1)+nz
3040  node_number=node_number_collapsed
3041  ELSE
3042  IF (node_number_counter<node_number_collapsed) THEN
3043  node_number_counter=node_number_collapsed+1
3044  ELSE
3045  node_number_counter=node_number_counter+1
3046  ENDIF
3047  node_number=node_number_counter
3048  ENDIF
3049  node_indexes(nn)=node_number
3050  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3051  IF(node_number>number_of_unique_nodes) THEN
3052  DO mm=1,number_of_derivatives(nn)
3053  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3054  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3055  scale_indexes(derivativeindex)=scaleindex1
3056  derivativeindex=derivativeindex+1
3057  scaleindex1=scaleindex1+1
3058  ENDDO
3059  number_of_unique_nodes=number_of_unique_nodes+1
3060  ELSE
3061  DO mm=1,number_of_derivatives(nn)
3062  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3063  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3064  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3065  & nn-number_of_unique_nodes-2))+mm)
3066  derivativeindex = derivativeindex + 1
3067  ENDDO
3068  ENDIF
3069  ENDDO
3070  ENDDO
3071  ENDDO
3072  ELSE IF(basis%COLLAPSED_XI(1)==basis_collapsed_at_xi1) THEN
3073  DO nz=1,nodesz
3074  DO ny=1,nodesy
3075  DO nx=1,nodesx
3076  nn=nn+1
3077  IF (ny==nodesy) THEN
3078  node_number=(nz-1)*nodesx*(nodesy-1)+nz+nodesx-1
3079  node_number=node_number_collapsed
3080  ELSE
3081  IF (node_number_counter<node_number_collapsed) THEN
3082  node_number_counter=node_number_collapsed+1
3083  ELSE
3084  node_number_counter=node_number_counter+1
3085  ENDIF
3086  node_number=node_number_counter
3087  ENDIF
3088  node_indexes(nn)=node_number
3089  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3090  IF(node_number>number_of_unique_nodes) THEN
3091  DO mm=1,number_of_derivatives(nn)
3092  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3093  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3094  scale_indexes(derivativeindex)=scaleindex1
3095  derivativeindex=derivativeindex+1
3096  scaleindex1=scaleindex1+1
3097  ENDDO
3098  number_of_unique_nodes=number_of_unique_nodes+1
3099  ELSE
3100  DO mm=1,number_of_derivatives(nn)
3101  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3102  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3103  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3104  & nn-number_of_unique_nodes-2))+mm)
3105  derivativeindex = derivativeindex + 1
3106  ENDDO
3107  ENDIF
3108  ENDDO
3109  ENDDO
3110  ENDDO
3111  ELSE IF(basis%COLLAPSED_XI(3)==basis_collapsed_at_xi0) THEN
3112  DO nz=1,nodesz
3113  DO ny=1,nodesy
3114  DO nx=1,nodesx
3115  nn=nn+1
3116  IF (nz==1) THEN
3117  node_number_collapsed=nx
3118  node_number=node_number_collapsed
3119  ELSE
3120  IF (node_number_counter<node_number_collapsed) THEN
3121  node_number_counter=node_number_collapsed+1
3122  ELSE
3123  node_number_counter=node_number_counter+1
3124  ENDIF
3125  node_number=node_number_counter
3126  ENDIF
3127  node_indexes(nn)=node_number
3128  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3129  IF(node_number>number_of_unique_nodes) THEN
3130  DO mm=1,number_of_derivatives(nn)
3131  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3132  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3133  scale_indexes(derivativeindex)=scaleindex1
3134  derivativeindex=derivativeindex+1
3135  scaleindex1=scaleindex1+1
3136  ENDDO
3137  number_of_unique_nodes=number_of_unique_nodes+1
3138  ELSE
3139  DO mm=1,number_of_derivatives(nn)
3140  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3141  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3142  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3143  & nn-number_of_unique_nodes-2))+mm)
3144  derivativeindex = derivativeindex + 1
3145  ENDDO
3146  ENDIF
3147  ENDDO
3148  ENDDO
3149  ENDDO
3150  ELSE IF(basis%COLLAPSED_XI(3)==basis_collapsed_at_xi1) THEN
3151  DO nz=1,nodesz
3152  DO ny=1,nodesy
3153  DO nx=1,nodesx
3154  nn=nn+1
3155  IF (nz==nodesz) THEN
3156  node_number_collapsed=(nodesz-1)*nodesy*nodesx+nx
3157  node_number=node_number_collapsed
3158  ELSE
3159  IF (node_number_counter<node_number_collapsed) THEN
3160  node_number_counter=node_number_collapsed+1
3161  ELSE
3162  node_number_counter=node_number_counter+1
3163  ENDIF
3164  node_number=node_number_counter
3165  ENDIF
3166  node_indexes(nn)=node_number
3167  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3168  IF(node_number>number_of_unique_nodes) THEN
3169  DO mm=1,number_of_derivatives(nn)
3170  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3171  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3172  scale_indexes(derivativeindex)=scaleindex1
3173  derivativeindex=derivativeindex+1
3174  scaleindex1=scaleindex1+1
3175  ENDDO
3176  number_of_unique_nodes=number_of_unique_nodes+1
3177  ELSE
3178  DO mm=1,number_of_derivatives(nn)
3179  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3180  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3181  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3182  & nn-number_of_unique_nodes-2))+mm)
3183  derivativeindex = derivativeindex + 1
3184  ENDDO
3185  ENDIF
3186  ENDDO
3187  ENDDO
3188  ENDDO
3189  ENDIF
3190  ELSE IF(basis%COLLAPSED_XI(3)==basis_xi_collapsed) THEN
3191  IF(basis%COLLAPSED_XI(1)==basis_collapsed_at_xi0) THEN
3192  DO nz=1,nodesz
3193  DO ny=1,nodesy
3194  DO nx=1,nodesx
3195  nn=nn+1
3196  IF (nx==1) THEN
3197  node_number_collapsed=nodesx*(ny-1)+ny
3198  node_number=node_number_collapsed
3199  ELSE
3200  IF (node_number_counter<node_number_collapsed) THEN
3201  node_number_counter=node_number_collapsed+1
3202  ELSE
3203  node_number_counter=node_number_counter+1
3204  ENDIF
3205  node_number=node_number_counter
3206  ENDIF
3207  node_indexes(nn)=node_number
3208  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3209  IF(node_number>number_of_unique_nodes) THEN
3210  DO mm=1,number_of_derivatives(nn)
3211  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3212  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3213  scale_indexes(derivativeindex)=scaleindex1
3214  derivativeindex=derivativeindex+1
3215  scaleindex1=scaleindex1+1
3216  ENDDO
3217  number_of_unique_nodes=number_of_unique_nodes+1
3218  ELSE
3219  DO mm=1,number_of_derivatives(nn)
3220  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3221  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3222  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3223  & nn-number_of_unique_nodes-2))+mm)
3224  derivativeindex = derivativeindex + 1
3225  ENDDO
3226  ENDIF
3227  ENDDO
3228  ENDDO
3229  ENDDO
3230  ELSE IF(basis%COLLAPSED_XI(1)==basis_collapsed_at_xi1) THEN
3231  DO nz=1,nodesz
3232  DO ny=1,nodesy
3233  DO nx=1,nodesx
3234  nn=nn+1
3235  IF (nx==nodesx) THEN
3236  node_number_collapsed=nodesx*(ny-1)+ny+nodesx-1
3237  node_number=node_number_collapsed
3238  ELSE
3239  IF (node_number_counter<node_number_collapsed) THEN
3240  node_number_counter=node_number_collapsed+1
3241  ELSE
3242  node_number_counter=node_number_counter+1
3243  ENDIF
3244  node_number=node_number_counter
3245  ENDIF
3246  node_indexes(nn)=node_number
3247  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3248  IF(node_number>number_of_unique_nodes) THEN
3249  DO mm=1,number_of_derivatives(nn)
3250  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3251  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3252  scale_indexes(derivativeindex)=scaleindex1
3253  derivativeindex=derivativeindex+1
3254  scaleindex1=scaleindex1+1
3255  ENDDO
3256  number_of_unique_nodes=number_of_unique_nodes+1
3257  ELSE
3258  DO mm=1,number_of_derivatives(nn)
3259  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3260  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3261  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3262  & nn-number_of_unique_nodes-2))+mm)
3263  derivativeindex = derivativeindex + 1
3264  ENDDO
3265  ENDIF
3266  ENDDO
3267  ENDDO
3268  ENDDO
3269  ELSE IF(basis%COLLAPSED_XI(2)==basis_collapsed_at_xi0) THEN
3270  DO nz=1,nodesz
3271  DO ny=1,nodesy
3272  DO nx=1,nodesx
3273  nn=nn+1
3274  IF (ny==1) THEN
3275  node_number_collapsed=nx
3276  node_number=node_number_collapsed
3277  ELSE
3278  IF (node_number_counter<node_number_collapsed) THEN
3279  node_number_counter=node_number_collapsed+1
3280  ELSE
3281  node_number_counter=node_number_counter+1
3282  ENDIF
3283  node_number=node_number_counter
3284  ENDIF
3285  node_indexes(nn)=node_number
3286  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3287  IF(node_number>number_of_unique_nodes) THEN
3288  DO mm=1,number_of_derivatives(nn)
3289  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3290  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3291  scale_indexes(derivativeindex)=scaleindex1
3292  derivativeindex=derivativeindex+1
3293  scaleindex1=scaleindex1+1
3294  ENDDO
3295  number_of_unique_nodes=number_of_unique_nodes+1
3296  ELSE
3297  DO mm=1,number_of_derivatives(nn)
3298  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3299  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3300  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3301  & nn-number_of_unique_nodes-2))+mm)
3302  derivativeindex = derivativeindex + 1
3303  ENDDO
3304  ENDIF
3305  ENDDO
3306  ENDDO
3307  ENDDO
3308  ELSE IF(basis%COLLAPSED_XI(2)==basis_collapsed_at_xi1) THEN
3309  DO nz=1,nodesz
3310  DO ny=1,nodesy
3311  DO nx=1,nodesx
3312  nn=nn+1
3313  IF (ny==nodesy) THEN
3314  node_number_collapsed=nodesx*(nodesy-1)+nx
3315  node_number=node_number_collapsed
3316  ELSE
3317  IF (node_number_counter<node_number_collapsed) THEN
3318  node_number_counter=node_number_collapsed+1
3319  ELSE
3320  node_number_counter=node_number_counter+1
3321  ENDIF
3322  node_number=node_number_counter
3323  ENDIF
3324  node_indexes(nn)=node_number
3325  number_of_derivatives(nn)=basis%NUMBER_OF_DERIVATIVES(node_number)
3326  IF(node_number>number_of_unique_nodes) THEN
3327  DO mm=1,number_of_derivatives(nn)
3328  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3329  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3330  scale_indexes(derivativeindex)=scaleindex1
3331  derivativeindex=derivativeindex+1
3332  scaleindex1=scaleindex1+1
3333  ENDDO
3334  number_of_unique_nodes=number_of_unique_nodes+1
3335  ELSE
3336  DO mm=1,number_of_derivatives(nn)
3337  element_derivatives(derivativeindex)=field_io_element_derivative_index( &
3338  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,node_number,err,error)
3339  scale_indexes(derivativeindex) = scale_indexes(sum(number_of_derivatives(1:node_number+ &
3340  & nn-number_of_unique_nodes-2))+mm)
3341  derivativeindex = derivativeindex + 1
3342  ENDDO
3343  ENDIF
3344  ENDDO
3345  ENDDO
3346  ENDDO
3347  ENDIF
3348  ENDIF
3349  !NODE_NUMBER_COUNTER has counted up to the highest number of nodes in the element
3350  number_of_element_nodes=nn
3351  ! ENDIF
3352  ELSE !Not collapsed nodes
3353  DO nn=1,basis%NUMBER_OF_NODES
3354  number_of_derivatives(nn) = basis%NUMBER_OF_DERIVATIVES(nn)
3355  DO mm=1,number_of_derivatives(nn)
3356  element_derivatives(derivativeindex) = field_io_element_derivative_index( &
3357  & domain_elements%ELEMENTS(group_local_number(comp_idx)),mm,nn,err,error)
3358  scale_indexes(derivativeindex) = scaleindex1
3359  derivativeindex = derivativeindex + 1
3360  scaleindex1 = scaleindex1 + 1
3361  ENDDO !mm
3362  ENDDO !nn
3363 
3364  !Find the local-node index in the element's total node list.
3365  !TODO This assumes nested subsets of nodes, and will therefore break on, e.g., mixed quad and cubic interpolation
3366  DO nn = 1, basis%NUMBER_OF_NODES
3367  DO mm = 1, max_node_element%BASIS%NUMBER_OF_NODES
3368  node_local_number = domain_elements%ELEMENTS( local_number )%ELEMENT_NODES( nn )
3369  node_user_number=domain_elements%DOMAIN%TOPOLOGY%NODES%NODES(node_local_number)%USER_NUMBER
3370  max_element_local_number = max_node_element%ELEMENT_NODES( mm )
3371  max_element_user_number = max_element_domain_nodes%NODES(max_element_local_number)%USER_NUMBER
3372  IF( node_user_number == max_element_user_number ) THEN
3373  node_indexes( nn ) = mm
3374  EXIT
3375  ENDIF
3376  ENDDO !mm
3377  ENDDO !nn
3378  number_of_element_nodes= basis%NUMBER_OF_NODES
3379  ENDIF
3380 
3381 
3382  IF( variable_ptr%FIELD%SCALINGS%SCALING_TYPE == field_no_scaling ) THEN
3383  scale_indexes(:) = -1
3384  ENDIF
3385  err = fieldexport_nodescaleindexes( sessionhandle, number_of_element_nodes, c_loc( number_of_derivatives ), &
3386  & c_loc( element_derivatives ), c_loc( node_indexes ), c_loc( scale_indexes ) )
3387  ! ELSE
3388  ! CALL FlagError("exporting degenerated nodes has not been implemented",ERR,ERROR,*999)
3389  ! ENDIF
3390  ENDIF
3391 
3392  IF(err/=0) THEN
3393  CALL flagerror( "File write error during field export", err, error,*999 )
3394  ENDIF
3395 
3396  ENDDO !comp_idx
3397 
3398  !release temporary memory
3399  CALL checked_deallocate( listscalefields )
3400  CALL checked_deallocate( listscalebases )
3401  CALL checked_deallocate( group_local_number )
3402  CALL checked_deallocate( group_scale_factors )
3403  CALL checked_deallocate( group_node )
3404  CALL checked_deallocate( group_variables )
3405  CALL checked_deallocate( interpolation_xi )
3406  CALL checked_deallocate( element_derivatives )
3407  CALL checked_deallocate( number_of_derivatives )
3408  CALL checked_deallocate( node_indexes )
3409  CALL checked_deallocate( scale_indexes )
3410 
3411 
3412  exits("FieldIO_ExportElementalGroupHeaderFortran")
3413  RETURN
3414 999 errorsexits("FieldIO_ExportElementalGroupHeaderFortran",err,error)
3415  RETURN 1
3417 
3418  !
3419  !================================================================================================================================
3420  !
3421 
3422  SUBROUTINE field_io_export_element_scale_factors( sessionHandle, components, componentScales, globalNumber, &
3423  & mycomputationalnodenumber, err, error, * )
3424  !Argument variables
3425  INTEGER(INTG) :: sessionHandle
3426  TYPE(field_io_component_info_set), INTENT(INOUT) :: components
3427  INTEGER(INTG) :: componentScales(:)
3428  INTEGER(INTG) :: globalNumber
3429  INTEGER(INTG) :: myComputationalNodeNumber
3430  INTEGER(INTG), INTENT(OUT) :: ERR
3431  TYPE(varying_string), INTENT(OUT) :: ERROR
3432 
3433  !Local variables
3434  INTEGER(INTG) :: scaleIndex, componentIndex, localNumber, scaleFactorCount, nodeIndex
3435  INTEGER(INTG) :: nodeNumber, derivativeIndex, nv, nk, ny2, firstScaleSet
3436  TYPE(field_variable_component_type), POINTER :: component
3437  TYPE(domain_elements_type), POINTER :: domainElements
3438  TYPE(domain_nodes_type), POINTER :: domainNodes
3439  TYPE(domain_mapping_type), POINTER :: domainElementMapping
3440  TYPE(basis_type), POINTER :: basis
3441  REAL(C_DOUBLE), ALLOCATABLE, TARGET :: scaleBuffer(:)
3442  REAL(DP), POINTER :: SCALE_FACTORS(:)
3443 
3444  NULLIFY(scale_factors)
3445 
3446  enters("FIELD_IO_EXPORT_ELEMENT_SCALE_FACTORS",err,error,*999)
3447 
3448  scaleindex = 1
3449  firstscaleset = 1
3450  DO componentindex = 1, components%NUMBER_OF_COMPONENTS
3451  component => components%COMPONENTS( componentindex )%PTR
3452  !finding the local numbering through the global to local mapping
3453 
3454  domainelementmapping=>component%DOMAIN%MAPPINGS%ELEMENTS
3455  !get the domain index for this variable component according to my own computional node number
3456 
3457  localnumber = findmylocaldomainnumber( domainelementmapping%GLOBAL_TO_LOCAL_MAP( globalnumber ), &
3458  & mycomputationalnodenumber )
3459  !use local domain information find the out the maximum number of derivatives
3460  domainelements => component%DOMAIN%TOPOLOGY%ELEMENTS
3461  domainnodes => component%DOMAIN%TOPOLOGY%NODES
3462 
3463  !write out the components' values of this node in this domain
3464  !DO scaleIndex=1, NUM_OF_SCALING_FACTOR_SETS
3465  IF( componentscales( componentindex ) == scaleindex ) THEN
3466  scaleindex = scaleindex + 1
3467 
3468  scalefactorcount = 0
3469  basis => domainelements%ELEMENTS( localnumber )%BASIS
3470 
3471  CALL reallocate( scalebuffer, sum( basis%NUMBER_OF_DERIVATIVES(1:basis%NUMBER_OF_NODES ) ), &
3472  & "Could not allocate scale buffer in IO", err, error, *999 )
3473 
3474  IF( component%FIELD_VARIABLE%FIELD%SCALINGS%SCALING_TYPE /= field_no_scaling ) THEN
3475  CALL distributed_vector_data_get(component%FIELD_VARIABLE%FIELD%SCALINGS%SCALINGS(component% &
3476  & scaling_index)%SCALE_FACTORS,scale_factors,err,error,*999)
3477  ENDIF
3478 
3479  !IF( .NOT.basis%DEGENERATE ) THEN
3480  DO nodeindex = 1, basis%NUMBER_OF_NODES
3481  nodenumber = domainelements%ELEMENTS( localnumber )%ELEMENT_NODES( nodeindex )
3482  DO derivativeindex = 1, basis%NUMBER_OF_DERIVATIVES( nodeindex )
3483  nk = domainelements%ELEMENTS( localnumber )%ELEMENT_DERIVATIVES(derivativeindex, nodeindex )
3484  nv = domainelements%ELEMENTS( localnumber )%elementVersions(derivativeindex, nodeindex )
3485  ny2 = domainnodes%NODES( nodenumber )%DERIVATIVES(nk)%DOF_INDEX(nv)
3486  scalefactorcount = scalefactorcount + 1
3487  IF( component%FIELD_VARIABLE%FIELD%SCALINGS%SCALING_TYPE /= field_no_scaling ) THEN
3488  scalebuffer( scalefactorcount ) = scale_factors(ny2)
3489  ELSE
3490  scalebuffer( scalefactorcount ) = 1
3491  ENDIF
3492  ENDDO !derivativeIndex
3493  ENDDO !nodeIndex
3494  !ELSE
3495  !This is just a hack, forcing to write out the correct number of scale factors equal to one!!!!
3496  ! NodesX=BASIS%INTERPOLATION_XI(1)+1
3497  ! NodesY=BASIS%INTERPOLATION_XI(2)+1
3498  ! NodesZ=BASIS%INTERPOLATION_XI(3)+1
3499  ! CALL REALLOCATE( scaleBuffer, (NodesX*NodesY*NodesZ), &
3500  ! & "Could not allocate scale buffer in IO", ERR, ERROR, *999 )
3501  ! DO nz=1,NodesZ
3502  ! DO ny=1,NodesY
3503  ! DO nx=1,NodesX
3504  ! scaleFactorCount=scaleFactorCOUNT+1
3505  ! scaleBuffer( scaleFactorCount ) = 1
3506  ! ENDDO
3507  ! ENDDO
3508  ! ENDDO
3509  !ENDIF
3510 
3511  NULLIFY( scale_factors )
3512 
3513  err = fieldexport_elementnodescales( sessionhandle, firstscaleset, scalefactorcount, c_loc( scalebuffer ) )
3514 
3515  firstscaleset = 0
3516 
3517  IF( err /= 0 ) THEN
3518  CALL flagerror( "Cannot write node scales to file", err, error,*999 )
3519  ENDIF
3520 
3521  ENDIF ! componentScales(componentIndex) == scaleIndex
3522  ENDDO ! componentIndex
3523 
3524  CALL checked_deallocate( scalebuffer )
3525 
3526  exits("FIELD_IO_EXPORT_ELEMENT_SCALE_FACTORS")
3527  RETURN
3528 999 errorsexits("FIELD_IO_EXPORT_ELEMENT_SCALE_FACTORS",err,error)
3529  RETURN 1
3531 
3532  !
3533  !================================================================================================================================
3534  !
3535 
3537  SUBROUTINE field_io_export_elements_into_local_file(ELEMENTAL_INFO_SET, NAME, my_computational_node_number, &
3538  & err, error, *)
3539  !the reason that my_computational_node_number is used in the argument is for future extension
3540  !Argument variables
3541  TYPE(field_io_info_set), INTENT(INOUT) :: ELEMENTAL_INFO_SET
3542  TYPE(varying_string), INTENT(IN) :: NAME
3543  INTEGER(INTG), INTENT(IN):: my_computational_node_number
3544  INTEGER(INTG), INTENT(OUT) :: ERR
3545  TYPE(varying_string), INTENT(OUT) :: ERROR
3546  !Local Variables
3547  INTEGER(INTG) :: sessionHandle
3548  TYPE(coordinate_system_type), POINTER :: COORDINATE_SYSTEM
3549  TYPE(field_variable_component_type), POINTER :: component
3550  TYPE(mesh_element_type), POINTER :: element
3551  TYPE(varying_string) :: FILE_NAME !the prefix name of file.
3552  TYPE(basis_type), POINTER ::BASIS
3553  TYPE(domain_mapping_type), POINTER :: DOMAIN_MAPPING_ELEMENTS !The domain mapping to calculate elemental mappings
3554  TYPE(domain_elements_type), POINTER :: DOMAIN_ELEMENTS ! domain elements
3555  INTEGER(INTG) :: local_number, global_number, MAX_NODE_COMP_INDEX, NUM_DIM
3556  INTEGER(INTG), ALLOCATABLE :: LIST_COMP_SCALE(:), NODAL_NUMBER(:)!LIST_COMP(:) !Components which will be used for export scale factors
3557  INTEGER(C_INT), TARGET :: USER_ELEMENT_NODES(64)
3558  INTEGER(INTG) :: elem_idx, comp_idx, NUM_OF_SCALING_FACTOR_SETS, isFirstValueSet !dev_idx elem_num
3559  REAL(DP), ALLOCATABLE :: SCALE_FACTORS(:)
3560  TYPE(field_io_component_info_set), POINTER :: components
3561  REAL(DP), POINTER :: GEOMETRIC_PARAMETERS(:)
3562  INTEGER(INTG), POINTER :: GEOMETRIC_PARAMETERS_INTG(:)
3563  REAL(DP), ALLOCATABLE :: GEOMETRIC_PARAMETERS_DP(:)
3564 
3565  enters("FIELD_IO_EXPORT_ELEMENTS_INTO_LOCAL_FILE",err,error,*999)
3566 
3567  !is not necessarily equal to numbering of computional node, so use method COMPUTATIONAL_NODE_NUMBER_GET
3568  !will be a secured way to get the number
3569  !my_computational_node_number=COMPUTATIONAL_NODE_NUMBER_GET(ERR,ERROR)
3570  !IF(ERR/=0) GOTO 999
3571  file_name=name//".part"//trim(number_to_vstring(my_computational_node_number,"*",err,error))//".exelem"
3572  num_of_scaling_factor_sets=0
3573 
3574  IF(.NOT.ALLOCATED(elemental_info_set%COMPONENT_INFO_SET)) THEN
3575  CALL flagerror("the elemental information set in input is invalid",err,error,*999)
3576  ENDIF
3577 
3578  IF(.NOT.ALLOCATED(elemental_info_set%LIST_OF_GLOBAL_NUMBER)) THEN
3579  CALL flagerror("the elemental information set is not associated with any numbering list",err,error,*999)
3580  ENDIF
3581 
3582  IF(elemental_info_set%NUMBER_OF_ENTRIES==0) THEN
3583  CALL flagerror("the elemental information set does not contain any nodes",err,error,*999)
3584  ENDIF
3585 
3586  IF(elemental_info_set%COMPONENT_INFO_SET(1)%PTR%SAME_HEADER) THEN
3587  CALL flagerror("the first header flag of elemental information set should be false",err,error,*999)
3588  ENDIF
3589 
3590  !NULLIFY(SCALE_FACTORS)
3591  !NULLIFY(LIST_COMP_SCALE)
3592  !NULLIFY(tmp_components)
3593 
3594  NULLIFY(coordinate_system)
3595  CALL field_coordinate_system_get(elemental_info_set%COMPONENT_INFO_SET(1)%PTR%COMPONENTS(1)%PTR% &
3596  & field_variable%FIELD,coordinate_system,err,error,*999)
3597  num_dim=coordinate_system%NUMBER_OF_DIMENSIONS
3598 
3599  err = fieldexport_opensession( export_type_file, char(file_name)//c_null_char, sessionhandle )
3600  IF(err/=0) THEN
3601  CALL flagerror( "Cannot open file export session", err, error,*999 )
3602  ENDIF
3603 
3604  IF(ASSOCIATED(elemental_info_set%FIELDS%REGION)) THEN
3605  err = fieldexport_group( sessionhandle, char(elemental_info_set%FIELDS%REGION%LABEL)//c_null_char )
3606  ELSE
3607  IF(ASSOCIATED(elemental_info_set%FIELDS%INTERFACE)) THEN
3608  err = fieldexport_group( sessionhandle, char(elemental_info_set%FIELDS%INTERFACE%LABEL)//c_null_char )
3609  ELSE
3610  CALL flagerror("Fields region or interface is not associated.",err,error,*999)
3611  ENDIF
3612  ENDIF
3613  IF(err/=0) THEN
3614  CALL flagerror( "Cannot write group name to elements file", err, error,*999 )
3615  ENDIF
3616 
3617  components => elemental_info_set%COMPONENT_INFO_SET(1)%PTR
3618  component => components%COMPONENTS(1)%PTR
3619  domain_mapping_elements=>component%DOMAIN%MAPPINGS%ELEMENTS
3620  domain_elements=>component%DOMAIN%TOPOLOGY%ELEMENTS
3621  basis => domain_elements%ELEMENTS( 1 )%BASIS
3622 
3623  err = fieldexport_meshdimensions( sessionhandle, basis%NUMBER_OF_XI, basis%TYPE )
3624  IF(err/=0) THEN
3625  CALL flagerror( "Cannot write mesh dimensions to file", err, error,*999 )
3626  ENDIF
3627 
3628  DO elem_idx=1, elemental_info_set%NUMBER_OF_ENTRIES
3629 
3630  components => elemental_info_set%COMPONENT_INFO_SET(elem_idx)%PTR
3631  global_number = elemental_info_set%LIST_OF_GLOBAL_NUMBER(elem_idx)
3632 
3633  IF(.NOT.ALLOCATED(list_comp_scale)) THEN
3634  ALLOCATE(list_comp_scale(components%NUMBER_OF_COMPONENTS),stat=err)
3635  IF(err/=0) CALL flagerror("Could not allocate LIST_COMP_SCALE in exelem io",err,error,*999)
3636  ENDIF
3637 
3638  !check whether need to write out the nodal information header
3639  IF(.NOT.components%SAME_HEADER) THEN
3640  !write out the nodal header
3641  CALL fieldio_exportelementalgroupheaderfortran( global_number, max_node_comp_index, num_of_scaling_factor_sets, &
3642  & list_comp_scale, my_computational_node_number, components, sessionhandle, err, error, *999)
3643  ENDIF
3644 
3645  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3646  !write out elemental information
3647  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3648  !element info
3649  component => components%COMPONENTS(max_node_comp_index)%PTR
3650  element => component%DOMAIN%MESH%TOPOLOGY(component%MESH_COMPONENT_NUMBER)%PTR%ELEMENTS%ELEMENTS(global_number)
3651 
3652  err = fieldexport_elementindex( sessionhandle, num_dim, element%USER_NUMBER )
3653  IF(err/=0) THEN
3654  CALL flagerror( "Cannot write element index to file", err, error,*999 )
3655  ENDIF
3656 
3657  isfirstvalueset = 1
3658  DO comp_idx = 1, components%NUMBER_OF_COMPONENTS
3659  component => components%COMPONENTS(comp_idx)%PTR
3660 
3661  !finding the local numbering through the global to local mapping
3662  domain_mapping_elements=>component%DOMAIN%MAPPINGS%ELEMENTS
3663  domain_elements=>component%DOMAIN%TOPOLOGY%ELEMENTS
3664  !get the domain index for this variable component according to my own computional node number
3665  local_number = findmylocaldomainnumber( domain_mapping_elements%GLOBAL_TO_LOCAL_MAP( global_number ), &
3666  & my_computational_node_number )
3667  !use local domain information find the out the maximum number of derivatives
3668  basis => domain_elements%ELEMENTS( local_number )%BASIS
3669 
3670  IF( component%INTERPOLATION_TYPE == field_element_based_interpolation ) THEN
3671 ! IF( .NOT.ASSOCIATED( component%DOMAIN%TOPOLOGY%ELEMENTS ) ) THEN
3672 ! CYCLE
3673 ! ENDIF
3674  IF(component%FIELD_VARIABLE%DATA_TYPE==field_dp_type) THEN
3675  NULLIFY(geometric_parameters)
3676  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,&
3677  & component%FIELD_VARIABLE%VARIABLE_TYPE,field_values_set_type,geometric_parameters,err,error,*999)
3678  err = fieldexport_elementgridvalues( sessionhandle, isfirstvalueset, 1, &
3679  & geometric_parameters(component%PARAM_TO_DOF_MAP%ELEMENT_PARAM2DOF_MAP%ELEMENTS(local_number)))
3680  ELSE IF(component%FIELD_VARIABLE%DATA_TYPE==field_intg_type) THEN
3681  NULLIFY(geometric_parameters_intg)
3682  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,&
3683  & component%FIELD_VARIABLE%VARIABLE_TYPE,field_values_set_type,geometric_parameters_intg,err,error,*999)
3684  ALLOCATE(geometric_parameters_dp(SIZE(geometric_parameters_intg)))
3685  IF(err/=0) CALL flagerror("Could not allocate geometric parameters dp", err, error,*999 )
3686  geometric_parameters_dp(1:SIZE(geometric_parameters_intg))= &
3687  & REAL(geometric_parameters_intg(1:size(geometric_parameters_intg)))
3688  err = fieldexport_elementgridvalues( sessionhandle, isfirstvalueset, 1, &
3689  & geometric_parameters_dp(component%PARAM_TO_DOF_MAP%ELEMENT_PARAM2DOF_MAP%ELEMENTS(local_number)))
3690  DEALLOCATE(geometric_parameters_dp)
3691  ELSE
3692  CALL flagerror( "Only INTG and REAL data types implemented.", err, error,*999 )
3693  ENDIF
3694  isfirstvalueset = 0
3695  ELSE IF( component%INTERPOLATION_TYPE == field_constant_interpolation ) THEN
3696  IF(component%FIELD_VARIABLE%DATA_TYPE==field_dp_type) THEN
3697  NULLIFY(geometric_parameters)
3698  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,component%FIELD_VARIABLE%VARIABLE_TYPE, &
3699  & field_values_set_type,geometric_parameters,err,error,*999)
3700  err = fieldexport_elementgridvalues( sessionhandle, isfirstvalueset, 1, &
3701  & geometric_parameters(component%PARAM_TO_DOF_MAP%CONSTANT_PARAM2DOF_MAP))
3702  ELSE IF(component%FIELD_VARIABLE%DATA_TYPE==field_intg_type) THEN
3703  NULLIFY(geometric_parameters_intg)
3704  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,component%FIELD_VARIABLE%VARIABLE_TYPE, &
3705  & field_values_set_type,geometric_parameters_intg,err,error,*999)
3706  ALLOCATE(geometric_parameters_dp(SIZE(geometric_parameters_intg)))
3707  IF(err/=0) CALL flagerror("Could not allocate geometric parameters dp", err, error,*999 )
3708  geometric_parameters_dp(1:SIZE(geometric_parameters_intg))= &
3709  & REAL(geometric_parameters_intg(1:size(geometric_parameters_intg)))
3710  err = fieldexport_elementgridvalues( sessionhandle, isfirstvalueset, 1, &
3711  & geometric_parameters_dp(component%PARAM_TO_DOF_MAP%CONSTANT_PARAM2DOF_MAP))
3712  DEALLOCATE(geometric_parameters_dp)
3713  ELSE
3714  CALL flagerror( "Only INTG and REAL data types implemented.", err, error,*999 )
3715  ENDIF
3716  isfirstvalueset = 0
3717  ELSE IF( component%INTERPOLATION_TYPE == field_gauss_point_based_interpolation) THEN
3718  IF(component%FIELD_VARIABLE%DATA_TYPE==field_dp_type) THEN
3719  NULLIFY(geometric_parameters)
3720  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,component%FIELD_VARIABLE%VARIABLE_TYPE, &
3721  & field_values_set_type,geometric_parameters,err,error,*999)
3722  err = fieldexport_elementgridvalues( sessionhandle, isfirstvalueset, basis%QUADRATURE%QUADRATURE_SCHEME_MAP( &
3723  & basis_default_quadrature_scheme)%PTR%NUMBER_OF_GAUSS, &
3724  & geometric_parameters(component%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(1,local_number)))
3725  ELSE IF(component%FIELD_VARIABLE%DATA_TYPE==field_intg_type) THEN
3726  NULLIFY(geometric_parameters_intg)
3727  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,component%FIELD_VARIABLE%VARIABLE_TYPE, &
3728  & field_values_set_type,geometric_parameters_intg,err,error,*999)
3729  ALLOCATE(geometric_parameters_dp(SIZE(geometric_parameters_intg)))
3730  IF(err/=0) CALL flagerror("Could not allocate geometric parameters dp", err, error,*999 )
3731  geometric_parameters_dp(1:SIZE(geometric_parameters_intg))= &
3732  & REAL(geometric_parameters_intg(1:size(geometric_parameters_intg)))
3733  err = fieldexport_elementgridvalues( sessionhandle, isfirstvalueset, basis%QUADRATURE%QUADRATURE_SCHEME_MAP( &
3734  & basis_default_quadrature_scheme)%PTR%NUMBER_OF_GAUSS, &
3735  & geometric_parameters_dp(component%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(1,local_number)))
3736  DEALLOCATE(geometric_parameters_dp)
3737  ELSE
3738  CALL flagerror( "Only INTG and REAL data types implemented.", err, error,*999 )
3739  ENDIF
3740  isfirstvalueset = 0
3741  ENDIF
3742 
3743  IF(err/=0) THEN
3744  CALL flagerror( "Cannot write grid points to nodes file", err, error,*999 )
3745  ENDIF
3746  ENDDO
3747 
3748 
3749  basis=>element%BASIS
3750 
3751 !!TEMP
3752  !ERR = FieldExport_ElementNodeIndices( sessionHandle, BASIS%NUMBER_OF_NODES, C_LOC( element%USER_ELEMENT_NODES ) )
3753 !!Copy user element nodes to a temporary array that has the target attribute. gcc bug 38813 prevents using C_LOC with
3754 !!the array directly. nb using a fixed length array here which is dangerous but should suffice for now.
3755  SELECT CASE(basis%TYPE)
3757  user_element_nodes(1:basis%NUMBER_OF_NODES)=element%USER_ELEMENT_NODES(1:basis%NUMBER_OF_NODES)
3758  CASE(basis_simplex_type)
3759  SELECT CASE(basis%NUMBER_OF_XI)
3760  CASE(1)
3761  user_element_nodes(1:basis%NUMBER_OF_NODES)=element%USER_ELEMENT_NODES(1:basis%NUMBER_OF_NODES)
3762  CASE(2)
3763  SELECT CASE(basis%INTERPOLATION_ORDER(1))
3765  user_element_nodes(1:3)=element%USER_ELEMENT_NODES(1:3)
3767  user_element_nodes(1)=element%USER_ELEMENT_NODES(1)
3768  user_element_nodes(2)=element%USER_ELEMENT_NODES(4)
3769  user_element_nodes(3)=element%USER_ELEMENT_NODES(2)
3770  user_element_nodes(4)=element%USER_ELEMENT_NODES(6)
3771  user_element_nodes(5)=element%USER_ELEMENT_NODES(5)
3772  user_element_nodes(6)=element%USER_ELEMENT_NODES(3)
3774  user_element_nodes(1)=element%USER_ELEMENT_NODES(1)
3775  user_element_nodes(2)=element%USER_ELEMENT_NODES(4)
3776  user_element_nodes(3)=element%USER_ELEMENT_NODES(5)
3777  user_element_nodes(4)=element%USER_ELEMENT_NODES(2)
3778  user_element_nodes(5)=element%USER_ELEMENT_NODES(9)
3779  user_element_nodes(6)=element%USER_ELEMENT_NODES(10)
3780  user_element_nodes(7)=element%USER_ELEMENT_NODES(6)
3781  user_element_nodes(8)=element%USER_ELEMENT_NODES(8)
3782  user_element_nodes(9)=element%USER_ELEMENT_NODES(7)
3783  user_element_nodes(10)=element%USER_ELEMENT_NODES(3)
3784  CASE DEFAULT
3785  CALL flagerror("Invalid basis order.",err,error,*999)
3786  END SELECT
3787  CASE(3)
3788  SELECT CASE(basis%INTERPOLATION_ORDER(1))
3790  user_element_nodes(1:4)=element%USER_ELEMENT_NODES(1:4)
3792  user_element_nodes(1)=element%USER_ELEMENT_NODES(1)
3793  user_element_nodes(2)=element%USER_ELEMENT_NODES(5)
3794  user_element_nodes(3)=element%USER_ELEMENT_NODES(2)
3795  user_element_nodes(4)=element%USER_ELEMENT_NODES(6)
3796  user_element_nodes(5)=element%USER_ELEMENT_NODES(8)
3797  user_element_nodes(6)=element%USER_ELEMENT_NODES(3)
3798  user_element_nodes(7)=element%USER_ELEMENT_NODES(7)
3799  user_element_nodes(8)=element%USER_ELEMENT_NODES(10)
3800  user_element_nodes(9)=element%USER_ELEMENT_NODES(9)
3801  user_element_nodes(10)=element%USER_ELEMENT_NODES(4)
3803  user_element_nodes(1)=element%USER_ELEMENT_NODES(1)
3804  user_element_nodes(2)=element%USER_ELEMENT_NODES(5)
3805  user_element_nodes(3)=element%USER_ELEMENT_NODES(6)
3806  user_element_nodes(4)=element%USER_ELEMENT_NODES(2)
3807  user_element_nodes(5)=element%USER_ELEMENT_NODES(7)
3808  user_element_nodes(6)=element%USER_ELEMENT_NODES(17)
3809  user_element_nodes(7)=element%USER_ELEMENT_NODES(11)
3810  user_element_nodes(8)=element%USER_ELEMENT_NODES(8)
3811  user_element_nodes(9)=element%USER_ELEMENT_NODES(12)
3812  user_element_nodes(10)=element%USER_ELEMENT_NODES(3)
3813  user_element_nodes(11)=element%USER_ELEMENT_NODES(9)
3814  user_element_nodes(12)=element%USER_ELEMENT_NODES(18)
3815  user_element_nodes(13)=element%USER_ELEMENT_NODES(15)
3816  user_element_nodes(14)=element%USER_ELEMENT_NODES(19)
3817  user_element_nodes(15)=element%USER_ELEMENT_NODES(20)
3818  user_element_nodes(16)=element%USER_ELEMENT_NODES(13)
3819  user_element_nodes(17)=element%USER_ELEMENT_NODES(10)
3820  user_element_nodes(18)=element%USER_ELEMENT_NODES(16)
3821  user_element_nodes(19)=element%USER_ELEMENT_NODES(14)
3822  user_element_nodes(20)=element%USER_ELEMENT_NODES(4)
3823  CASE DEFAULT
3824  CALL flagerror("Invalid basis order.",err,error,*999)
3825  END SELECT
3826  CASE DEFAULT
3827  CALL flagerror("Invalid number of xi.",err,error,*999)
3828  END SELECT
3829  CASE DEFAULT
3830  CALL flagerror("Not implemented.",err,error,*999)
3831  END SELECT
3832  err = fieldexport_elementnodeindices( sessionhandle, basis%NUMBER_OF_NODES, c_loc( user_element_nodes ) )
3833  IF(err/=0) THEN
3834  CALL flagerror( "Cannot write node indices to file", err, error,*999 )
3835  ENDIF
3836 
3837  CALL field_io_export_element_scale_factors( sessionhandle, components, &
3838  & list_comp_scale, global_number, my_computational_node_number, err, error, *999 )
3839 
3840  ENDDO !elem_idx
3841 
3842  err = fieldexport_closesession( sessionhandle )
3843  IF(err/=0) THEN
3844  CALL flagerror( "Cannot close element export file", err, error,*999 )
3845  ENDIF
3846  sessionhandle = -1
3847 
3848  !release the temporary memory
3849  CALL checked_deallocate( scale_factors )
3850  CALL checked_deallocate( nodal_number )
3851  CALL checked_deallocate( list_comp_scale )
3852 
3853  exits("FIELD_IO_EXPORT_ELEMENTS_INTO_LOCAL_FILE")
3854  RETURN
3855 999 errorsexits("FIELD_IO_EXPORT_ELEMENTS_INTO_LOCAL_FILE",err,error)
3856  RETURN 1
3858 
3859  !
3860  !================================================================================================================================
3861  !
3862 
3864  SUBROUTINE field_io_elemental_info_set_sort(ELEMENTAL_INFO_SET, my_computational_node_number, ERR,ERROR,*)
3865  !Argument variables
3866  TYPE(field_io_info_set), INTENT(INOUT) :: ELEMENTAL_INFO_SET
3867  INTEGER(INTG), INTENT(IN):: my_computational_node_number
3868  INTEGER(INTG), INTENT(OUT) :: ERR
3869  TYPE(varying_string), INTENT(OUT) :: ERROR
3870  !Local Variables
3871  TYPE(domain_mapping_type), POINTER :: DOMAIN_MAPPING_ELEMENTS !The domain mapping to calculate nodal mappings
3872  TYPE(domain_elements_type), POINTER :: DOMAIN_ELEMENTS1, DOMAIN_ELEMENTS2! domain nodes
3873  INTEGER(INTG) :: global_number1, local_number1, global_number2, local_number2
3874  INTEGER(INTG) :: component_idx, nn1, nn2 ! nn, tmp2, tmp1!temporary variable
3875  INTEGER(INTG) :: node_idx, deriv_idx
3876  TYPE(field_io_component_info_set), POINTER :: tmpInfoSet
3877  LOGICAL :: SAME_ELEMENT_INFO
3878 
3879  !from now on, global numbering are used
3880  enters("FIELD_IO_ELEMENTAL_INFO_SET_SORT",err,error,*999)
3881 
3882  IF(.NOT.ALLOCATED(elemental_info_set%LIST_OF_GLOBAL_NUMBER)) THEN
3883  CALL flagerror("list of global numbering in the input data is invalid",err,error,*999)
3884  ENDIF
3885  IF(.NOT.ALLOCATED(elemental_info_set%COMPONENT_INFO_SET)) THEN
3886  CALL flagerror("nodal information set in the input data is invalid",err,error,*999)
3887  ENDIF
3888 
3889 
3890  !!get my own computianal node number--be careful the rank of process in the MPI pool
3891  !!is not necessarily equal to numbering of computional node, so use method COMPUTATIONAL_NODE_NUMBER_GET
3892  !!will be a secured way to get the number
3893  !my_computational_node_number=COMPUTATIONAL_NODE_NUMBER_GET(ERR,ERROR)
3894  !IF(ERR/=0) GOTO 999
3895 
3896  !group nodal information set according to its components, i.e. put all the nodes with the same components together
3897  !and change the global number in the LIST_OF_GLOBAL_NUMBER
3898  nn1=1
3899  DO WHILE(nn1<elemental_info_set%NUMBER_OF_ENTRIES)
3900  !global number of this node
3901  global_number1=elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn1)
3902  DO nn2=nn1+1,elemental_info_set%NUMBER_OF_ENTRIES
3903  global_number2=elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn2)
3904  IF(elemental_info_set%COMPONENT_INFO_SET(nn1)%PTR%NUMBER_OF_COMPONENTS== &
3905  & elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR%NUMBER_OF_COMPONENTS) THEN
3906  same_element_info=.true.
3907  !we will check the component (type of component, partial derivative).
3908  DO component_idx=1,elemental_info_set%COMPONENT_INFO_SET(nn1)%PTR%NUMBER_OF_COMPONENTS
3909  !not safe, but it is fast
3910  !=============================================================================================!
3911  ! checking according to local memory adddress !
3912  !=============================================================================================!
3913  !are they in the same memory address?
3914  IF(.NOT.ASSOCIATED(elemental_info_set%COMPONENT_INFO_SET(nn1)%PTR%COMPONENTS(component_idx)%PTR, &
3915  &TARGET=elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR%COMPONENTS(component_idx)%PTR)) THEN
3916  same_element_info=.false.
3917  EXIT
3918  ENDIF !ASSCOCIATED
3919 
3920  !! better use this one because it is safe method, but slow
3921  !!=============================================================================================!
3922  !! checking according to the types defined in the openCMISS !
3923  !!=============================================================================================!
3924  !!are they in the same field?
3925  !IF(ELEMENTAL_INFO_SET%COMPONENT_INFO_SET(nn1)%PTR%COMPONENTS(component_idx)%PTR%FIELD%GLOBAL_NUMBER/= &
3926  !&ELEMENTAL_INFO_SET%COMPONENT_INFO_SET(nn2)%PTR%COMPONENTS(component_idx)%PTR%FIELD%GLOBAL_NUMBER) THEN
3927  ! SAME_ELEMENT_INFO=.FALSE.
3928  ! EXIT
3929  !ELSE !GLOBAL_NUBMER
3930  ! !are they the same variable?
3931  ! IF(ELEMENTAL_INFO_SET%COMPONENT_INFO_SET(nn1)%PTR%COMPONENTS(component_idx)%PTR%FIELD_VARIABLE%VARIABLE_NUMBER/= &
3932  ! & ELEMENTAL_INFO_SET%COMPONENT_INFO_SET(nn2)%PTR%COMPONENTS(component_idx)%PTR%FIELD_VARIABLE%VARIABLE_NUMBER) THEN
3933  ! SAME_ELEMENT_INFO=.FALSE.
3934  ! EXIT
3935  ! ELSE !VARIABLE_NUBMER
3936  ! !are they the same component?
3937  ! IF(LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn1)%PTR%COMPONENTS(component_idx)%PTR%COMPONENT_NUMBER/=&
3938  ! &LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn2)%PTR%COMPONENTS(component_idx)%PTR%COMPONENT_NUMBER) THEN
3939  ! SAME_ELEMENT_INFO=.FALSE.
3940  ! EXIT
3941  ! ENDIF !COMPONENT_NUMBER
3942  ! ENDIF ! VARIABLE_NUBMER
3943  !ENDIF !GLOBAL_NUBMER
3944  ENDDO !component_idx
3945 
3946  !check whether correspoding two components have the same partial derivatives
3947  IF(same_element_info) THEN
3948  DO component_idx=1,elemental_info_set%COMPONENT_INFO_SET(nn1)%PTR%NUMBER_OF_COMPONENTS
3949  !finding the local numbering for the NODAL_INFO_SET(nn1)
3950  domain_mapping_elements=>&
3951  & elemental_info_set%COMPONENT_INFO_SET(nn1)%PTR%COMPONENTS(component_idx)%PTR%DOMAIN% &
3952  & mappings%ELEMENTS
3953  !get the domain index for this variable component according to my own computional node number
3954  !local number of nn1'th node in the damain assoicated with component(component_idx)
3955  local_number1 = findmylocaldomainnumber( domain_mapping_elements%GLOBAL_TO_LOCAL_MAP( global_number1 ), &
3956  & my_computational_node_number )
3957  domain_elements1=>&
3958  & elemental_info_set%COMPONENT_INFO_SET(nn1)%PTR%COMPONENTS(component_idx)%PTR% &
3959  & domain%TOPOLOGY%ELEMENTS
3960 
3961  !finding the local numbering for the NODAL_INFO_SET(nn2)
3962  domain_mapping_elements=>&
3963  & elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR%COMPONENTS(component_idx)%PTR% &
3964  & domain%MAPPINGS%ELEMENTS
3965  !get the domain index for this variable component according to my own computional node number
3966  !local number of nn2'th node in the damain assoicated with component(component_idx)
3967  local_number2 = findmylocaldomainnumber( domain_mapping_elements%GLOBAL_TO_LOCAL_MAP( global_number2 ), &
3968  & my_computational_node_number )
3969  domain_elements2=>&
3970  & elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR%COMPONENTS(component_idx)%PTR% &
3971  & domain%TOPOLOGY%ELEMENTS
3972 
3973  !checking whether they have the same basis
3974  IF(domain_elements1%ELEMENTS(local_number1)%BASIS%GLOBAL_NUMBER/=&
3975  &domain_elements2%ELEMENTS(local_number2)%BASIS%GLOBAL_NUMBER) THEN
3976  same_element_info=.false.
3977  EXIT
3978  ENDIF !DOMAIN_ELEMENTS1
3979 
3980  !Check that the elements use the same versions of all derivatives for all element nodes
3981  DO node_idx=1,domain_elements1%ELEMENTS(local_number1)%BASIS%NUMBER_OF_NODES
3982  DO deriv_idx=1,domain_elements1%ELEMENTS(local_number1)%BASIS%NUMBER_OF_DERIVATIVES(node_idx)
3983  IF (domain_elements1%ELEMENTS(local_number1)%elementVersions(deriv_idx,node_idx)/= &
3984  & domain_elements2%ELEMENTS(local_number2)%elementVersions(deriv_idx,node_idx)) THEN
3985  same_element_info=.false.
3986  EXIT
3987  END IF
3988  END DO
3989  END DO
3990 
3991  ENDDO !component_idx
3992  ENDIF !SAME_ELEMENT_INFO==.TRUE.
3993  ENDIF !LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS==LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn+1)%PTR%NUMBER_OF_COMPONENTS
3994 
3995  !find two elements which have the same output, and then they should put together
3996  IF(same_element_info) THEN
3997  tmpinfoset => elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR
3998  elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR => elemental_info_set%COMPONENT_INFO_SET(nn1+1)%PTR
3999  elemental_info_set%COMPONENT_INFO_SET(nn1+1)%PTR => tmpinfoset
4000 
4001  elemental_info_set%COMPONENT_INFO_SET(nn2)%PTR%SAME_HEADER=.false.
4002  elemental_info_set%COMPONENT_INFO_SET(nn1+1)%PTR%SAME_HEADER=.true.
4003 
4004  !exchange the global number
4005  elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn2)=elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn1+1)
4006  elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn1+1)=global_number2
4007 
4008  !increase nn1 to skip the nodes which have the same output
4009  nn1=nn1+1
4010  ENDIF !(SAME_ELEMENT_INFO=.TRUE.)
4011  ENDDO !nn2
4012  !increase the nn1 to check next node
4013  nn1=nn1+1
4014  ENDDO !nn1<LOCAL_PROCESS_NODAL_INFO_SET%NUMBER_OF_ENTRIES
4015 
4016  !order the variable components and group them: X1(1),X1(2),X1(3),X2(2),X2(3),X3(2)....
4017  !DO nn=1,LOCAL_PROCESS_NODAL_INFO_SET%NUMBER_OF_ENTRIES
4018  ! print "(A, I)", "nn=", nn
4019  ! !temporarily use nk, nu here to save memory
4020  ! IF(LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS/=1) THEN
4021  ! component_idx=1
4022  ! DO WHILE(component_idx<LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS)
4023  ! !checking the same variable's components
4024  ! print "(A, I)", "component_idx=", component_idx
4025  ! print "(A, I)", "LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS", LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS
4026  ! DO WHILE(ASSOCIATED(LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(component_idx)%PTR%FIELD_VARIABLE, &
4027  ! & TARGET=LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(component_idx+1)%PTR%FIELD_VARIABLE))
4028  ! component_idx=component_idx+1
4029  ! IF(component_idx>=LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS) THEN
4030  ! EXIT
4031  ! ENDIF
4032  ! ENDDO
4033  !
4034  ! !It may have more than 3 component in the future?!! I do not know,too
4035  ! !so there the components are sorted according their numbering of component
4036  ! !nk and nu are used here temporarily
4037  ! DO tmp1=1,component_idx
4038  ! print "(A, I)", "tmp1=", tmp1
4039  ! SAME_ELEMENT_INFO=.FALSE.
4040  ! DO tmp2=1,(component_idx-tmp1)
4041  ! IF(LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(tmp2)%PTR%COMPONENT_NUMBER>&
4042  ! &LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(tmp2+1)%PTR%COMPONENT_NUMBER) THEN
4043  ! tmp_ptr=>LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(tmp2+1)%PTR
4044  ! LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(tmp2+1)%PTR=>&
4045  ! LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(tmp2)%PTR
4046  !
4047  ! LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(tmp2)%PTR=>tmp_ptr
4048  ! SAME_ELEMENT_INFO=.TRUE.
4049  ! ENDIF
4050  ! ENDDO
4051  ! IF(SAME_ELEMENT_INFO) THEN
4052  ! EXIT
4053  ! ENDIF
4054  ! ENDDO
4055  ! NULLIFY(tmp_ptr)
4056  ! component_idx=component_idx+1
4057  ! ENDDO ! WHILE(component_idx<LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS)
4058  ! ENDIF ! LOCAL_PROCESS_NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS/=1
4059  !ENDDO !nn
4060 
4061  exits("FIELD_IO_ELEMENTAL_INFO_SET_SORT")
4062  RETURN
4063 999 errorsexits("FIELD_IO_ELEMENTAL_INFO_SET_SORT",err,error)
4064  RETURN 1
4065  END SUBROUTINE field_io_elemental_info_set_sort
4066 
4067  !
4068  !================================================================================================================================
4069  !
4070 
4072  SUBROUTINE fieldio_elementalinfosetattachlocalprocess( ELEMENTAL_INFO_SET, FIELDS, ERR, ERROR, * )
4073  !Argument variables
4074  TYPE(field_io_info_set), INTENT(INOUT):: ELEMENTAL_INFO_SET
4075  TYPE(fields_type), POINTER ::FIELDS
4076  INTEGER(INTG), INTENT(OUT):: ERR
4077  TYPE(varying_string), INTENT(OUT) :: ERROR
4078  !Local Variables
4079  LOGICAL :: ININTERFACE,INREGION
4080  TYPE(varying_string) :: LOCAL_ERROR
4081  TYPE(field_type), POINTER :: FIELD
4082  TYPE(domain_mapping_type), POINTER:: DOMAIN_ELEMENTS_MAPPING !nodes in local mapping--it is different as exnode
4083  TYPE(field_variable_type), POINTER:: FIELD_VARIABLE !field variable
4084  INTEGER(INTG) :: num_field, var_idx, component_idx, np, nn !temporary variable
4085  LOGICAL :: foundNewElement
4086 
4087  enters("FieldIO_ElementalInfoSetAttachLocalProcess",err,error,*999)
4088 
4089  !validate the input data
4090  inregion=.false.
4091  ininterface=.false.
4092  IF(ASSOCIATED(fields%REGION)) THEN
4093  inregion=.true.
4094  ELSE
4095  IF(ASSOCIATED(fields%INTERFACE)) THEN
4096  ininterface=.true.
4097  ELSE
4098  CALL flagerror("Fields is not associated with a region or interface.",err,error,*999)
4099  ENDIF
4100  ENDIF
4101 
4102  IF(inregion) THEN
4103  !checking whether the list of fields in the same region
4104  DO num_field =1, fields%NUMBER_OF_FIELDS
4105  IF(.NOT.ASSOCIATED(fields%FIELDS(num_field)%PTR)) THEN
4106  local_error ="No. "//trim(number_to_vstring(num_field,"*",err,error))// &
4107  & " field handle in fields list is invalid"
4108  CALL flagerror(local_error,err,error,*999)
4109  ENDIF
4110 
4111  IF( num_field == 1 ) THEN
4112  cycle
4113  ENDIF
4114 
4115  IF(fields%FIELDS(num_field-1)%PTR%REGION%USER_NUMBER/=fields%FIELDS(num_field)%PTR%REGION%USER_NUMBER) THEN
4116  local_error = "No. "//trim(number_to_vstring(num_field-1,"*",err,error))//" and "// &
4117  & trim(number_to_vstring(num_field,"*",err,error))//" fields are not in the same region"
4118  CALL flagerror(local_error,err,error,*999)
4119  ENDIF
4120  ENDDO
4121  ELSE
4122  !checking whether the list of fields in the same interface
4123  DO num_field =1, fields%NUMBER_OF_FIELDS
4124  IF(.NOT.ASSOCIATED(fields%FIELDS(num_field)%PTR)) THEN
4125  local_error ="No. "//trim(number_to_vstring(num_field,"*",err,error))// &
4126  & " field handle in fields list is invalid"
4127  CALL flagerror(local_error,err,error,*999)
4128  ENDIF
4129 
4130  IF( num_field == 1 ) THEN
4131  cycle
4132  ENDIF
4133 
4134  IF(fields%FIELDS(num_field-1)%PTR%INTERFACE%USER_NUMBER/= &
4135  & fields%FIELDS(num_field)%PTR%INTERFACE%USER_NUMBER) THEN
4136  local_error = "No. "//trim(number_to_vstring(num_field-1,"*",err,error))//" and "// &
4137  & trim(number_to_vstring(num_field,"*",err,error))//" fields are not in the same interface."
4138  CALL flagerror(local_error,err,error,*999)
4139  ENDIF
4140  ENDDO
4141  ENDIF
4142 
4143  elemental_info_set%FIELDS=>fields
4144 
4145  !attache local process to local nodal information set. In current opencmiss system,
4146  !each local process owns it local nodal information, so all we need to do is to fill the nodal
4147  !information set with nodal information of local process
4148  IF((elemental_info_set%NUMBER_OF_ENTRIES/=0).OR.(.NOT.ASSOCIATED(elemental_info_set%FIELDS)) &
4149  & .OR.ALLOCATED(elemental_info_set%COMPONENT_INFO_SET)) THEN
4150  CALL flagerror("nodal information set is not initialized properly, and call start method first", &
4151  & err,error,*999)
4152  ENDIF
4153 
4154  DO num_field=1,elemental_info_set%FIELDS%NUMBER_OF_FIELDS
4155  field=>elemental_info_set%FIELDS%FIELDS(num_field)%PTR
4156  IF(.NOT.ALLOCATED(field%VARIABLES)) THEN
4157  cycle
4158  ENDIF
4159  DO var_idx=1, field%NUMBER_OF_VARIABLES
4160  field_variable=>field%VARIABLES(var_idx)
4161  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
4162  IF(.NOT.ASSOCIATED(field_variable%COMPONENTS(component_idx)%DOMAIN%TOPOLOGY%ELEMENTS)) THEN
4163  cycle
4164  ENDIF
4165 
4166  domain_elements_mapping=>field_variable%COMPONENTS(component_idx)%DOMAIN%MAPPINGS%ELEMENTS
4167  DO np=1,domain_elements_mapping%NUMBER_OF_LOCAL
4168  foundnewelement=.true.
4169  DO nn=1,elemental_info_set%NUMBER_OF_ENTRIES
4170  IF(elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn)==domain_elements_mapping%LOCAL_TO_GLOBAL_MAP(np)) THEN
4171  foundnewelement=.false.
4172  EXIT
4173  ENDIF
4174  ENDDO
4175  !have one more global node
4176  !i hate the codes here, but i have to save the memory
4177  IF(foundnewelement) THEN
4178  CALL grow_array( elemental_info_set%LIST_OF_GLOBAL_NUMBER, 1, &
4179  & "Could not allocate temporary buffer in IO", err, error, *999 )
4180  elemental_info_set%LIST_OF_GLOBAL_NUMBER(elemental_info_set% &
4181  & number_of_entries+1) = domain_elements_mapping%LOCAL_TO_GLOBAL_MAP(np)
4182  elemental_info_set%NUMBER_OF_ENTRIES=elemental_info_set%NUMBER_OF_ENTRIES+1
4183  ENDIF !foundNewElement
4184  ENDDO !np
4185  ENDDO !component_idx
4186  ENDDO !var_idx
4187  ENDDO !num_field
4188 
4189  !allocate the nodal information set and initialize them
4190  ALLOCATE(elemental_info_set%COMPONENT_INFO_SET(elemental_info_set%NUMBER_OF_ENTRIES),stat=err)
4191  IF(err/=0) CALL flagerror("Could not allocate nodal information set",err,error,*999)
4192 
4193  DO nn = 1, elemental_info_set%NUMBER_OF_ENTRIES
4194  ALLOCATE( elemental_info_set%COMPONENT_INFO_SET(nn)%PTR )
4195  elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%SAME_HEADER = .false.
4196  elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS = 0
4197  CALL checked_deallocate( elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS )
4198  ENDDO
4199 
4200  !collect nodal information from local process
4201  DO num_field=1,elemental_info_set%FIELDS%NUMBER_OF_FIELDS
4202  field=>elemental_info_set%FIELDS%FIELDS(num_field)%PTR
4203  IF(.NOT.ALLOCATED(field%VARIABLES)) THEN
4204  cycle
4205  ENDIF
4206  DO var_idx=1, field%NUMBER_OF_VARIABLES
4207  field_variable=>field%VARIABLES(var_idx)
4208  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
4209  IF(.NOT.ASSOCIATED(field_variable%COMPONENTS(component_idx)%DOMAIN%TOPOLOGY%ELEMENTS)) THEN
4210  cycle
4211  ENDIF
4212 
4213  domain_elements_mapping=>field_variable%COMPONENTS(component_idx)%DOMAIN%MAPPINGS%ELEMENTS
4214  DO np=1,domain_elements_mapping%NUMBER_OF_LOCAL
4215  DO nn=1,elemental_info_set%NUMBER_OF_ENTRIES
4216  IF(elemental_info_set%LIST_OF_GLOBAL_NUMBER(nn)==domain_elements_mapping%LOCAL_TO_GLOBAL_MAP(np)) THEN
4217  EXIT
4218  ENDIF
4219  ENDDO
4220 
4221  !allocate variable component memory
4222  CALL grow_array( elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS, 1, &
4223  & "Could not allocate component buffer in IO", err, error, *999 )
4224  elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS( &
4225  & elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS+1 &
4226  & )%PTR=>field%VARIABLES(var_idx)%COMPONENTS(component_idx)
4227  !increase number of component
4228  elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS=&
4229  & elemental_info_set%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS+1
4230  ENDDO !np
4231  ENDDO !component_idx
4232  ENDDO !var_idx
4233  ENDDO !num_field
4234 
4235  !LOCAL_PROCESS_NODAL_INFO_SET%LIST_OF_GLOBAL_NUMBER=>LIST_OF_GLOBAL_NUMBER
4236  !NULLIFY(LIST_OF_GLOBAL_NUMBER)
4237 
4238  exits("FieldIO_ElementalInfoSetAttachLocalProcess")
4239  RETURN
4240 999 errorsexits("FieldIO_ElementalInfoSetAttachLocalProcess",err,error)
4241  RETURN 1
4243 
4244  !
4245  !================================================================================================================================
4246  !
4247  !
4248  !!>Import nodal information \see{FIELD_IO::FIELD_IO_NODES_IMPORT}.
4249  !SUBROUTINE FIELD_IO_NODES_IMPORT(FIELDS, FILE_NAME, METHOD, ERR,ERROR,*)
4250  ! !Argument variables
4251  ! TYPE(FIELDS_TYPE), POINTER :: FIELDS !<the field object
4252  ! TYPE(VARYING_STRING), INTENT(INOUT) :: FILE_NAME !<file name
4253  ! TYPE(VARYING_STRING), INTENT(IN):: METHOD
4254  ! INTEGER(INTG), INTENT(OUT) :: ERR !<The error code
4255  ! TYPE(VARYING_STRING), INTENT(OUT) :: ERROR !<The error string
4256  ! !Local Variables
4257  ! TYPE(FIELD_IO_INFO_SET) :: LOCAL_PROCESS_NODAL_INFO_SET !<nodal information in this process
4258  ! INTEGER(INTG):: my_computational_node_number !<local process number
4259  ! INTEGER(INTG):: computational_node_numbers !<total process number
4260  !
4261  ! ENTERS("FIELD_IO_NODES_IMPORT", ERR,ERROR,*999)
4262  !
4263  ! !Get the number of computational nodes
4264  ! computational_node_numbers=COMPUTATIONAL_NODES_NUMBER_GET(ERR,ERROR)
4265  ! IF(ERR/=0) GOTO 999
4266  ! !Get my computational node number
4267  ! my_computational_node_number=COMPUTATIONAL_NODE_NUMBER_GET(ERR,ERROR)
4268  ! IF(ERR/=0) GOTO 999
4269  ! IF(METHOD=="FORTRAN") THEN
4270  ! CALL FIELD_IO_INFO_SET_INITIALISE(LOCAL_PROCESS_NODAL_INFO_SET, FIELDS, ERR,ERROR,*999)
4271  ! CALL FieldIO_NodelInfoSetAttachLocalProcess(LOCAL_PROCESS_NODAL_INFO_SET, ERR,ERROR,*999)
4272  ! CALL FIELD_IO_NODAL_INFO_SET_SORT(LOCAL_PROCESS_NODAL_INFO_SET, my_computational_node_number, ERR,ERROR,*999)
4273  ! CALL FIELD_IO_IMPORT_NODES_FROM_LOCAL_FILE(LOCAL_PROCESS_NODAL_INFO_SET, FILE_NAME, my_computational_node_number, &
4274  ! &computational_node_numbers, ERR, ERROR, *999)
4275  ! CALL FIELD_IO_NODAL_INFO_SET_FINALIZE(LOCAL_PROCESS_NODAL_INFO_SET, ERR,ERROR,*999)
4276  ! ELSE IF(METHOD=="MPIIO") THEN
4277  ! CALL FlagError("what are u thinking, of course not!",ERR,ERROR,*999)
4278  ! ENDIF
4279  !
4280  ! EXITS("FIELD_IO_NODES_IMPORT")
4281  ! RETURN
4282 !999 ERRORSEXITS("FIELD_IO_NODES_IMPORT",ERR,ERROR)
4283  ! RETURN 1
4284  !END SUBROUTINE FIELD_IO_NODES_IMPORT
4285 
4286 
4287  !
4288  !================================================================================================================================
4289  !
4290 
4291  FUNCTION field_io_compare_info_set_components( SET1, SET2 )
4292  !Argument variables
4293  TYPE(field_io_component_info_set) :: SET1
4294  TYPE(field_io_component_info_set) :: SET2
4295  LOGICAL :: FIELD_IO_COMPARE_INFO_SET_COMPONENTS
4296 
4297  !local variables
4298  INTEGER(INTG) :: component_idx
4299 
4300  field_io_compare_info_set_components = .false.
4301 
4302  IF( set1%NUMBER_OF_COMPONENTS /= set2%NUMBER_OF_COMPONENTS ) THEN
4303  RETURN
4304  ENDIF
4305 
4306  DO component_idx = 1, set1%NUMBER_OF_COMPONENTS
4307  !!not safe, but it is fast
4308  !!=============================================================================================!
4309  !! checking according to local memory adddress !
4310  !!=============================================================================================!
4311  !!are they in the same memory address?
4312  !IF(SET1%COMPONENTS(component_idx)%PTR/=&
4313  ! &SET2%COMPONENTS(component_idx)%PTR)
4314  !THEN
4315  ! FIELD_IO_COMPARE_INFO_SETS=.FALSE. !out of loop-component_idx=1,SET1%NUMBER_OF_COMPONENTS
4316  ! EXIT
4317  !ENDIF NUMBER_OF_NODES
4318 
4319  ! better use this one because it is safe method, but slow
4320  !=============================================================================================!
4321  ! checking according to the types defined in the openCMISS !
4322  !=============================================================================================!
4323  !are they in the same field?
4324  IF( set1%COMPONENTS(component_idx)%PTR%FIELD_VARIABLE%FIELD%GLOBAL_NUMBER/= &
4325  & set2%COMPONENTS(component_idx)%PTR%FIELD_VARIABLE%FIELD%GLOBAL_NUMBER ) THEN
4326  RETURN
4327  ENDIF
4328 
4329  !are they the same variable?
4330  IF( set1%COMPONENTS( component_idx )%PTR%FIELD_VARIABLE% &
4331  & variable_number /= set2%COMPONENTS( component_idx )%PTR% &
4332  & field_variable%VARIABLE_NUMBER ) THEN
4333  RETURN
4334  ENDIF
4335 
4336  !are they the same component?
4337  IF( set1%COMPONENTS( component_idx )%PTR%COMPONENT_NUMBER /= &
4338  & set2%COMPONENTS( component_idx)%PTR%COMPONENT_NUMBER ) THEN
4339  RETURN
4340  ENDIF
4341  ENDDO !component_idx
4342 
4343  field_io_compare_info_set_components = .true.
4344 
4346 
4347  !
4348  !================================================================================================================================
4349  !
4350 
4351  SUBROUTINE field_io_compare_info_set_derivatives( SET1, SET2, my_computational_node_number, global_number1, global_number2, &
4352  & doesmatch, err, error, * )
4353  !Argument variables
4354  TYPE(field_io_component_info_set) :: SET1
4355  TYPE(field_io_component_info_set) :: SET2
4356  INTEGER(INTG) :: my_computational_node_number
4357  INTEGER(INTG) :: global_number1
4358  INTEGER(INTG) :: global_number2
4359  LOGICAL :: doesMatch
4360  INTEGER(INTG), INTENT(OUT) :: ERR
4361  TYPE(varying_string), INTENT(OUT) :: ERROR
4362 
4363  !local variables
4364  INTEGER(INTG) :: component_idx, derivative_idx
4365  INTEGER(INTG) :: local_number1, local_number2, tmp1
4366  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES1, DOMAIN_NODES2
4367  INTEGER(INTG), ALLOCATABLE:: array1(:), array2(:)
4368  LOGICAL :: FOUND
4369 
4370  enters("FIELD_IO_COMPARE_INFO_SET_DERIVATIVES",err,error,*999)
4371 
4372  doesmatch = .true.
4373 
4374  !We have a potential match. Do a deeper inspection
4375  DO component_idx=1, set1%NUMBER_OF_COMPONENTS
4376 
4377  domain_nodes1=>set1%COMPONENTS(component_idx)%PTR%DOMAIN%TOPOLOGY%NODES
4378  found=.false.
4379  DO local_number1=1,domain_nodes1%NUMBER_OF_NODES
4380  IF( domain_nodes1%NODES(local_number1)%GLOBAL_NUMBER == global_number1 ) THEN
4381  found = .true.
4382  EXIT
4383  ENDIF
4384  ENDDO !local_number
4385 
4386  IF( .NOT. found ) THEN
4387  doesmatch = .false.
4388  EXIT !out of loop-component_idx=1,SET1%NUMBER_OF_COMPONENTS
4389  ENDIF
4390 
4391  domain_nodes2=>set2%COMPONENTS(component_idx)%PTR%DOMAIN%TOPOLOGY%NODES
4392  found=.false.
4393  DO local_number2=1,domain_nodes2%NUMBER_OF_NODES
4394  IF( domain_nodes2%NODES(local_number2)%GLOBAL_NUMBER == global_number2 ) THEN
4395  found = .true.
4396  EXIT
4397  ENDIF
4398  ENDDO !local_number
4399 
4400  IF( .NOT. found ) THEN
4401  doesmatch = .false.
4402  EXIT !out of loop-component_idx=1,SET1%NUMBER_OF_COMPONENTS
4403  ENDIF
4404 
4405  IF(domain_nodes1%NODES(local_number1)%NUMBER_OF_DERIVATIVES&
4406  &==domain_nodes2%NODES(local_number2)%NUMBER_OF_DERIVATIVES) THEN
4407  ALLOCATE(array1(domain_nodes1%NODES(local_number1)%NUMBER_OF_DERIVATIVES),stat=err)
4408  IF(err/=0) CALL flagerror("Could not allocate temporary buffer in IO sorting",err,error,*999)
4409 
4410  ALLOCATE(array2(domain_nodes1%NODES(local_number2)%NUMBER_OF_DERIVATIVES),stat=err)
4411  IF(err/=0) CALL flagerror("Could not allocate temporary buffer in IO sorting",err,error,*999)
4412 
4413  array1(1:domain_nodes1%NODES(local_number1)%NUMBER_OF_DERIVATIVES)=0
4414  array2(1:domain_nodes1%NODES(local_number2)%NUMBER_OF_DERIVATIVES)=0
4415 
4416  DO derivative_idx=1,domain_nodes1%NODES(local_number1)%NUMBER_OF_DERIVATIVES
4417  array1(derivative_idx)=domain_nodes1%NODES(local_number1)%DERIVATIVES(derivative_idx)%PARTIAL_DERIVATIVE_INDEX
4418  ENDDO
4419  DO derivative_idx=1,domain_nodes1%NODES(local_number2)%NUMBER_OF_DERIVATIVES
4420  array2(derivative_idx)=domain_nodes1%NODES(local_number2)%DERIVATIVES(derivative_idx)%PARTIAL_DERIVATIVE_INDEX
4421  ENDDO
4422 
4423  CALL list_sort(array1,err,error,*999)
4424  CALL list_sort(array2,err,error,*999)
4425  tmp1=sum(array1-array2)
4426  DEALLOCATE(array1)
4427  DEALLOCATE(array2)
4428  IF(tmp1/=0) THEN
4429  doesmatch = .false.
4430  EXIT !out of loop-component_idx=1,SET1%NUMBER_OF_COMPONENTS
4431  ENDIF
4432  ELSE
4433  doesmatch = .false.
4434  EXIT
4435  ENDIF
4436 
4437  ! Check that the nodes have the same number of versions, otherwise they must be grouped separately
4438  IF(set1%COMPONENT_VERSIONS(component_idx)/=set2%COMPONENT_VERSIONS(component_idx)) THEN
4439  doesmatch = .false.
4440  EXIT
4441  END IF
4442  ENDDO !component_idx
4443 
4444  exits("FIELD_IO_COMPARE_INFO_SET_DERIVATIVES")
4445  RETURN
4446 999 errorsexits("FIELD_IO_COMPARE_INFO_SET_DERIVATIVES",err,error)
4447  RETURN 1
4448 
4450 
4451  !
4452  !================================================================================================================================
4453  !
4454 
4456  SUBROUTINE field_io_nodal_info_set_sort(NODAL_INFO_SET, my_computational_node_number, ERR,ERROR,*)
4457  !Argument variables
4458  TYPE(field_io_info_set), INTENT(INOUT) :: NODAL_INFO_SET
4459  INTEGER(INTG), INTENT(IN):: my_computational_node_number
4460  INTEGER(INTG), INTENT(OUT) :: ERR
4461  TYPE(varying_string), INTENT(OUT) :: ERROR
4462  !Local Variables
4463  TYPE(field_io_component_info_set), POINTER :: tmpInfoSet
4464  INTEGER(INTG) :: global_number1, global_number2
4465  INTEGER(INTG) :: nn1, nn2
4466  LOGICAL :: SAME_NODAL_INFO
4467 
4468  !from now on, global numbering are used
4469  enters("FIELD_IO_NODAL_INFO_SET_SORT",err,error,*999)
4470 
4471  IF(.NOT.ALLOCATED(nodal_info_set%LIST_OF_GLOBAL_NUMBER)) THEN
4472  CALL flagerror("list of global numbering in the input data is invalid",err,error,*999)
4473  ENDIF
4474  IF(.NOT.ALLOCATED(nodal_info_set%COMPONENT_INFO_SET)) THEN
4475  CALL flagerror("nodal information set in the input data is invalid",err,error,*999)
4476  ENDIF
4477 
4478  !group nodal information set according to its components, i.e. put all the nodes with the same components together
4479  !and change the global number in the LIST_OF_GLOBAL_NUMBER
4480  nn1=1
4481  DO WHILE(nn1<nodal_info_set%NUMBER_OF_ENTRIES)
4482  !global number of this node
4483  global_number1=nodal_info_set%LIST_OF_GLOBAL_NUMBER(nn1)
4484  DO nn2=nn1+1,nodal_info_set%NUMBER_OF_ENTRIES
4485  global_number2=nodal_info_set%LIST_OF_GLOBAL_NUMBER(nn2)
4486 
4487  same_nodal_info = field_io_compare_info_set_components( nodal_info_set%COMPONENT_INFO_SET( nn1 )%PTR, &
4488  & nodal_info_set%COMPONENT_INFO_SET( nn2 )%PTR )
4489 
4490  !check whether correspoding two components have the same partial derivatives
4491  IF( same_nodal_info ) THEN
4492  CALL field_io_compare_info_set_derivatives( nodal_info_set%COMPONENT_INFO_SET(nn1)%PTR, &
4493  & nodal_info_set%COMPONENT_INFO_SET(nn2)%PTR, my_computational_node_number, global_number1, global_number2, &
4494  & same_nodal_info, err, error, *999 )
4495  ENDIF !SAME_NODAL_INFO==.TRUE.
4496 
4497  !find two nodes which have the same output, and then they should put together
4498  IF(same_nodal_info) THEN
4499  tmpinfoset => nodal_info_set%COMPONENT_INFO_SET(nn2)%PTR
4500  nodal_info_set%COMPONENT_INFO_SET(nn2)%PTR => nodal_info_set%COMPONENT_INFO_SET(nn1+1)%PTR
4501  nodal_info_set%COMPONENT_INFO_SET(nn1+1)%PTR => tmpinfoset
4502 
4503  nodal_info_set%COMPONENT_INFO_SET(nn2)%PTR%SAME_HEADER=.false.
4504  nodal_info_set%COMPONENT_INFO_SET(nn1+1)%PTR%SAME_HEADER=.true.
4505 
4506  !exchange the global number
4507  nodal_info_set%LIST_OF_GLOBAL_NUMBER(nn2)=nodal_info_set%LIST_OF_GLOBAL_NUMBER(nn1+1)
4508  nodal_info_set%LIST_OF_GLOBAL_NUMBER(nn1+1)=global_number2
4509 
4510  !increase nn1 to skip the nodes which have the same output
4511  nn1=nn1+1
4512  ENDIF !(SAME_NODAL_INFO=.TRUE.)
4513 
4514  ENDDO !nn2
4515  !increase the nn1 to check next node
4516  nn1=nn1+1
4517  ENDDO !nn1<NODAL_INFO_SET%NUMBER_OF_ENTRIES
4518 
4519  !order the variable components and group them: X1(1),X1(2),X1(3),X2(2),X2(3),X3(2)....
4520  !DO nn=1,NODAL_INFO_SET%NUMBER_OF_ENTRIES
4521  ! print "(A, I)", "nn=", nn
4522  ! !temporarily use nk, nu here to save memory
4523  ! IF(NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONENTS/=1) THEN
4524  ! component_idx=1
4525  ! DO WHILE(component_idx<NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONNode:ENTS)
4526  ! !checking the same variable's components
4527  ! print "(A, I)", "component_idx=", component_idx
4528  ! print "(A, I)", "NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONENTS", NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONENTS
4529  ! DO WHILE(ASSOCIATED(NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(component_idx)%PTR%FIELD_VARIABLE, &
4530  ! & TARGET=NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(component_idx+1)%PTR%FIELD_VARIABLE))
4531  ! component_idx=component_idx+1
4532  ! IF(component_idx>=NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONENTS) THEN
4533  ! EXIT
4534  ! ENDIF
4535  ! ENDDO
4536  !
4537  ! !It may have more than 3 component in the future?!! I do not know,too
4538  ! !so there the components are sorted according their numbering of component
4539  ! !nk and nu are used here temporarily
4540  ! DO tmp1=1,component_idx
4541  ! print "(A, I)", "tmp1=", tmp1
4542  ! SAME_NODAL_INFO=.FALSE.
4543  ! DO tmp2=1,(component_idx-tmp1)
4544  ! IF(NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(tmp2)%PTR%COMPONENT_NUMBER>&
4545  ! &NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(tmp2+1)%PTR%COMPONENT_NUMBER) THEN
4546  ! tmp_ptr=>NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(tmp2+1)%PTR
4547  ! NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(tmp2+1)%PTR=>&
4548  ! NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(tmp2)%PTR
4549  !
4550  ! NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%COMPONENTS(tmp2)%PTR=>tmp_ptr
4551  ! SAME_NODAL_INFO=.TRUE.
4552  ! ENDIF
4553  ! ENDDO
4554  ! IF(SAME_NODAL_INFO) THEN
4555  ! EXIT
4556  ! ENDIF
4557  ! ENDDO
4558  ! NULLIFY(tmp_ptr)
4559  ! component_idx=component_idx+1
4560  ! ENDDO ! WHILE(component_idx<NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONENTS)
4561  ! ENDIF ! NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%NUMBER_OF_COMPONENTS/=1
4562  !ENDDO !nn
4563 
4564  exits("FIELD_IO_NODAL_INFO_SET_SORT")
4565  RETURN
4566 999 errorsexits("FIELD_IO_NODAL_INFO_SET_SORT",err,error)
4567  RETURN 1
4568  END SUBROUTINE field_io_nodal_info_set_sort
4569 
4570  !
4571  !================================================================================================================================
4572  !
4573 
4575  FUNCTION field_io_label_derivative_info_get(GROUP_DERIVATIVES, NUMBER_DERIVATIVES, LABEL_TYPE, ERR, ERROR)
4576  !Argument variables
4577  INTEGER(INTG), INTENT(IN) :: NUMBER_DERIVATIVES
4578  INTEGER(INTG), INTENT(IN) :: GROUP_DERIVATIVES(number_derivatives)
4579  INTEGER(INTG), INTENT(IN) :: LABEL_TYPE
4580  INTEGER(INTG), INTENT(OUT) :: ERR
4581  TYPE(varying_string), INTENT(OUT) :: ERROR
4582  !Local Variables
4583  TYPE(varying_string) ::FIELD_IO_LABEL_DERIVATIVE_INFO_GET
4584  INTEGER(INTG) :: dev_idx
4585 
4586  enters("FIELD_IO_LABEL_DERIVATIVE_INFO_GET",err,error,*999)
4587 
4588  IF(number_derivatives==0) THEN
4589  CALL flagerror("number of derivatives in the input data is zero",err,error,*999)
4590  ENDIF
4591  IF(label_type/=field_io_derivative_label) THEN
4592  CALL flagerror("label type in the input data is not derivative label",err,error,*999)
4593  ENDIF
4594 
4595  IF((number_derivatives==1).AND.group_derivatives(1)==no_part_deriv) THEN
4596  field_io_label_derivative_info_get=" "
4597  ELSE
4598  field_io_label_derivative_info_get="("
4599  DO dev_idx=1,number_derivatives
4600  SELECT CASE(group_derivatives(dev_idx))
4601  CASE(no_part_deriv)
4602  field_io_label_derivative_info_get=field_io_label_derivative_info_get
4603  CASE(part_deriv_s1)
4604  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d/ds1"
4605  CASE(part_deriv_s1_s1)
4606  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds1ds1"
4607  CASE(part_deriv_s2)
4608  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d/ds2"
4609  CASE(part_deriv_s2_s2)
4610  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds2ds2"
4611  CASE(part_deriv_s1_s2)
4612  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d/ds3"
4613  CASE(part_deriv_s3)
4614  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds3ds3"
4615  CASE(part_deriv_s3_s3)
4616  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds3ds3"
4617  CASE(part_deriv_s1_s3)
4618  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds1ds3"
4619  CASE(part_deriv_s2_s3)
4620  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds2ds3"
4621  CASE(part_deriv_s1_s2_s3)
4622  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds1ds2ds3"
4623  CASE(part_deriv_s4)
4624  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d/ds4"
4625  CASE(part_deriv_s4_s4)
4626  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds4ds4"
4627  CASE(part_deriv_s1_s4)
4628  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds1ds4"
4629  CASE(part_deriv_s2_s4)
4630  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds2ds4"
4631  CASE(part_deriv_s3_s4)
4632  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d2/ds3ds4"
4633  CASE(part_deriv_s1_s2_s4)
4634  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds1ds2ds4"
4635  CASE(part_deriv_s1_s3_s4)
4636  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds1ds3ds4"
4637  CASE(part_deriv_s2_s3_s4)
4638  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds2ds3ds4"
4639  CASE(part_deriv_s1_s4_s4)
4640  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds1ds4ds4"
4641  CASE(part_deriv_s2_s4_s4)
4642  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds2ds4ds4"
4643  CASE(part_deriv_s3_s4_s4)
4644  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds3ds4ds4"
4645  CASE(part_deriv_s4_s4_s4)
4646  field_io_label_derivative_info_get=field_io_label_derivative_info_get//", d3/ds4ds4ds4"
4647  CASE DEFAULT
4648  field_io_label_derivative_info_get="real, add more details later, #Components="!&
4649  !&//TRIM(NUMBER_TO_VSTRING(NUMBER_OF_COMPONENTS,"*",ERR,ERROR))
4650  END SELECT
4651  ENDDO ! dev_idx
4652  ENDIF !NUMBER_DERIVATIVES==1.AND.GROUP_DERIVATIVES(1)==NO_PART_DERIV
4653 
4654  exits("FIELD_IO_LABEL_DERIVATIVE_INFO_GET")
4655  RETURN
4656 999 errorsexits("FIELD_IO_LABEL_DERIVATIVE_INFO_GET",err,error)
4658 
4659  !
4660  !================================================================================================================================
4661  !
4662 
4664  FUNCTION field_io_get_field_info_label(FIELD, ERR, ERROR)
4665  !Argument variables
4666  TYPE(field_type), POINTER :: FIELD
4667  INTEGER(INTG), INTENT(OUT) :: ERR
4668  TYPE(varying_string), INTENT(OUT) :: ERROR
4669  !Local Variables
4670 
4671  TYPE(varying_string) :: FIELD_IO_GET_FIELD_INFO_LABEL
4672 
4673  enters("FIELD_IO_GET_FIELD_INFO_LABEL",err,error,*999)
4674 
4675  IF(.NOT.ASSOCIATED(field)) THEN
4676  CALL flagerror("field pointer in the input data is invalid",err,error,*999)
4677  GOTO 999
4678  ENDIF
4679 
4680  SELECT CASE(field%TYPE)
4681  CASE(field_geometric_type) !FIELD_GEOMETRIC_TYPE
4682  field_io_get_field_info_label="field geometric type"
4683  CASE(field_fibre_type)
4684  field_io_get_field_info_label="field fibres type"
4685  CASE(field_general_type)
4686  field_io_get_field_info_label="field general type"
4687  CASE(field_material_type)
4688  field_io_get_field_info_label="field material type"
4689  CASE(field_geometric_general_type)
4690  field_io_get_field_info_label="field geometric general type"
4691  CASE DEFAULT
4692  field_io_get_field_info_label="unknown field type"
4693  END SELECT
4694 
4695  exits("FIELD_IO_GET_FIELD_INFO_LABEL")
4696  RETURN
4697 999 errorsexits("FIELD_IO_GET_FIELD_INFO_LABEL",err,error)
4698  END FUNCTION field_io_get_field_info_label
4699  !
4700  !================================================================================================================================
4701  !
4702 
4704  FUNCTION field_io_get_variable_info_label(COMPONENT, ERR, ERROR)
4705  !Argument variables
4706  TYPE(field_variable_component_type), POINTER :: COMPONENT
4707  INTEGER(INTG), INTENT(OUT) :: ERR
4708  TYPE(varying_string), INTENT(OUT) :: ERROR
4709  !Local Variables
4710  TYPE(coordinate_system_type), POINTER :: COORDINATE_SYSTEM
4711  TYPE(field_type), POINTER :: FIELD
4712  TYPE(field_variable_type), POINTER :: VARIABLE
4713  TYPE(varying_string) :: FIELD_IO_GET_VARIABLE_INFO_LABEL
4714 
4715  enters("FIELD_IO_GET_VARIABLE_INFO_LABEL",err,error,*999)
4716 
4717  IF(.NOT.ASSOCIATED(component)) THEN
4718  CALL flagerror("component pointer in the input data is invalid",err,error,*999)
4719  GOTO 999
4720  ENDIF
4721 
4722  field=>component%FIELD_VARIABLE%FIELD
4723  variable=>component%FIELD_VARIABLE
4724 
4725  SELECT CASE(field%TYPE)
4726  CASE(field_geometric_type) !FIELD_GEOMETRIC_TYPE
4727  SELECT CASE(variable%VARIABLE_TYPE)
4728  CASE(field_u_variable_type)
4729  !coordinate system
4730  NULLIFY(coordinate_system)
4731  CALL field_coordinate_system_get(field,coordinate_system,err,error,*999)
4732  SELECT CASE(coordinate_system%TYPE)
4734  field_io_get_variable_info_label="coordinates, coordinate, rectangular cartesian"
4735  !CASE(COORDINATE_CYCLINDRICAL_POLAR_TYPE)
4736  !CASE(COORDINATE_SPHERICAL_POLAR_TYPE)
4737  !CASE(COORDINATE_PROLATE_SPHEROIDAL_TYPE)
4738  !CASE(COORDINATE_OBLATE_SPHEROIDAL_TYPE)
4739  CASE DEFAULT
4740  field_io_get_variable_info_label="unknown" !coordinates, coordinate, rectangular cartesian,
4741  END SELECT
4742  CASE(field_deludeln_variable_type)
4743  field_io_get_variable_info_label="Normal_derivative, field, normal derivative of variable"
4744  CASE(field_deludelt_variable_type)
4745  field_io_get_variable_info_label="first_time_derivative, field, first time derivative of variable"
4746  CASE(field_del2udelt2_variable_type)
4747  field_io_get_variable_info_label="second_time_derivative, field, second time derivative of variable"
4748  CASE DEFAULT
4749  field_io_get_variable_info_label="unknown_geometry, field, real"
4750  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4751  CASE(field_fibre_type)
4752  SELECT CASE(variable%VARIABLE_TYPE)
4753  CASE(field_u_variable_type)
4754 !kmith - 17.10.08: Fixing fibre field label
4755  !FIELD_IO_GET_VARIABLE_INFO_LABEL="fiber, standand variable type"
4756  field_io_get_variable_info_label="fibres, anatomical, fibre"
4757 !kmith - 17.10.08:
4758  CASE(field_deludeln_variable_type)
4759  field_io_get_variable_info_label="norm_der_fiber, normal derivative of variable"
4760  CASE(field_deludelt_variable_type)
4761  field_io_get_variable_info_label="first_time_fiber, first time derivative of variable"
4762  CASE(field_del2udelt2_variable_type)
4763  field_io_get_variable_info_label="second_time_fiber, second time derivative of variable"
4764  CASE DEFAULT
4765  field_io_get_variable_info_label="unknown_fiber, real"
4766  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4767  CASE(field_general_type)
4768  SELECT CASE(variable%VARIABLE_TYPE)
4769  CASE(field_u_variable_type)
4770 !kmith - 17.10.08: Fixing general field label
4771  !FIELD_IO_GET_VARIABLE_INFO_LABEL="general_variabe, field, string"
4772  field_io_get_variable_info_label="general, field, rectangular cartesian"
4773 !kmith - 17.10.08:
4774  CASE(field_deludeln_variable_type)
4775  field_io_get_variable_info_label="norm_dev_variable, field, string"
4776  CASE(field_deludelt_variable_type)
4777  field_io_get_variable_info_label="first_time_variable, field, first time derivative of variable"
4778  CASE(field_del2udelt2_variable_type)
4779  field_io_get_variable_info_label="second_time_variable, field, second time derivative of variable"
4780  CASE DEFAULT
4781  field_io_get_variable_info_label="unknown_general, field, real"
4782  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4783  CASE(field_material_type)
4784  SELECT CASE(variable%VARIABLE_TYPE)
4785  CASE(field_u_variable_type)
4786 !kmith - 17.10.08: Fixing material field label
4787  !FIELD_IO_GET_VARIABLE_INFO_LABEL="material, field, standand variable type"
4788  field_io_get_variable_info_label="material, field, rectangular cartesian"
4789 !kmith - 17.10.08:
4790  CASE(field_deludeln_variable_type)
4791  field_io_get_variable_info_label="normal_material, field, normal derivative of variable"
4792  CASE(field_deludelt_variable_type)
4793  field_io_get_variable_info_label="fist_time_material, field, first time derivative of variable"
4794  CASE(field_del2udelt2_variable_type)
4795  field_io_get_variable_info_label="second_time_material, field, second time derivative of variable"
4796  CASE DEFAULT
4797  field_io_get_variable_info_label="unknown material, field, real"
4798  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4799  CASE(field_geometric_general_type)
4800  SELECT CASE(variable%VARIABLE_TYPE)
4801  CASE(field_u_variable_type)
4802 !kmith - 17.10.08: Fixing general field label
4803  !FIELD_IO_GET_VARIABLE_INFO_LABEL="general_variabe, field, string"
4804  field_io_get_variable_info_label="geometric general, field, rectangular cartesian"
4805 !kmith - 17.10.08:
4806  CASE(field_deludeln_variable_type)
4807  field_io_get_variable_info_label="norm_dev_variable, field, string"
4808  CASE(field_deludelt_variable_type)
4809  field_io_get_variable_info_label="first_time_variable, field, first time derivative of variable"
4810  CASE(field_del2udelt2_variable_type)
4811  field_io_get_variable_info_label="second_time_variable, field, second time derivative of variable"
4812  CASE DEFAULT
4813  field_io_get_variable_info_label="unknown_general, field, real"
4814  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4815  CASE DEFAULT
4816  SELECT CASE(variable%VARIABLE_TYPE)
4817  CASE(field_u_variable_type)
4818  field_io_get_variable_info_label="unknown, field, unknown standand variable type"
4819  CASE(field_deludeln_variable_type)
4820  field_io_get_variable_info_label="unknown, field, unknown normal derivative of variable"
4821  CASE(field_deludelt_variable_type)
4822  field_io_get_variable_info_label="unknown, field, unknown first time derivative of variable"
4823  CASE(field_del2udelt2_variable_type)
4824  field_io_get_variable_info_label="unknown, field, unknown second time derivative of variable"
4825  CASE DEFAULT
4826  field_io_get_variable_info_label="unknown, field, real"
4827  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4828  END SELECT
4829 
4830  exits("FIELD_IO_GET_VARIABLE_INFO_LABEL")
4831  RETURN
4832 999 errorsexits("FIELD_IO_GET_VARIABLE_INFO_LABEL",err,error)
4834  !
4835  !================================================================================================================================
4836  !
4837 
4839  FUNCTION field_io_get_component_info_label(COMPONENT, ERR, ERROR)
4840  !Argument variables
4841  TYPE(field_variable_component_type), POINTER :: COMPONENT
4842  INTEGER(INTG), INTENT(OUT) :: ERR
4843  TYPE(varying_string), INTENT(OUT) :: ERROR
4844  !Local Variables
4845  TYPE(coordinate_system_type), POINTER :: COORDINATE_SYSTEM
4846  TYPE(field_type), POINTER :: FIELD
4847  TYPE(field_variable_type), POINTER :: VARIABLE
4848  TYPE(varying_string) :: FIELD_IO_GET_COMPONENT_INFO_LABEL
4849 
4850  enters("FIELD_IO_GET_COMPONENT_INFO_LABEL",err,error,*999)
4851 
4852  IF(.NOT.ASSOCIATED(component)) THEN
4853  CALL flagerror("component pointer in the input data is invalid",err,error,*999)
4854  GOTO 999
4855  ENDIF
4856 
4857  field=>component%FIELD_VARIABLE%FIELD
4858  variable=>component%FIELD_VARIABLE
4859 
4860  SELECT CASE(field%TYPE)
4861  CASE(field_geometric_type) !FIELD_GEOMETRIC_TYPE
4862  SELECT CASE(variable%VARIABLE_TYPE)
4863  CASE(field_u_variable_type)
4864  !coordinate system
4865  NULLIFY(coordinate_system)
4866  CALL field_coordinate_system_get(field,coordinate_system,err,error,*999)
4867  SELECT CASE(coordinate_system%TYPE)
4869  IF(component%COMPONENT_NUMBER==1) THEN
4870  field_io_get_component_info_label="x"
4871  ELSE IF(component%COMPONENT_NUMBER==2) THEN
4872  field_io_get_component_info_label="y"
4873  ELSE IF(component%COMPONENT_NUMBER==3) THEN
4874  field_io_get_component_info_label="z"
4875  ENDIF
4876  !CASE(COORDINATE_CYCLINDRICAL_POLAR_TYPE)
4877  !CASE(COORDINATE_SPHERICAL_POLAR_TYPE)
4878  !CASE(COORDINATE_PROLATE_SPHEROIDAL_TYPE)
4879  !CASE(COORDINATE_OBLATE_SPHEROIDAL_TYPE)
4880  CASE DEFAULT
4881  field_io_get_component_info_label=trim(number_to_vstring(component%COMPONENT_NUMBER,"*",err,error))
4882  END SELECT
4883  CASE DEFAULT
4884  field_io_get_component_info_label=trim(number_to_vstring(component%COMPONENT_NUMBER,"*",err,error))
4885  END SELECT !CASE(VARIABLE%VARIABLE_TYPE)
4886  CASE DEFAULT
4887  field_io_get_component_info_label=trim(number_to_vstring(component%COMPONENT_NUMBER,"*",err,error))
4888  END SELECT
4889 
4890  exits("FIELD_IO_GET_COMPONENT_INFO_LABEL")
4891  RETURN
4892 999 errorsexits("FIELD_IO_GET_COMPONENT_INFO_LABEL",err,error)
4894 
4895  !!
4896  !!================================================================================================================================
4897  !!
4898 
4899  !!>Write the header of a group nodes using FORTRAIN
4900  !SUBROUTINE FIELD_IO_IMPORT_NODAL_GROUP_HEADER_FORTRAN(NODAL_INFO_SET, LOCAL_NODAL_NUMBER, MAX_NUM_OF_NODAL_DERIVATIVES, &
4901  !&my_computational_node_number, FILE_ID, ERR,ERROR, *)
4902  ! !Argument variables
4903  ! TYPE(FIELD_IO_INFO_SET), INTENT(INOUT) :: NODAL_INFO_SET !<NODAL_INFO_SET
4904  ! INTEGER(INTG), INTENT(IN) :: LOCAL_NODAL_NUMBER !<LOCAL_NUMBER IN THE NODAL IO LIST
4905  ! INTEGER(INTG), INTENT(INOUT) :: MAX_NUM_OF_NODAL_DERIVATIVES !<MAX_NUM_OF_NODAL_DERIVATIVES
4906  ! INTEGER(INTG), INTENT(IN) :: my_computational_node_number !<local process number
4907  ! INTEGER(INTG), INTENT(IN) :: FILE_ID !< FILE ID
4908  ! INTEGER(INTG), INTENT(OUT) :: ERR !<The error code
4909  ! TYPE(VARYING_STRING), INTENT(OUT) :: ERROR !<The error string
4910  ! !Local Variables
4911  ! TYPE(FIELD_TYPE), POINTER :: field_ptr
4912  ! TYPE(FIELD_VARIABLE_TYPE), POINTER :: variable_ptr
4913  ! TYPE(DOMAIN_MAPPING_TYPE), POINTER :: DOMAIN_MAPPING_NODES !The domain mapping to calculate nodal mappings
4914  ! TYPE(DOMAIN_NODES_TYPE), POINTER :: DOMAIN_NODES ! domain nodes
4915  ! TYPE(VARYING_STRING) :: LINE, LABEL
4916  ! INTEGER(INTG) :: NUM_OF_FIELDS, NUM_OF_VARIABLES, NUM_OF_NODAL_DEV
4917  ! INTEGER(INTG) :: local_number, global_number
4918  ! INTEGER(INTG), POINTER :: GROUP_FIELDS(:), GROUP_VARIABLES(:), GROUP_DERIVATIVES(:)
4919  ! INTEGER(INTG) :: field_idx, comp_idx, comp_idx1, value_idx, var_idx, global_var_idx !dev_idx,
4920  !
4921  ! ENTERS("FIELD_IO_IMPORT_NODAL_GROUP_HEADER_FORTRAN",ERR,ERROR,*999)
4922  !
4923  ! !colllect nodal header information for IO first
4924  !
4925  ! !!get the number of this computational node from mpi pool
4926  ! !my_computational_node_number=COMPUTATIONAL_NODE_NUMBER_GET(ERR,ERROR)
4927  ! !IF(ERR/=0) GOTO 999
4928  !
4929  ! !attach the temporary pointer
4930  ! !tmp_components=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS
4931  !
4932  ! !collect maximum number of nodal derivatives, number of fields and variables
4933  ! NUM_OF_FIELDS=0
4934  ! NUM_OF_VARIABLES=0
4935  ! MAX_NUM_OF_NODAL_DERIVATIVES=0
4936  ! global_number=NODAL_INFO_SET%LIST_OF_GLOBAL_NUMBER(LOCAL_NODAL_NUMBER)
4937  ! NULLIFY(field_ptr)
4938  ! NULLIFY(variable_ptr)
4939  ! DO comp_idx=1,NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%NUMBER_OF_COMPONENTS
4940  ! !calculate the number of fields
4941  ! IF (.NOT.ASSOCIATED(field_ptr, target=NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)% &
4942  ! &COMPONENTS(comp_idx)%PTR%FIELD)) THEN
4943  ! NUM_OF_FIELDS=NUM_OF_FIELDS+1
4944  ! field_ptr=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS (comp_idx)%PTR%FIELD
4945  ! ENDIF
4946  !
4947  ! !calculate the number of variables
4948  ! IF (.NOT.ASSOCIATED(variable_ptr, target=NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)% &
4949  ! &COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE)) THEN
4950  ! NUM_OF_VARIABLES=NUM_OF_VARIABLES+1
4951  ! variable_ptr=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
4952  ! ENDIF
4953  !
4954  ! !finding the local numbering through the global to local mapping
4955  ! DOMAIN_MAPPING_NODES=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%&
4956  ! &COMPONENTS(comp_idx)%PTR%DOMAIN%MAPPINGS%NODES
4957  ! !get the domain index for this variable component according to my own computional node number
4958  ! local_number = FindMyLocalDomainNumber( DOMAIN_MAPPING_NODES%GLOBAL_TO_LOCAL_MAP(global_number), my_computational_node_number )
4959  ! !use local domain information find the out the maximum number of derivatives
4960  ! DOMAIN_NODES=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%DOMAIN%TOPOLOGY%NODES
4961  ! MAX_NUM_OF_NODAL_DERIVATIVES=MAX(DOMAIN_NODES%NODES(local_number)%NUMBER_OF_DERIVATIVES,MAX_NUM_OF_NODAL_DERIVATIVES)
4962  ! ENDDO !comp_idx
4963  ! !Allocate the memory for group of field variables
4964  ! ALLOCATE(GROUP_FIELDS(NUM_OF_FIELDS),STAT=ERR)
4965  ! IF(ERR/=0) CALL FlagError("Could not allocate temporary field buffer in IO",ERR,ERROR,*999)
4966  ! !Allocate the memory for group of field components
4967  ! ALLOCATE(GROUP_VARIABLES(NUM_OF_VARIABLES),STAT=ERR)
4968  ! IF(ERR/=0) CALL FlagError("Could not allocate temporary variable buffer in IO",ERR,ERROR,*999)
4969  ! !Allocate the memory for group of maximum number of derivatives
4970  ! ALLOCATE(GROUP_DERIVATIVES(MAX_NUM_OF_NODAL_DERIVATIVES),STAT=ERR)
4971  ! IF(ERR/=0) CALL FlagError("Could not allocate temporary derivatives buffer in IO",ERR,ERROR,*999)
4972  !
4973  ! !fill information into the group of fields and variables
4974  ! NUM_OF_FIELDS=0
4975  ! NUM_OF_VARIABLES=0
4976  ! NULLIFY(field_ptr)
4977  ! NULLIFY(variable_ptr)
4978  ! GROUP_FIELDS(:)=0 !the item in this arrary is the number of variables in the same field
4979  ! GROUP_VARIABLES(:)=0 !the item in this arrary is the number of components in the same variable
4980  ! DO comp_idx=1,NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%NUMBER_OF_COMPONENTS
4981  ! !grouping field variables and components together
4982  ! IF((.NOT.ASSOCIATED(field_ptr,TARGET=NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)% &
4983  ! &COMPONENTS(comp_idx)%PTR%FIELD)).AND.(.NOT.ASSOCIATED(variable_ptr,TARGET=NODAL_INFO_SET% &
4984  ! &NODAL_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE))) THEN !different field and variables
4985  ! !add one new variable
4986  ! NUM_OF_FIELDS=NUM_OF_FIELDS+1
4987  ! GROUP_FIELDS(NUM_OF_FIELDS)=GROUP_FIELDS(NUM_OF_FIELDS)+1
4988  ! !add one new component
4989  ! NUM_OF_VARIABLES=NUM_OF_VARIABLES+1
4990  ! GROUP_VARIABLES(NUM_OF_VARIABLES)=GROUP_VARIABLES(NUM_OF_VARIABLES)+1
4991  ! field_ptr=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%FIELD
4992  ! variable_ptr=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
4993  ! ELSE IF (ASSOCIATED(field_ptr,TARGET=NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)% &
4994  ! &COMPONENTS(comp_idx)%PTR%FIELD).AND.(.NOT.ASSOCIATED(variable_ptr,TARGET=NODAL_INFO_SET%&
4995  ! &NODAL_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE))) THEN !the same field and different variables
4996  ! !add one new variable
4997  ! GROUP_FIELDS(NUM_OF_FIELDS)=GROUP_FIELDS(NUM_OF_FIELDS)+1
4998  ! !add one new component
4999  ! NUM_OF_VARIABLES=NUM_OF_VARIABLES+1
5000  ! GROUP_VARIABLES(NUM_OF_VARIABLES)=GROUP_VARIABLES(NUM_OF_VARIABLES)+1
5001  ! variable_ptr=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
5002  ! ELSE !different components of the same variable
5003  ! !add one new component
5004  ! GROUP_VARIABLES(NUM_OF_VARIABLES)=GROUP_VARIABLES(NUM_OF_VARIABLES)+1
5005  ! ENDIF !field_ptr/=NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS%COMPONENTS(comp_idx)%PTR%FIELD
5006  ! ENDDO !comp_idx
5007  !
5008  ! !write out the nodal header
5009  ! var_idx=1
5010  ! comp_idx=1
5011  ! field_idx=1
5012  ! value_idx=1
5013  ! comp_idx1=1
5014  ! global_var_idx=0
5015  !
5016  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR,ERROR, *999)
5017  ! IF(LINE/=" "//"#Fields="//TRIM(NUMBER_TO_VSTRING(SUM(GROUP_FIELDS(1:NUM_OF_FIELDS)),"*",ERR,ERROR))) &
5018  ! & CALL FlagError("Fields number in the Header part do not match",ERR,ERROR,*999)
5019  !
5020  ! DO field_idx=1, NUM_OF_FIELDS
5021  ! !write out the field information
5022  ! !LABEL=FIELD_IO_GET_FIELD_INFO_LABEL(NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx1)%PTR, FIELD_IO_FIELD_LABEL,ERR,ERROR)
5023  ! !IF(ERR/=0) THEN
5024  ! ! CALL FlagError("can not get field label",ERR,ERROR,*999)
5025  ! !ENDIF
5026  ! !CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR,ERROR, *999)
5027  ! !IF(LINE/=TRIM(NUMBER_TO_VSTRING(field_idx,"*",ERR,ERROR))//") "//TRIM(LABEL)&
5028  ! !&//" , #variables="//TRIM(NUMBER_TO_VSTRING(GROUP_FIELDS(field_idx),"*",ERR,ERROR)) &
5029  ! !CALL FlagError("Variable number in the Header part do not match",ERR,ERROR,*999)
5030  !
5031  ! DO var_idx=1, GROUP_FIELDS(field_idx)
5032  ! global_var_idx=global_var_idx+1
5033  ! !write out the field information
5034  ! LABEL=" "//TRIM(NUMBER_TO_VSTRING(global_var_idx,"*",ERR,ERROR))//") "&
5035  ! &//FIELD_IO_GET_FIELD_INFO_LABEL(NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%&
5036  ! &COMPONENTS(comp_idx1)%PTR, FIELD_IO_VARIABLE_LABEL,ERR,ERROR)
5037  ! IF(ERR/=0) THEN
5038  ! CALL FlagError("can not get variable label",ERR,ERROR,*999)
5039  ! GOTO 999
5040  ! ENDIF
5041  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR,ERROR, *999)
5042  ! IF(LINE/=TRIM(LABEL)//", #Components="//TRIM(NUMBER_TO_VSTRING(GROUP_VARIABLES(global_var_idx),"*",ERR,ERROR))) &
5043  ! & CALL FlagError("Components number in the Header part do not match",ERR,ERROR,*999)
5044  !
5045  !
5046  ! DO comp_idx=1, GROUP_VARIABLES(global_var_idx)
5047  ! !write out the component information
5048  ! LABEL=" "//FIELD_IO_GET_FIELD_INFO_LABEL(NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%&
5049  ! &COMPONENTS(comp_idx1)%PTR, FIELD_IO_COMPONENT_LABEL,ERR,ERROR)
5050  ! IF(ERR/=0) THEN
5051  ! CALL FlagError("can not get component label",ERR,ERROR,*999)
5052  ! GOTO 999
5053  ! ENDIF
5054  ! LINE=TRIM(LABEL)//"."
5055  !
5056  ! !finding the local numbering through the global to local mapping
5057  ! DOMAIN_MAPPING_NODES=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%&
5058  ! &DOMAIN%MAPPINGS%NODES
5059  ! !get the domain index for this variable component according to my own computional node number
5060  ! local_number = FindMyLocalDomainNumber( DOMAIN_MAPPING_NODES%GLOBAL_TO_LOCAL_MAP(global_number), my_computational_node_number )
5061  ! !use local domain information find the out the maximum number of derivatives
5062  ! DOMAIN_NODES=>NODAL_INFO_SET%COMPONENT_INFO_SET(LOCAL_NODAL_NUMBER)%COMPONENTS(comp_idx)%PTR%DOMAIN%TOPOLOGY%NODES
5063  ! !get the nodal partial derivatives
5064  ! NUM_OF_NODAL_DEV=DOMAIN_NODES%NODES(local_number)%NUMBER_OF_DERIVATIVES
5065  ! GROUP_DERIVATIVES(1:NUM_OF_NODAL_DEV)=DOMAIN_NODES%NODES(local_number)%PARTIAL_DERIVATIVE_INDEX(:)
5066  ! !sort the partial derivatives
5067  ! CALL LIST_SORT(GROUP_DERIVATIVES(1:NUM_OF_NODAL_DEV),ERR,ERROR,*999)
5068  ! !get the derivative name
5069  ! LABEL=FIELD_IO_LABEL_DERIVATIVE_INFO_GET(GROUP_DERIVATIVES(1:NUM_OF_NODAL_DEV), NUM_OF_NODAL_DEV, &
5070  ! &FIELD_IO_DERIVATIVE_LABEL,ERR,ERROR)
5071  ! IF(ERR/=0) THEN
5072  ! CALL FlagError("can not get derivative label",ERR,ERROR,*999)
5073  ! GOTO 999
5074  ! ENDIF
5075  ! !write out the header
5076  ! CALL FIELD_IO_FORTRAN_FILE_READ_STRING(FILE_ID, LINE, FILE_END, ERR,ERROR, *999)
5077  ! !assemble the header
5078  ! IF(LINE/=LINE//" Value index= "//TRIM(NUMBER_TO_VSTRING(value_idx,"*",ERR,ERROR))&
5079  ! &//", #Derivatives= "//TRIM(NUMBER_TO_VSTRING(NUM_OF_NODAL_DEV-1,"*",ERR,ERROR))//TRIM(LABEL)) &
5080  ! & CALL FlagError("Value index in the Header part do not match",ERR,ERROR,*999)
5081  ! !increase the component index
5082  ! comp_idx1=comp_idx1+1
5083  ! !increase the value index
5084  ! value_idx=value_idx+NUM_OF_NODAL_DEV
5085  ! ENDDO !comp_idx
5086  ! ENDDO !var_idx
5087  ! ENDDO !field_idx
5088  !
5089  ! !release temporary memory
5090  ! IF(ASSOCIATED(GROUP_FIELDS)) DEALLOCATE(GROUP_FIELDS)
5091  ! IF(ASSOCIATED(GROUP_VARIABLES)) DEALLOCATE(GROUP_VARIABLES)
5092  ! IF(ASSOCIATED(GROUP_DERIVATIVES)) DEALLOCATE(GROUP_DERIVATIVES)
5093  !
5094  ! EXITS("FIELD_IO_IMPORT_NODAL_GROUP_HEADER_FORTRAN")
5095  ! RETURN
5096 !999 ERRORSEXITS("FIELD_IO_IMPORT_NODAL_GROUP_HEADER_FORTRAN",ERR,ERROR)
5097  ! RETURN 1
5098  !END SUBROUTINE FIELD_IO_IMPORT_NODAL_GROUP_HEADER_FORTRAN
5099 
5100  !
5101  !================================================================================================================================
5102  !
5103 
5105  SUBROUTINE field_io_export_nodal_group_header_fortran(fieldInfoSet, global_number, MAX_NUM_OF_NODAL_DERIVATIVES, &
5106  &my_computational_node_number, sessionhandle, paddinginfo, err,error, *)
5107  !Argument variables
5108  TYPE(field_io_component_info_set), INTENT(IN) :: fieldInfoSet
5109  INTEGER(INTG), INTENT(IN) :: global_number
5110  INTEGER(INTG), INTENT(INOUT) :: MAX_NUM_OF_NODAL_DERIVATIVES
5111  INTEGER(INTG), INTENT(IN) :: my_computational_node_number
5112  INTEGER(INTG), INTENT(IN) :: sessionHandle
5113  INTEGER(INTG), ALLOCATABLE, INTENT(INOUT) :: paddingInfo(:)
5114  INTEGER(INTG), INTENT(OUT) :: ERR
5115  TYPE(varying_string), INTENT(OUT) :: ERROR
5116  !Local Variables
5117  INTEGER(INTG) :: i, LENGTH
5118  CHARACTER(LEN=MAXSTRLEN) :: fvar_name
5119  CHARACTER(LEN=1, KIND=C_CHAR) :: cvar_name(maxstrlen+1)
5120  TYPE(coordinate_system_type), POINTER :: COORDINATE_SYSTEM
5121  TYPE(field_type), POINTER :: field_ptr
5122  TYPE(field_variable_type), POINTER :: variable_ptr
5123  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES ! domain nodes
5124  TYPE(field_variable_component_type), POINTER :: component, fieldComponent
5125  INTEGER(INTG), ALLOCATABLE, TARGET :: GROUP_FIELDS(:), GROUP_VARIABLES(:), GROUP_DERIVATIVES(:)
5126  INTEGER(INTG) :: NUM_OF_FIELDS, NUM_OF_VARIABLES, NUM_OF_NODAL_DEV
5127  INTEGER(INTG) :: local_number
5128  INTEGER(INTG) :: field_idx, comp_idx, comp_idx1, value_idx, var_idx, global_var_idx ,derivative_idx !dev_idx,
5129  LOGICAL :: FOUND
5130 
5131  enters("FIELD_IO_EXPORT_NODAL_GROUP_HEADER_FORTRAN",err,error,*999)
5132 
5133  !colllect nodal header information for IO first
5134 
5135  !!get the number of this computational node from mpi pool
5136  !my_computational_node_number=COMPUTATIONAL_NODE_NUMBER_GET(ERR,ERROR)
5137  !IF(ERR/=0) GOTO 999
5138 
5139  !attach the temporary pointer
5140  !tmp_components=>fieldInfoSet%COMPONENTS
5141 
5142  !collect maximum number of nodal derivatives, number of fields and variables
5143  num_of_fields=0
5144  num_of_variables=0
5145  max_num_of_nodal_derivatives=0
5146  NULLIFY(field_ptr)
5147  NULLIFY(variable_ptr)
5148  DO comp_idx=1,fieldinfoset%NUMBER_OF_COMPONENTS
5149  !calculate the number of fields
5150  IF (.NOT.ASSOCIATED(field_ptr, TARGET=fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE%FIELD)) THEN
5151  num_of_fields=num_of_fields+1
5152  field_ptr=>fieldinfoset%COMPONENTS (comp_idx)%PTR%FIELD_VARIABLE%FIELD
5153  ENDIF
5154 
5155  !calculate the number of variables
5156  IF (.NOT.ASSOCIATED(variable_ptr, TARGET=fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE)) THEN
5157  num_of_variables=num_of_variables+1
5158  variable_ptr=>fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
5159  ENDIF
5160 
5161  !find the local numbering
5162  domain_nodes=>fieldinfoset%COMPONENTS(comp_idx)%PTR%DOMAIN%TOPOLOGY%NODES
5163  found=.false.
5164  DO local_number=1,domain_nodes%NUMBER_OF_NODES
5165  IF( domain_nodes%NODES(local_number)%GLOBAL_NUMBER == global_number ) THEN
5166  found = .true.
5167  EXIT
5168  ENDIF
5169  ENDDO !local_number
5170 
5171  IF( .NOT. found ) THEN
5172  !Something's gone horribly wrong
5173  cycle
5174  ENDIF
5175 
5176  max_num_of_nodal_derivatives=max(domain_nodes%NODES(local_number)%NUMBER_OF_DERIVATIVES,max_num_of_nodal_derivatives)
5177  ENDDO !comp_idx
5178 
5179  !Allocate the memory for group of field variables
5180  ALLOCATE(group_fields(num_of_fields),stat=err)
5181  IF(err/=0) CALL flagerror("Could not allocate temporary field buffer in IO",err,error,*999)
5182  !Allocate the memory for group of field components
5183  ALLOCATE(group_variables(num_of_variables),stat=err)
5184  IF(err/=0) CALL flagerror("Could not allocate temporary variable buffer in IO",err,error,*999)
5185  !Allocate the memory for group of maximum number of derivatives
5186  ALLOCATE(group_derivatives(max_num_of_nodal_derivatives),stat=err)
5187  IF(err/=0) CALL flagerror("Could not allocate temporary derivatives buffer in IO",err,error,*999)
5188 
5189  !fill information into the group of fields and variables
5190  num_of_fields=0
5191  num_of_variables=0
5192  NULLIFY(field_ptr)
5193  NULLIFY(variable_ptr)
5194  group_fields(:)=0 !the item in this arrary is the number of variables in the same field
5195  group_variables(:)=0 !the item in this arrary is the number of components in the same variable
5196  DO comp_idx=1,fieldinfoset%NUMBER_OF_COMPONENTS
5197  !grouping field variables and components together
5198  IF((.NOT.ASSOCIATED(field_ptr,TARGET=fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE%FIELD)).AND. &
5199  & (.NOT.ASSOCIATED(variable_ptr,TARGET=fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE))) THEN !different field and variables
5200  num_of_fields=num_of_fields+1
5201  field_ptr=>fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE%FIELD
5202  ENDIF
5203 
5204  IF(.NOT.ASSOCIATED(variable_ptr,TARGET=fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE)) THEN !the same field and different variables
5205  !add one new variable
5206  group_fields(num_of_fields)=group_fields(num_of_fields)+1
5207  !add one new component
5208  num_of_variables=num_of_variables+1
5209  variable_ptr=>fieldinfoset%COMPONENTS(comp_idx)%PTR%FIELD_VARIABLE
5210  ENDIF
5211 
5212  group_variables(num_of_variables)=group_variables(num_of_variables)+1
5213 
5214  ENDDO !comp_idx
5215 
5216  !write out the nodal header
5217  var_idx=1
5218  comp_idx=1
5219  field_idx=1
5220  value_idx=1
5221  comp_idx1=1
5222  global_var_idx=0
5223 
5224  CALL reallocate( paddinginfo, fieldinfoset%NUMBER_OF_COMPONENTS + 1, "Cannot allocate padding info", err, error, *999 )
5225 
5226  err = fieldexport_fieldcount( sessionhandle, sum(group_fields(1:num_of_fields) ) )
5227  IF(err/=0) THEN
5228  CALL flagerror( "File write error during field export", err, error,*999 )
5229  ENDIF
5230 
5231  DO field_idx=1, num_of_fields
5232  DO var_idx=1, group_fields(field_idx)
5233  global_var_idx=global_var_idx+1
5234 
5235  variable_ptr=>fieldinfoset%COMPONENTS(comp_idx1)%PTR%FIELD_VARIABLE
5236  !write out the field information
5237 
5238  fvar_name = char(variable_ptr%variable_label)
5239  length=len_trim(fvar_name)
5240  DO i=1,length
5241  cvar_name(i)=fvar_name(i:i)
5242  ENDDO !i
5243  cvar_name(length+1)=c_null_char
5244 
5245  IF( variable_ptr%FIELD%TYPE == field_geometric_type .AND. &
5246  & variable_ptr%VARIABLE_TYPE == field_u_variable_type ) THEN
5247  NULLIFY(coordinate_system)
5248  CALL field_coordinate_system_get(variable_ptr%FIELD,coordinate_system,err,error,*999)
5249  err = fieldexport_coordinatevariable( sessionhandle, cvar_name, global_var_idx, &
5250  & coordinate_system%TYPE, variable_ptr%NUMBER_OF_COMPONENTS )
5251  ELSE
5252  err = fieldexport_variable( sessionhandle, cvar_name, global_var_idx, variable_ptr%FIELD%TYPE, &
5253  & variable_ptr%VARIABLE_TYPE, &
5254  & variable_ptr%NUMBER_OF_COMPONENTS )
5255  ENDIF
5256  IF( err /= 0 ) THEN
5257  CALL flagerror( "File write error during field export", err, error,*999 )
5258  ENDIF
5259 
5260  DO comp_idx=1, variable_ptr%NUMBER_OF_COMPONENTS
5261  !write out the component information
5262 
5263  fieldcomponent => variable_ptr%COMPONENTS(comp_idx)
5264 
5265  IF( comp_idx1 <= fieldinfoset%NUMBER_OF_COMPONENTS ) THEN
5266  !It's possible to run out of node-local components before we've examined all field components.
5267  component => fieldinfoset%COMPONENTS(comp_idx1)%PTR
5268  ENDIF
5269 
5270  !The field component is not present at this node. Add a dummy value.
5271  IF(.NOT.ASSOCIATED(component,TARGET=fieldcomponent)) THEN
5272  paddinginfo(comp_idx1) = paddinginfo(comp_idx1) + 1
5273  group_derivatives(1:1) = no_part_deriv
5274  IF( fieldcomponent%FIELD_VARIABLE%FIELD%TYPE == field_geometric_type .AND. &
5275  & fieldcomponent%FIELD_VARIABLE%VARIABLE_TYPE == field_u_variable_type ) THEN
5276  NULLIFY(coordinate_system)
5277  CALL field_coordinate_system_get(variable_ptr%FIELD,coordinate_system,err,error,*999)
5278  err = fieldexport_coordinatederivativeindices( sessionhandle, fieldcomponent%COMPONENT_NUMBER, &
5279  & coordinate_system%TYPE, 1, c_loc(group_derivatives), value_idx )
5280  ELSE
5281  err = fieldexport_derivativeindices( sessionhandle, fieldcomponent%COMPONENT_NUMBER, &
5282  & variable_ptr%FIELD%TYPE, &
5283  & variable_ptr%VARIABLE_TYPE, 1, c_loc(group_derivatives), value_idx )
5284  ENDIF
5285 
5286  value_idx = value_idx + 1
5287 
5288  err = fieldexport_endcomponent( sessionhandle )
5289  cycle
5290  ENDIF
5291 
5292  !use local domain information find the out the maximum number of derivatives
5293  domain_nodes=>component%DOMAIN%TOPOLOGY%NODES
5294 
5295  found=.false.
5296  DO local_number=1,domain_nodes%NUMBER_OF_NODES
5297  IF( domain_nodes%NODES(local_number)%GLOBAL_NUMBER == global_number ) THEN
5298  found = .true.
5299  EXIT
5300  ENDIF
5301  ENDDO !local_number
5302 
5303  IF( .NOT. found ) THEN
5304  err = fieldexport_endcomponent( sessionhandle )
5305  cycle
5306  ENDIF
5307 
5308  !get the nodal partial derivatives
5309  num_of_nodal_dev=domain_nodes%NODES(local_number)%NUMBER_OF_DERIVATIVES
5310  DO derivative_idx=1,num_of_nodal_dev
5311  group_derivatives(derivative_idx)=domain_nodes%NODES(local_number)%DERIVATIVES(derivative_idx)% &
5313  ENDDO
5314  !sort the partial derivatives
5315  CALL list_sort(group_derivatives(1:num_of_nodal_dev),err,error,*999)
5316 
5317  IF( component%FIELD_VARIABLE%FIELD%TYPE == field_geometric_type .AND. &
5318  & component%FIELD_VARIABLE%VARIABLE_TYPE == field_u_variable_type ) THEN
5319  NULLIFY(coordinate_system)
5320  CALL field_coordinate_system_get(variable_ptr%FIELD,coordinate_system,err,error,*999)
5321  err = fieldexport_coordinatederivativeindices( sessionhandle, component%COMPONENT_NUMBER, &
5322  & coordinate_system%TYPE, num_of_nodal_dev, c_loc(group_derivatives), value_idx )
5323  ELSE
5324  err = fieldexport_derivativeindices( sessionhandle, component%COMPONENT_NUMBER, &
5325  & variable_ptr%FIELD%TYPE, &
5326  & variable_ptr%VARIABLE_TYPE,num_of_nodal_dev, c_loc(group_derivatives), value_idx )
5327  ENDIF
5328 
5329  err = fieldexport_versioninfo( sessionhandle, fieldinfoset%COMPONENT_VERSIONS(comp_idx1) )
5330  IF(err/=0) THEN
5331  CALL flagerror( "Error exporting version information.", err, error,*999 )
5332  ENDIF
5333  err = fieldexport_endcomponent( sessionhandle )
5334 
5335  !increase the component index
5336  comp_idx1=comp_idx1+1
5337  !increase the value index
5338  value_idx=value_idx+num_of_nodal_dev
5339  ENDDO !comp_idx
5340  ENDDO !var_idx
5341  ENDDO !field_idx
5342 
5343  !release temporary memory
5344  CALL checked_deallocate( group_fields )
5345  CALL checked_deallocate( group_variables )
5346  CALL checked_deallocate( group_derivatives )
5347 
5348  exits("FIELD_IO_EXPORT_NODAL_GROUP_HEADER_FORTRAN")
5349  RETURN
5350 999 errorsexits("FIELD_IO_EXPORT_NODAL_GROUP_HEADER_FORTRAN",err,error)
5351  RETURN 1
5353 
5354  !
5355  !================================================================================================================================
5356  !
5357 
5359  SUBROUTINE field_io_export_nodes_into_local_file(NODAL_INFO_SET, NAME, my_computational_node_number,ERR, ERROR, *)
5360  !the reason that my_computational_node_number is used in the argument is for future extension
5361  !Argument variables
5362  TYPE(field_io_info_set), INTENT(INOUT):: NODAL_INFO_SET
5363  TYPE(varying_string), INTENT(IN) :: NAME
5364  INTEGER(INTG), INTENT(IN):: my_computational_node_number
5365  INTEGER(INTG), INTENT(OUT) :: ERR
5366  TYPE(varying_string), INTENT(OUT) :: ERROR
5367  !Local Variables
5368  TYPE(varying_string) :: FILE_NAME !the prefix name of file.
5369  TYPE(field_variable_component_type), POINTER :: COMPONENT !the prefix name of file.
5370  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES ! domain nodes
5371  INTEGER(INTG) :: local_number, global_number, sessionHandle, paddingCount,DERIVATIVE_INDEXES(part_deriv_s4_s4_s4)
5372  INTEGER(INTG), ALLOCATABLE :: paddingInfo(:)
5373  INTEGER(INTG) :: nn, comp_idx, dev_idx, version_idx, NUM_OF_NODAL_DEV, MAX_NUM_OF_NODAL_DERIVATIVES, total_nodal_values
5374  INTEGER(INTG) :: NUMBER_VERSIONS, MAX_NUMBER_VERSIONS
5375  INTEGER(INTG), POINTER :: GEOMETRIC_PARAMETERS_INTG(:)
5376  LOGICAL :: FOUND
5377  REAL(C_DOUBLE), ALLOCATABLE, TARGET :: NODAL_BUFFER(:), TOTAL_NODAL_BUFFER(:)
5378  REAL(DP), POINTER :: GEOMETRIC_PARAMETERS_DP(:)
5379  !INTEGER(INTG), POINTER :: GEOMETRIC_PARAMETERS_INTG(:)
5380  REAL(DP) :: padding(1),VALUE
5381 
5382  padding(1) = 1.23456789
5383 
5384 
5385  enters("FIELD_IO_EXPORT_NODES_INTO_LOCAL_FILE",err,error,*999)
5386 
5387  !get my own computianal node number--be careful the rank of process in the MPI pool
5388  !is not necessarily equal to numbering of computional node, so use method COMPUTATIONAL_NODE_NUMBER_GET
5389  !will be a secured way to get the number
5390  file_name=name//".part"//trim(number_to_vstring(my_computational_node_number,"*",err,error))//".exnode"
5391  max_num_of_nodal_derivatives=0
5392 
5393  IF(.NOT.ALLOCATED(nodal_info_set%COMPONENT_INFO_SET)) THEN
5394  CALL flagerror("the nodal information set in input is invalid",err,error,*999)
5395  ENDIF
5396 
5397  IF(.NOT.ALLOCATED(nodal_info_set%LIST_OF_GLOBAL_NUMBER)) THEN
5398  CALL flagerror("the nodal global information set is not associated with any numbering list",err,error,*999)
5399  ENDIF
5400 
5401  IF(nodal_info_set%NUMBER_OF_ENTRIES==0) THEN
5402  CALL flagerror("the nodal information set does not contain any nodes",err,error,*999)
5403  ENDIF
5404 
5405  IF(nodal_info_set%COMPONENT_INFO_SET(1)%PTR%SAME_HEADER) THEN
5406  CALL flagerror("the first header flag of nodal information set should be false",err,error,*999)
5407  ENDIF
5408 
5409  err = fieldexport_opensession( export_type_file, char(file_name)//c_null_char, sessionhandle )
5410  IF(err/=0) THEN
5411  CALL flagerror( "Cannot open file export session", err, error,*999 )
5412  ENDIF
5413 
5414  IF(ASSOCIATED(nodal_info_set%FIELDS%REGION)) THEN
5415  err = fieldexport_group( sessionhandle, char(nodal_info_set%FIELDS%REGION%LABEL)//c_null_char )
5416  ELSE
5417  IF(ASSOCIATED(nodal_info_set%FIELDS%INTERFACE)) THEN
5418  err = fieldexport_group( sessionhandle, char(nodal_info_set%FIELDS%INTERFACE%LABEL)//c_null_char )
5419  ELSE
5420  CALL flagerror("Fields region or interface is not associated.",err,error,*999)
5421  ENDIF
5422  ENDIF
5423  IF(err/=0) THEN
5424  CALL flagerror( "Cannot write group name to nodes file", err, error,*999 )
5425  ENDIF
5426 
5427  DO nn=1, nodal_info_set%NUMBER_OF_ENTRIES
5428  global_number=nodal_info_set%LIST_OF_GLOBAL_NUMBER(nn)
5429 
5430  IF(.NOT.nodal_info_set%COMPONENT_INFO_SET(nn)%PTR%SAME_HEADER) THEN
5431  !write out the nodal header
5432 
5433  CALL field_io_export_nodal_group_header_fortran(nodal_info_set%COMPONENT_INFO_SET(nn)%PTR, &
5434  & global_number, max_num_of_nodal_derivatives, my_computational_node_number, sessionhandle, &
5435  & paddinginfo, err,error,*999)
5436  max_number_versions = maxval(nodal_info_set%COMPONENT_INFO_SET(nn)%PTR%COMPONENT_VERSIONS)
5437  !value_idx=value_idx-1 !the len of NODAL_BUFFER
5438  !checking: whether need to allocate temporary memory for Io writing
5439  IF(ALLOCATED(nodal_buffer)) THEN
5440  IF(SIZE(nodal_buffer)<max_num_of_nodal_derivatives*max_number_versions) THEN
5441  CALL reallocate( nodal_buffer, max_num_of_nodal_derivatives*max_number_versions, &
5442  & "Could not allocate temporary nodal buffer in IO writing", err, error, *999 )
5443  ENDIF
5444  ELSE
5445  CALL reallocate( nodal_buffer, max_num_of_nodal_derivatives*max_number_versions, &
5446  & "Could not allocate temporary nodal buffer in IO writing", err, error, *999 )
5447  ENDIF
5448  ENDIF !NODAL_INFO_SET%COMPONENT_INFO_SET(nn)%SAME_HEADER==.FALSE.
5449 
5450  !write out the components' values of this node in this domain
5451  total_nodal_values = 0
5452  CALL checked_deallocate( total_nodal_buffer )
5453  DO comp_idx=1,nodal_info_set%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS
5454  component => nodal_info_set%COMPONENT_INFO_SET(nn)%PTR%COMPONENTS(comp_idx)%PTR
5455  number_versions = nodal_info_set%COMPONENT_INFO_SET(nn)%PTR%COMPONENT_VERSIONS(comp_idx)
5456  domain_nodes=>component%DOMAIN%TOPOLOGY%NODES
5457  found=.false.
5458  DO local_number=1,domain_nodes%NUMBER_OF_NODES
5459  IF( domain_nodes%NODES(local_number)%GLOBAL_NUMBER == global_number ) THEN
5460  found = .true.
5461  EXIT
5462  ENDIF
5463  ENDDO !local_number
5464 
5465  IF(.NOT. found) THEN
5466  cycle
5467  ENDIF
5468 
5469  DO paddingcount = 1, paddinginfo( comp_idx )
5470  num_of_nodal_dev = 1
5471  nodal_buffer(1) = padding(1)
5472 
5473  CALL grow_array( total_nodal_buffer, num_of_nodal_dev, "Insufficient memory during I/O", err, error, *999 )
5474  total_nodal_buffer(total_nodal_values+1:total_nodal_values+num_of_nodal_dev) = nodal_buffer(1:num_of_nodal_dev)
5475  total_nodal_values = total_nodal_values + num_of_nodal_dev
5476 
5477  err = fieldexport_nodevalues( sessionhandle, domain_nodes%NODES(local_number)%USER_NUMBER, num_of_nodal_dev, &
5478  & c_loc(nodal_buffer) )
5479  IF(err/=0) THEN
5480  CALL flagerror( "Cannot write group name to nodes file", err, error,*999 )
5481  ENDIF
5482  ENDDO !paddingCount
5483 
5484 
5485  SELECT CASE(component%FIELD_VARIABLE%DATA_TYPE)
5486  CASE(field_intg_type)
5487  NULLIFY(geometric_parameters_intg)
5488  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,component%FIELD_VARIABLE%VARIABLE_TYPE, &
5489  & field_values_set_type,geometric_parameters_intg,err,error,*999)
5490  CASE(field_dp_type)
5491  NULLIFY(geometric_parameters_dp)
5492  CALL field_parameter_set_data_get(component%FIELD_VARIABLE%FIELD,component%FIELD_VARIABLE%VARIABLE_TYPE, &
5493  & field_values_set_type,geometric_parameters_dp,err,error,*999)
5494  CASE DEFAULT
5495  CALL flagerror("Not implemented.",err,error,*999)
5496  END SELECT
5497  !get the nodal partial derivatives
5498  num_of_nodal_dev=domain_nodes%NODES(local_number)%NUMBER_OF_DERIVATIVES
5499 
5500  !Record the dof-index of each derivative (if it is present)
5501  derivative_indexes = -1
5502  DO dev_idx=1, num_of_nodal_dev
5503  derivative_indexes( domain_nodes%NODES(local_number)%DERIVATIVES(dev_idx)%PARTIAL_DERIVATIVE_INDEX ) = dev_idx
5504  ENDDO
5505 
5506  !Output the dofs, sorted according to derivative index
5507  !Loop over versions outside of derivatives, as cmgui treats versions differently
5508  num_of_nodal_dev = 0
5509  DO version_idx=1, number_versions
5510  DO dev_idx=1, SIZE(derivative_indexes)
5511  IF( derivative_indexes( dev_idx ) == -1 ) THEN
5512  cycle
5513  ENDIF
5514 
5515  num_of_nodal_dev = num_of_nodal_dev + 1
5516 
5517  SELECT CASE(component%FIELD_VARIABLE%DATA_TYPE)
5518  CASE(field_intg_type)
5519  IF(component%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_number)% &
5520  & derivatives(derivative_indexes(dev_idx))%NUMBER_OF_VERSIONS < version_idx) THEN
5521  !If the number of versions for this derivative isn't equal to the maximum number of versions for the
5522  !component, then fill the rest of the version data with the first version
5523  VALUE=REAL(GEOMETRIC_PARAMETERS_INTG( COMPONENT%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_number)% & & DERIVATIVES(DERIVATIVE_INDEXES(dev_idx))%VERSIONS(1) ) ,DP)
5524  ELSE
5525  VALUE=REAL(GEOMETRIC_PARAMETERS_INTG( COMPONENT%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_number)% & & DERIVATIVES(DERIVATIVE_INDEXES(dev_idx))%VERSIONS(version_idx) ) ,DP)
5526  ENDIF
5527  CASE(field_dp_type)
5528  !Default to version 1 of each node derivative
5529  IF(component%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_number)% &
5530  & derivatives(derivative_indexes(dev_idx))%NUMBER_OF_VERSIONS < version_idx) THEN
5531  VALUE=geometric_parameters_dp( component%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_number)% &
5532  & derivatives(derivative_indexes(dev_idx))%VERSIONS(1) )
5533  ELSE
5534  VALUE=geometric_parameters_dp( component%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_number)% &
5535  & derivatives(derivative_indexes(dev_idx))%VERSIONS(version_idx) )
5536  ENDIF
5537  CASE DEFAULT
5538  CALL flagerror("Not implemented.",err,error,*999)
5539  END SELECT
5540  nodal_buffer( num_of_nodal_dev ) = VALUE
5541  ENDDO !dev_idx
5542  ENDDO !verion_idx
5543 
5544  CALL grow_array( total_nodal_buffer, num_of_nodal_dev, "Insufficient memory during I/O", err, error, *999 )
5545  total_nodal_buffer(total_nodal_values+1:total_nodal_values+num_of_nodal_dev) = nodal_buffer(1:num_of_nodal_dev)
5546  total_nodal_values = total_nodal_values + num_of_nodal_dev
5547 
5548  !TEMPORARY
5549  err = fieldexport_nodevalues( sessionhandle, domain_nodes%NODES(local_number)%USER_NUMBER, num_of_nodal_dev, &
5550  & c_loc(nodal_buffer) )
5551  IF(err/=0) THEN
5552  CALL flagerror( "Cannot write group name to nodes file", err, error,*999 )
5553  ENDIF
5554  ENDDO !comp_idx
5555 
5556  !Note that paddingInfo's size is one more than the component count
5557  DO paddingcount = 1, paddinginfo( nodal_info_set%COMPONENT_INFO_SET(nn)%PTR%NUMBER_OF_COMPONENTS + 1 )
5558  num_of_nodal_dev = 1
5559  nodal_buffer(1) = padding(1)
5560 
5561  CALL grow_array( total_nodal_buffer, num_of_nodal_dev, "Insufficient memory during I/O", err, error, *999 )
5562  total_nodal_buffer(total_nodal_values+1:total_nodal_values+num_of_nodal_dev) = nodal_buffer(1:num_of_nodal_dev)
5563  total_nodal_values = total_nodal_values + num_of_nodal_dev
5564 
5565  err = fieldexport_nodevalues( sessionhandle, domain_nodes%NODES(local_number)%USER_NUMBER, num_of_nodal_dev, &
5566  & c_loc(nodal_buffer) )
5567  IF(err/=0) THEN
5568  CALL flagerror( "Cannot write group name to nodes file", err, error,*999 )
5569  ENDIF
5570  ENDDO !paddingCount
5571 
5572  !REINSTATE FOR HDF5 BLOCK DATA WRITES
5573  ! ERR = FieldExport_NodeValues( sessionHandle, DOMAIN_NODES%NODES(local_number)%USER_NUMBER, &
5574  ! & total_nodal_values, C_LOC(TOTAL_NODAL_BUFFER) )
5575  ! IF(ERR/=0) THEN
5576  ! CALL FlagError( "Cannot write group name to nodes file", ERR, ERROR,*999 )
5577  ! ENDIF
5578 
5579 
5580  ENDDO !nn
5581 
5582  err = fieldexport_closesession( sessionhandle )
5583  IF(err/=0) THEN
5584  CALL flagerror( "Cannot write group name to nodes file", err, error,*999 )
5585  ENDIF
5586 
5587  !release the temporary memory
5588  CALL checked_deallocate( nodal_buffer )
5589  CALL checked_deallocate( total_nodal_buffer )
5590  IF(ASSOCIATED(geometric_parameters_dp)) NULLIFY(geometric_parameters_dp)
5591  IF(ASSOCIATED(geometric_parameters_intg)) NULLIFY(geometric_parameters_intg)
5592 
5593  exits("FIELD_IO_EXPORT_NODES_INTO_LOCAL_FILE")
5594  RETURN
5595 999 errorsexits("FIELD_IO_EXPORT_NODES_INTO_LOCAL_FILE",err,error)
5596  RETURN 1
5598 
5599  !!
5600  !!================================================================================================================================
5601  !!
5602 
5604  SUBROUTINE field_io_fortran_file_read_string(FILE_ID, STRING_DATA, FILE_END, ERR,ERROR,*)
5605 
5606  !Argument variables
5607  TYPE(varying_string), INTENT(INOUT) :: STRING_DATA
5608  INTEGER(INTG), INTENT(IN) :: FILE_ID
5609  LOGICAL, INTENT(INOUT) :: FILE_END
5610  INTEGER(INTG), INTENT(OUT) :: ERR
5611  TYPE(varying_string), INTENT(OUT) :: ERROR
5612  !Local Variables
5613  CHARACTER (LEN=MAXSTRLEN) :: TEMP_STR
5614  INTEGER(INTG) :: LEN_OF_DATA, IOS
5615 
5616  string_data=remove(string_data, 1, len(string_data))
5617 
5618  enters("FIELD_IO_FORTRAN_FILE_READ_STRING", err, error, *999)
5619 
5620  READ(file_id, "(A)", iostat=ios) temp_str
5621 
5622  IF(ios>=0) THEN
5623  file_end=.false.
5624  ELSE
5625  file_end=.true.
5626  ENDIF
5627 
5628  string_data=trim(temp_str)
5629  len_of_data=len(string_data)
5630 
5631  IF(len_of_data==0) THEN
5632  CALL flagerror("leng of string is zero",err,error,*999)
5633  ENDIF
5634 
5635  exits("FIELD_IO_FORTRAN_FILE_READ_STRING")
5636  RETURN
5637 999 errorsexits("FIELD_IO_FORTRAN_FILE_READ_STRING",err,error)
5638 
5639  exits("FIELD_IO_FORTRAN_FILE_READ_STRING")
5640  RETURN 1
5641  END SUBROUTINE field_io_fortran_file_read_string
5642 
5643  !
5644  !================================================================================================================================
5645  !
5646  !
5647 
5649  SUBROUTINE field_io_fortran_file_read_dp(FILE_ID, REAL_DATA, LEN_OF_DATA, FILE_END, ERR,ERROR,*)
5650 
5651  !Argument variables
5652  REAL(DP), INTENT(OUT) :: REAL_DATA(:)
5653  INTEGER(INTG), INTENT(IN) :: FILE_ID
5654  INTEGER(INTG), INTENT(IN) :: LEN_OF_DATA
5655  LOGICAL, INTENT(INOUT) :: FILE_END ! file end
5656  INTEGER(INTG), INTENT(OUT) :: ERR
5657  TYPE(varying_string), INTENT(OUT) :: ERROR
5658  !Local Variables
5659  TYPE(varying_string) :: DP_FMT
5660  INTEGER(INTG) :: IOS
5661 
5662  enters("FIELD_IO_FORTRAN_FILE_READ_DP",err,error,*999)
5663 
5664  dp_fmt="("//trim(number_to_vstring(len_of_data,"*",err,error))//"ES)"
5665  READ(file_id, char(dp_fmt), iostat=ios) real_data(1:len_of_data)
5666 
5667  IF(ios>=0) THEN
5668  file_end=.false.
5669  ELSE
5670  file_end=.true.
5671  ENDIF
5672 
5673  exits("FIELD_IO_FORTRAN_FILE_READ_DP")
5674  RETURN
5675 999 errorsexits("FIELD_IO_FORTRAN_FILE_READ_DP",err,error)
5676  RETURN 1
5677  END SUBROUTINE field_io_fortran_file_read_dp
5678 
5679  !
5680  !================================================================================================================================
5681  !
5682 
5684  SUBROUTINE field_io_fortran_file_write_dp(FILE_ID, REAL_DATA, LEN_OF_DATA, ERR,ERROR,*)
5685 
5686  !Argument variables
5687  REAL(DP), INTENT(IN) :: REAL_DATA(:)
5688  INTEGER(INTG), INTENT(IN) :: FILE_ID
5689  INTEGER(INTG), INTENT(IN) :: LEN_OF_DATA
5690  INTEGER(INTG), INTENT(OUT) :: ERR
5691  TYPE(varying_string), INTENT(OUT) :: ERROR
5692  !Local Variables
5693 
5694  enters("FIELD_IO_FORTRAN_FILE_WRITE_DP",err,error,*999)
5695 
5696  !DP_FMT="(ES"//TRIM(NUMBER_TO_VSTRING(LEN_OF_DATA,"*",ERR,ERROR))//".0)"
5697  !WRITE(FILE_ID, CHAR(DP_FMT)) REAL_DATA(1:LEN_OF_DATA)
5698  WRITE(file_id,*) real_data(1:len_of_data)
5699 
5700  exits("FIELD_IO_FORTRAN_FILE_WRITE_DP")
5701  RETURN
5702 999 errorsexits("FIELD_IO_FORTRAN_FILE_WRITE_DP",err,error)
5703  RETURN 1
5704  END SUBROUTINE field_io_fortran_file_write_dp
5705 
5706  !!
5707  !!================================================================================================================================
5708  !!
5709 
5711  SUBROUTINE field_io_fortran_file_read_intg(FILE_ID, INTG_DATA, LEN_OF_DATA, ERR,ERROR,*)
5712 
5713  !Argument variables
5714  INTEGER(INTG), INTENT(OUT) :: INTG_DATA(:)
5715  INTEGER(INTG), INTENT(IN) :: FILE_ID
5716  INTEGER(INTG), INTENT(IN) :: LEN_OF_DATA
5717  INTEGER(INTG), INTENT(OUT) :: ERR
5718  TYPE(varying_string), INTENT(OUT) :: ERROR
5719  !Local Variables
5720  TYPE(varying_string) :: DP_FMT
5721 
5722  enters("FIELD_IO_FORTRAN_FILE_READ_INTG",err,error,*999)
5723 
5724  dp_fmt="("//trim(number_to_vstring(len_of_data,"*",err,error))//"I)"
5725  READ(file_id, char(dp_fmt)) intg_data(1:len_of_data)
5726 
5727  exits("FIELD_IO_FORTRAN_FILE_READ_INTG")
5728  RETURN
5729 999 errorsexits("FIELD_IO_FORTRAN_FILE_READ_INTG",err,error)
5730  RETURN 1
5731  END SUBROUTINE field_io_fortran_file_read_intg
5732 
5733  !
5734  !================================================================================================================================
5735  !
5736 
5738  SUBROUTINE field_io_fortran_file_write_intg(FILE_ID, INTG_DATA, LEN_OF_DATA, ERR,ERROR,*)
5739 
5740  !Argument variables
5741  INTEGER(INTG), INTENT(IN) :: INTG_DATA(:)
5742  INTEGER(INTG), INTENT(IN) :: FILE_ID
5743  INTEGER(INTG), INTENT(IN) :: LEN_OF_DATA
5744  INTEGER(INTG), INTENT(OUT) :: ERR
5745  TYPE(varying_string), INTENT(OUT) :: ERROR
5746  !Local Variables
5747  TYPE(varying_string) :: DP_FMT
5748 
5749  enters("FIELD_IO_FORTRAN_FILE_WRITE_INTG",err,error,*999)
5750 
5751  dp_fmt="(I"//trim(number_to_vstring(len_of_data,"*",err,error))//")"
5752  WRITE(file_id, char(dp_fmt)) intg_data(1:len_of_data)
5753 
5754  exits("FIELD_IO_FORTRAN_FILE_WRITE_INTG")
5755  RETURN
5756 999 errorsexits("FIELD_IO_FORTRAN_FILE_WRITE_INTG",err,error)
5757  RETURN 1
5758  END SUBROUTINE field_io_fortran_file_write_intg
5759 
5760  !
5761  !================================================================================================================================
5762  !
5763 
5765  SUBROUTINE field_io_fortran_file_open(FILE_ID, FILE_NAME, FILE_STATUS, ERR,ERROR,*)
5766 
5767  !Argument variables
5768  TYPE(varying_string), INTENT(INOUT) :: FILE_NAME
5769  TYPE(varying_string), INTENT(IN) :: FILE_STATUS
5770  INTEGER(INTG), INTENT(INOUT) :: FILE_ID
5771  INTEGER(INTG), INTENT(OUT) :: ERR
5772  TYPE(varying_string), INTENT(OUT) :: ERROR
5773  !Local Variables
5774 
5775  enters("FIELD_IO_FORTRAN_FILE_OPEN",err,error,*999)
5776 
5777  !CALL WRITE_STRING(DIAGNOSTIC_OUTPUT_TYPE,"OPEN FILE",ERR,ERROR,*999)
5778 
5779  OPEN(unit=file_id, file=char(file_name), status=char(file_status), form="FORMATTED", err=999)
5780 
5781 
5782  exits("FIELD_IO_FORTRAN_FILE_OPEN")
5783  RETURN
5784 999 errorsexits("FIELD_IO_FORTRAN_FILE_OPEN",err,error)
5785  RETURN 1
5786  END SUBROUTINE field_io_fortran_file_open
5787 
5788  !!
5789  !!================================================================================================================================
5790  !!
5791 
5793  SUBROUTINE field_io_fortran_file_close(FILE_ID, ERR,ERROR, *)
5794  !Argument variables
5795  INTEGER(INTG), INTENT(INOUT) :: FILE_ID
5796  INTEGER(INTG), INTENT(OUT) :: ERR
5797  TYPE(varying_string), INTENT(OUT) :: ERROR
5798  !Local Variables
5799 
5800  enters("FIELD_IO_FORTRAN_FILE_CLOSE",err,error,*999)
5801 
5802  !CALL WRITE_STRING(DIAGNOSTIC_OUTPUT_TYPE,"CLOSE FILE",ERR,ERROR,*999)
5803 
5804  CLOSE(unit=file_id, err=999)
5805 
5806  exits("FIELD_IO_FORTRAN_FILE_CLOSE")
5807  RETURN
5808 999 errorsexits("FIELD_IO_FORTRAN_FILE_CLOSE",err,error)
5809  RETURN 1
5810  END SUBROUTINE field_io_fortran_file_close
5811 
5812  SUBROUTINE string_to_muti_integers_vs(STRING, NUMBER_OF_INTEGERS, INTG_DATA, ERR, ERROR, *)
5813 
5814  !#### Function: STRING_TO_INTEGER_VS
5815  !### Type: INTEGER(INTG)
5816  !### Description:
5817  !### Converts a varying string representation of a number to an integer.
5818  !### Parent-function: STRING_TO_INTEGER
5819 
5820  !Argument variables
5821  TYPE(varying_string), INTENT(IN) :: STRING
5822  INTEGER(INTG), INTENT(INOUT) :: INTG_DATA(:)
5823  INTEGER(INTG), INTENT(IN) :: NUMBER_OF_INTEGERS
5824  INTEGER(INTG), INTENT(OUT) :: ERR
5825  TYPE(varying_string), INTENT(OUT) :: ERROR
5826  !Local variables
5827  TYPE(varying_string) :: LOCAL_STRING, LOCAL_STRING1
5828  INTEGER(INTG) :: idx, pos
5829 
5830  enters("STRING_TO_MUTI_INTEGERS_VS",err,error,*999)
5831 
5832 !!TODO: remove dependance on LOCAL_STRING
5833 
5834  local_string=string
5835 
5836  DO idx=1,number_of_integers-1
5837  local_string=adjustl(local_string)
5838  local_string=trim(local_string)
5839  pos=index(local_string, " ")
5840  local_string1=extract(local_string, 1, pos-1)
5841  intg_data(idx)=string_to_integer(local_string1, err, error)
5842  local_string=remove(local_string,1,pos)
5843  ENDDO
5844  local_string=adjustl(local_string)
5845  local_string=trim(local_string)
5846  intg_data(idx)=string_to_integer(local_string, err, error)
5847 
5848  exits("STRING_TO_MUTI_INTEGERS_VS")
5849  RETURN
5850 999 errorsexits("STRING_TO_MUTI_INTEGERS_VS",err,error)
5851  RETURN 1
5852  END SUBROUTINE string_to_muti_integers_vs
5853 
5854  SUBROUTINE string_to_muti_reals_vs(STRING, NUMBER_OF_REALS, REAL_DATA, POSITION, ERR, ERROR, *)
5855 
5856  !#### Function: STRING_TO_INTEGER_VS
5857  !### Type: INTEGER(INTG)
5858  !### Description:
5859  !### Converts a varying string representation of a number to an integer.
5860  !### Parent-function: STRING_TO_INTEGER
5861 
5862  !Argument variables
5863  TYPE(varying_string), INTENT(IN) :: STRING
5864  REAL(DP), INTENT(INOUT) :: REAL_DATA(:)
5865  INTEGER(INTG), INTENT(IN) :: NUMBER_OF_REALS
5866  INTEGER(INTG), INTENT(IN) :: POSITION
5867  INTEGER(INTG), INTENT(OUT) :: ERR
5868  TYPE(varying_string), INTENT(OUT) :: ERROR
5869  !Local variables
5870  TYPE(varying_string) :: LOCAL_STRIN