OpenCMISS-Iron Internal API Documentation
equations_set_routines.f90
Go to the documentation of this file.
1 
43 
45 MODULE equations_set_routines
46 
47  USE base_routines
48  USE basis_routines
49  USE bioelectric_routines
50  USE boundary_conditions_routines
51  USE classical_field_routines
52  USE cmiss_mpi
53  USE comp_environment
54  USE constants
55  USE coordinate_routines
56  USE field_routines
57  USE fitting_routines
58  USE distributed_matrix_vector
59  USE domain_mappings
60  USE elasticity_routines
61  USE equations_routines
62  USE equations_set_constants
63  USE equations_matrices_routines
64  USE field_routines
65  USE fluid_mechanics_routines
66  USE input_output
67  USE iso_varying_string
68  USE kinds
69  USE lists
70  USE matrix_vector
71  USE monodomain_equations_routines
72 #ifndef NOMPIMOD
73  USE mpi
74 #endif
75  USE multi_physics_routines
76  USE node_routines
77  USE strings
78  USE timer
79  USE types
80 
81 #include "macros.h"
82 
83  IMPLICIT NONE
84 
85 #ifdef NOMPIMOD
86 #include "mpif.h"
87 #endif
88 
89  PRIVATE
90 
91  !Module parameters
92 
93  !Module types
94 
95  !Module variables
96 
97  !Interfaces
98 
99  PUBLIC equations_set_analytic_create_start,equations_set_analytic_create_finish
100 
101  PUBLIC equations_set_analytic_destroy
102 
103  PUBLIC equations_set_analytic_evaluate
104 
105  PUBLIC equations_set_analytic_time_get,equations_set_analytic_time_set
106 
107  PUBLIC equations_set_assemble
108 
109  PUBLIC equations_set_backsubstitute,equations_set_nonlinear_rhs_update
110 
111  PUBLIC equations_set_boundary_conditions_analytic
112 
113  PUBLIC equations_set_create_start,equations_set_create_finish
114 
115  PUBLIC equations_set_destroy
116 
117  PUBLIC equations_sets_finalise,equations_sets_initialise
118 
119  PUBLIC equations_set_equations_create_finish,equations_set_equations_create_start
120 
121  PUBLIC equations_set_equations_destroy
122 
123  PUBLIC equations_set_materials_create_start,equations_set_materials_create_finish
124 
125  PUBLIC equations_set_materials_destroy
126 
127  PUBLIC equations_set_dependent_create_start,equations_set_dependent_create_finish
128 
129  PUBLIC equations_set_dependent_destroy
130 
131  PUBLIC equationsset_derivedcreatestart,equationsset_derivedcreatefinish
132 
133  PUBLIC equationsset_deriveddestroy
134 
135  PUBLIC equations_set_independent_create_start,equations_set_independent_create_finish
136 
137  PUBLIC equations_set_independent_destroy
138 
139  PUBLIC equations_set_jacobian_evaluate,equations_set_residual_evaluate
140 
141  PUBLIC equations_set_solution_method_get,equations_set_solution_method_set
142 
143  PUBLIC equations_set_source_create_start,equations_set_source_create_finish
144 
145  PUBLIC equations_set_source_destroy
146 
147  PUBLIC equationsset_specificationget,equationsset_specificationsizeget
148 
149  PUBLIC equationsset_tensorinterpolatexi
150 
151  PUBLIC equationsset_derivedvariablecalculate,equationsset_derivedvariableset
152 
153  PUBLIC equations_set_user_number_find
154 
155  PUBLIC equations_set_load_increment_apply
156 
157  PUBLIC equations_set_analytic_user_param_set,equations_set_analytic_user_param_get
158 
159 CONTAINS
160 
161  !
162  !================================================================================================================================
163  !
164 
166  SUBROUTINE equations_set_analytic_create_finish(EQUATIONS_SET,ERR,ERROR,*)
167 
168  !Argument variables
169  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
170  INTEGER(INTG), INTENT(OUT) :: ERR
171  TYPE(varying_string), INTENT(OUT) :: ERROR
172  !Local Variables
173  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
174  TYPE(field_type), POINTER :: ANALYTIC_FIELD
175 
176  enters("EQUATIONS_SET_ANALYTIC_CREATE_FINISH",err,error,*999)
177 
178  IF(ASSOCIATED(equations_set)) THEN
179  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
180  IF(equations_set%ANALYTIC%ANALYTIC_FINISHED) THEN
181  CALL flagerror("Equations set analytic has already been finished.",err,error,*999)
182  ELSE
183  !Initialise the setup
184  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
185  equations_set_setup_info%SETUP_TYPE=equations_set_setup_analytic_type
186  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
187  analytic_field=>equations_set%ANALYTIC%ANALYTIC_FIELD
188  IF(ASSOCIATED(analytic_field)) THEN
189  equations_set_setup_info%FIELD_USER_NUMBER=analytic_field%USER_NUMBER
190  equations_set_setup_info%FIELD=>analytic_field
191  ENDIF
192  !Finish the equations set specific analytic setup
193  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
194  !Finalise the setup
195  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
196  !Finish the analytic creation
197  equations_set%ANALYTIC%ANALYTIC_FINISHED=.true.
198  ENDIF
199  ELSE
200  CALL flagerror("The equations set analytic is not associated.",err,error,*999)
201  ENDIF
202  ELSE
203  CALL flagerror("Equations set is not associated.",err,error,*999)
204  ENDIF
205 
206  exits("EQUATIONS_SET_ANALYTIC_CREATE_FINISH")
207  RETURN
208 999 errorsexits("EQUATIONS_SET_ANALYTIC_CREATE_FINISH",err,error)
209  RETURN 1
210  END SUBROUTINE equations_set_analytic_create_finish
211 
212  !
213  !================================================================================================================================
214  !
215 
217  SUBROUTINE equations_set_analytic_create_start(EQUATIONS_SET,ANALYTIC_FUNCTION_TYPE,ANALYTIC_FIELD_USER_NUMBER,ANALYTIC_FIELD, &
218  & err,error,*)
219 
220  !Argument variables
221  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
222  INTEGER(INTG), INTENT(IN) :: ANALYTIC_FUNCTION_TYPE
223  INTEGER(INTG), INTENT(IN) :: ANALYTIC_FIELD_USER_NUMBER
224  TYPE(field_type), POINTER :: ANALYTIC_FIELD
225  INTEGER(INTG), INTENT(OUT) :: ERR
226  TYPE(varying_string), INTENT(OUT) :: ERROR
227  !Local Variables
228  INTEGER(INTG) :: DUMMY_ERR
229  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
230  TYPE(field_type), POINTER :: FIELD,GEOMETRIC_FIELD
231  TYPE(region_type), POINTER :: REGION,ANALYTIC_FIELD_REGION
232  TYPE(varying_string) :: DUMMY_ERROR,LOCAL_ERROR
233 
234  enters("EQUATIONS_SET_ANALYTIC_CREATE_START",err,error,*998)
235 
236  IF(ASSOCIATED(equations_set)) THEN
237  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
238  CALL flagerror("The equations set analytic is already associated.",err,error,*998)
239  ELSE
240  region=>equations_set%REGION
241  IF(ASSOCIATED(region)) THEN
242  IF(ASSOCIATED(analytic_field)) THEN
243  !Check the analytic field has been finished
244  IF(analytic_field%FIELD_FINISHED) THEN
245  !Check the user numbers match
246  IF(analytic_field_user_number/=analytic_field%USER_NUMBER) THEN
247  local_error="The specified analytic field user number of "// &
248  & trim(number_to_vstring(analytic_field_user_number,"*",err,error))// &
249  & " does not match the user number of the specified analytic field of "// &
250  & trim(number_to_vstring(analytic_field%USER_NUMBER,"*",err,error))//"."
251  CALL flagerror(local_error,err,error,*999)
252  ENDIF
253  analytic_field_region=>analytic_field%REGION
254  IF(ASSOCIATED(analytic_field_region)) THEN
255  !Check the field is defined on the same region as the equations set
256  IF(analytic_field_region%USER_NUMBER/=region%USER_NUMBER) THEN
257  local_error="Invalid region setup. The specified analytic field has been created on region number "// &
258  & trim(number_to_vstring(analytic_field_region%USER_NUMBER,"*",err,error))// &
259  & " and the specified equations set has been created on region number "// &
260  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
261  CALL flagerror(local_error,err,error,*999)
262  ENDIF
263  !Check the specified analytic field has the same decomposition as the geometric field
264  geometric_field=>equations_set%GEOMETRY%GEOMETRIC_FIELD
265  IF(ASSOCIATED(geometric_field)) THEN
266  IF(.NOT.ASSOCIATED(geometric_field%DECOMPOSITION,analytic_field%DECOMPOSITION)) THEN
267  CALL flagerror("The specified analytic field does not have the same decomposition as the geometric "// &
268  & "field for the specified equations set.",err,error,*999)
269  ENDIF
270  ELSE
271  CALL flagerror("The geometric field is not associated for the specified equations set.",err,error,*999)
272  ENDIF
273  ELSE
274  CALL flagerror("The specified analytic field region is not associated.",err,error,*999)
275  ENDIF
276  ELSE
277  CALL flagerror("The specified analytic field has not been finished.",err,error,*999)
278  ENDIF
279  ELSE
280  !Check the user number has not already been used for a field in this region.
281  NULLIFY(field)
282  CALL field_user_number_find(analytic_field_user_number,region,field,err,error,*999)
283  IF(ASSOCIATED(field)) THEN
284  local_error="The specified analytic field user number of "// &
285  & trim(number_to_vstring(analytic_field_user_number,"*",err,error))// &
286  & "has already been used to create a field on region number "// &
287  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
288  CALL flagerror(local_error,err,error,*999)
289  ENDIF
290  ENDIF
291  !Initialise the equations set analytic
292  CALL equations_set_analytic_initialise(equations_set,err,error,*999)
293  IF(.NOT.ASSOCIATED(analytic_field)) equations_set%ANALYTIC%ANALYTIC_FIELD_AUTO_CREATED=.true.
294  !Initialise the setup
295  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
296  equations_set_setup_info%SETUP_TYPE=equations_set_setup_analytic_type
297  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
298  equations_set_setup_info%FIELD_USER_NUMBER=analytic_field_user_number
299  equations_set_setup_info%FIELD=>analytic_field
300  equations_set_setup_info%ANALYTIC_FUNCTION_TYPE=analytic_function_type
301  !Start the equations set specific analytic setup
302  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
303  !Finalise the setup
304  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
305  !Set pointers
306  IF(equations_set%ANALYTIC%ANALYTIC_FIELD_AUTO_CREATED) THEN
307  analytic_field=>equations_set%ANALYTIC%ANALYTIC_FIELD
308  ELSE
309  equations_set%ANALYTIC%ANALYTIC_FIELD=>analytic_field
310  ENDIF
311  ELSE
312  CALL flagerror("Equations set region is not associated.",err,error,*999)
313  ENDIF
314  ENDIF
315  ELSE
316  CALL flagerror("Equations set is not associated.",err,error,*998)
317  ENDIF
318 
319  exits("EQUATIONS_SET_ANALYTIC_CREATE_START")
320  RETURN
321 999 CALL equations_set_analytic_finalise(equations_set%ANALYTIC,dummy_err,dummy_error,*998)
322 998 errorsexits("EQUATIONS_SET_ANALYTIC_CREATE_START",err,error)
323  RETURN 1
324  END SUBROUTINE equations_set_analytic_create_start
325 
326  !
327  !================================================================================================================================
328  !
329 
331  SUBROUTINE equations_set_analytic_destroy(EQUATIONS_SET,ERR,ERROR,*)
332 
333  !Argument variables
334  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
335  INTEGER(INTG), INTENT(OUT) :: ERR
336  TYPE(varying_string), INTENT(OUT) :: ERROR
337  !Local Variables
338 
339  enters("EQUATIONS_SET_ANALYTIC_DESTROY",err,error,*999)
340 
341  IF(ASSOCIATED(equations_set)) THEN
342  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
343  CALL equations_set_analytic_finalise(equations_set%ANALYTIC,err,error,*999)
344  ELSE
345  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
346  ENDIF
347  ELSE
348  CALL flagerror("Equations set is not associated.",err,error,*999)
349  ENDIF
350 
351  exits("EQUATIONS_SET_ANALYTIC_DESTROY")
352  RETURN
353 999 errorsexits("EQUATIONS_SET_ANALYTIC_DESTROY",err,error)
354  RETURN 1
355  END SUBROUTINE equations_set_analytic_destroy
356 
357  !
358  !================================================================================================================================
359  !
360 
362  SUBROUTINE equations_set_analytic_evaluate(EQUATIONS_SET,ERR,ERROR,*)
363 
364  !Argument variables
365  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
366  INTEGER(INTG), INTENT(OUT) :: ERR
367  TYPE(varying_string), INTENT(OUT) :: ERROR
368  !Local Variables
369  INTEGER(INTG) :: component_idx,derivative_idx,element_idx,Gauss_idx,GLOBAL_DERIV_INDEX,local_ny,node_idx, &
370  & NUMBER_OF_ANALYTIC_COMPONENTS,NUMBER_OF_DIMENSIONS,variable_idx, &
371  & variable_type,version_idx
372  REAL(DP) :: NORMAL(3),POSITION(3),TANGENTS(3,3),VALUE
373  REAL(DP) :: ANALYTIC_DUMMY_VALUES(1)=0.0_dp
374  REAL(DP) :: MATERIALS_DUMMY_VALUES(1)=0.0_dp
375  LOGICAL :: reverseNormal=.false.
376  TYPE(basis_type), POINTER :: BASIS
377  TYPE(domain_type), POINTER :: DOMAIN
378  TYPE(domain_elements_type), POINTER :: DOMAIN_ELEMENTS
379  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES
380  TYPE(field_type), POINTER :: ANALYTIC_FIELD,DEPENDENT_FIELD,GEOMETRIC_FIELD,MATERIALS_FIELD
381  TYPE(field_interpolation_parameters_ptr_type), POINTER :: ANALYTIC_INTERP_PARAMETERS(:),GEOMETRIC_INTERP_PARAMETERS(:), &
382  & MATERIALS_INTERP_PARAMETERS(:)
383  TYPE(field_interpolated_point_ptr_type), POINTER :: ANALYTIC_INTERP_POINT(:),GEOMETRIC_INTERP_POINT(:), &
384  & MATERIALS_INTERP_POINT(:)
385  TYPE(field_interpolated_point_metrics_ptr_type), POINTER :: GEOMETRIC_INTERPOLATED_POINT_METRICS(:)
386  TYPE(field_physical_point_ptr_type), POINTER :: ANALYTIC_PHYSICAL_POINT(:),MATERIALS_PHYSICAL_POINT(:)
387  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
388  TYPE(varying_string) :: LOCAL_ERROR
389 
390  enters("EQUATIONS_SET_ANALYTIC_EVALUATE",err,error,*999)
391 
392  IF(ASSOCIATED(equations_set)) THEN
393  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
394  IF(equations_set%ANALYTIC%ANALYTIC_FINISHED) THEN
395  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
396  IF(ASSOCIATED(dependent_field)) THEN
397  geometric_field=>equations_set%GEOMETRY%GEOMETRIC_FIELD
398  IF(ASSOCIATED(geometric_field)) THEN
399  CALL field_numberofcomponentsget(geometric_field,field_u_variable_type,number_of_dimensions,err,error,*999)
400  CALL field_interpolationparametersinitialise(geometric_field,geometric_interp_parameters,err,error,*999)
401  CALL field_interpolatedpointsinitialise(geometric_interp_parameters,geometric_interp_point,err,error,*999)
402  CALL field_interpolatedpointsmetricsinitialise(geometric_interp_point,geometric_interpolated_point_metrics, &
403  & err,error,*999)
404  analytic_field=>equations_set%ANALYTIC%ANALYTIC_FIELD
405  IF(ASSOCIATED(analytic_field)) THEN
406  CALL field_numberofcomponentsget(analytic_field,field_u_variable_type,number_of_analytic_components, &
407  & err,error,*999)
408  CALL field_interpolationparametersinitialise(analytic_field,analytic_interp_parameters,err,error,*999)
409  CALL field_interpolatedpointsinitialise(analytic_interp_parameters,analytic_interp_point,err,error,*999)
410  CALL field_physicalpointsinitialise(analytic_interp_point,geometric_interp_point,analytic_physical_point, &
411  & err,error,*999)
412  ENDIF
413  NULLIFY(materials_field)
414  IF(ASSOCIATED(equations_set%MATERIALS)) THEN
415  materials_field=>equations_set%MATERIALS%MATERIALS_FIELD
416  CALL field_numberofcomponentsget(materials_field,field_u_variable_type,number_of_analytic_components, &
417  & err,error,*999)
418  CALL field_interpolationparametersinitialise(materials_field,materials_interp_parameters,err,error,*999)
419  CALL field_interpolatedpointsinitialise(materials_interp_parameters,materials_interp_point,err,error,*999)
420  CALL field_physicalpointsinitialise(materials_interp_point,geometric_interp_point,materials_physical_point, &
421  & err,error,*999)
422  ENDIF
423  DO variable_idx=1,dependent_field%NUMBER_OF_VARIABLES
424  variable_type=dependent_field%VARIABLES(variable_idx)%VARIABLE_TYPE
425  field_variable=>dependent_field%VARIABLE_TYPE_MAP(variable_type)%PTR
426  IF(ASSOCIATED(field_variable)) THEN
427  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
428  domain=>field_variable%COMPONENTS(component_idx)%DOMAIN
429  IF(ASSOCIATED(domain)) THEN
430  IF(ASSOCIATED(domain%TOPOLOGY)) THEN
431  SELECT CASE(field_variable%COMPONENTS(component_idx)%INTERPOLATION_TYPE)
432  CASE(field_constant_interpolation)
433  CALL flagerror("Cannot evaluate an analytic solution for a constant interpolation components.", &
434  & err,error,*999)
435  CASE(field_element_based_interpolation)
436  domain_elements=>domain%TOPOLOGY%ELEMENTS
437  IF(ASSOCIATED(domain_elements)) THEN
438  !Loop over the local elements excluding the ghosts
439  DO element_idx=1,domain_elements%NUMBER_OF_ELEMENTS
440  basis=>domain_elements%ELEMENTS(element_idx)%BASIS
441  CALL field_interpolationparameterselementget(field_values_set_type,element_idx, &
442  & geometric_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
443  IF(ASSOCIATED(analytic_field)) THEN
444  CALL field_interpolationparameterselementget(field_values_set_type,element_idx, &
445  & analytic_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
446  ENDIF
447  IF(ASSOCIATED(materials_field)) THEN
448  CALL field_interpolationparameterselementget(field_values_set_type,element_idx, &
449  & materials_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
450  ENDIF
451  CALL field_interpolate_xi(first_part_deriv,[0.5_dp,0.5_dp,0.5_dp], &
452  & geometric_interp_point(field_u_variable_type)%PTR,err,error,*999)
453  CALL field_interpolatedpointmetricscalculate(coordinate_jacobian_no_type, &
454  & geometric_interpolated_point_metrics(field_u_variable_type)%PTR,err,error,*999)
455  CALL field_positionnormaltangentscalculateintptmetric( &
456  & geometric_interpolated_point_metrics(field_u_variable_type)%PTR,reversenormal, &
457  & position,normal,tangents,err,error,*999)
458  IF(ASSOCIATED(analytic_field)) THEN
459  CALL field_interpolate_xi(no_part_deriv,[0.5_dp,0.5_dp,0.5_dp], &
460  & analytic_interp_point(field_u_variable_type)%PTR,err,error,*999)
461  ENDIF
462  IF(ASSOCIATED(materials_field)) THEN
463  CALL field_interpolate_xi(no_part_deriv,[0.5_dp,0.5_dp,0.5_dp], &
464  & materials_interp_point(field_u_variable_type)%PTR,err,error,*999)
465  ENDIF
466 !! \todo Maybe do this with optional arguments?
467  IF(ASSOCIATED(analytic_field)) THEN
468  IF(ASSOCIATED(materials_field)) THEN
469  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
470  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
471  & variable_type,global_deriv_index,component_idx, &
472  & analytic_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
473  & materials_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
474  & VALUE,err,error,*999)
475  ELSE
476  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
477  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
478  & variable_type,global_deriv_index,component_idx, &
479  & analytic_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
480  & materials_dummy_values,VALUE,err,error,*999)
481  ENDIF
482  ELSE
483  IF(ASSOCIATED(materials_field)) THEN
484  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
485  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
486  & variable_type,global_deriv_index,component_idx,analytic_dummy_values, &
487  & materials_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
488  & VALUE,err,error,*999)
489  ELSE
490  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
491  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
492  & variable_type,global_deriv_index,component_idx,analytic_dummy_values, &
493  & materials_dummy_values,VALUE,err,error,*999)
494  ENDIF
495  ENDIF
496  local_ny=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP% &
497  & element_param2dof_map%ELEMENTS(element_idx)
498  CALL field_parametersetupdatelocaldof(dependent_field,variable_type, &
499  & field_analytic_values_set_type,local_ny,VALUE,err,error,*999)
500  ENDDO !element_idx
501  ELSE
502  CALL flagerror("Domain topology elements is not associated.",err,error,*999)
503  ENDIF
504  CASE(field_node_based_interpolation)
505  domain_nodes=>domain%TOPOLOGY%NODES
506  IF(ASSOCIATED(domain_nodes)) THEN
507  !Loop over the local nodes excluding the ghosts.
508  DO node_idx=1,domain_nodes%NUMBER_OF_NODES
509  CALL field_positionnormaltangentscalculatenode(dependent_field,variable_type,component_idx, &
510  & node_idx,position,normal,tangents,err,error,*999)
511  IF(ASSOCIATED(analytic_field)) THEN
512  CALL field_interpolate_field_node(no_physical_deriv,field_values_set_type,analytic_field, &
513  & field_u_variable_type,component_idx,node_idx,analytic_physical_point( &
514  & field_u_variable_type)%PTR,err,error,*999)
515  ENDIF
516  IF(ASSOCIATED(materials_field)) THEN
517  CALL field_interpolate_field_node(no_physical_deriv,field_values_set_type,materials_field, &
518  & field_u_variable_type,component_idx,node_idx,materials_physical_point( &
519  & field_u_variable_type)%PTR,err,error,*999)
520  ENDIF
521  !Loop over the derivatives
522  DO derivative_idx=1,domain_nodes%NODES(node_idx)%NUMBER_OF_DERIVATIVES
523  global_deriv_index=domain_nodes%NODES(node_idx)%DERIVATIVES(derivative_idx)% &
524  & global_derivative_index
525 !! \todo Maybe do this with optional arguments?
526  IF(ASSOCIATED(analytic_field)) THEN
527  IF(ASSOCIATED(materials_field)) THEN
528  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
529  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
530  & variable_type,global_deriv_index,component_idx, &
531  & analytic_physical_point(field_u_variable_type)%PTR%VALUES, &
532  & materials_physical_point(field_u_variable_type)%PTR%VALUES,VALUE,err,error,*999)
533  ELSE
534  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
535  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
536  & variable_type,global_deriv_index,component_idx, &
537  & analytic_physical_point(field_u_variable_type)%PTR%VALUES, &
538  & materials_dummy_values,VALUE,err,error,*999)
539  ENDIF
540  ELSE
541  IF(ASSOCIATED(materials_field)) THEN
542  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
543  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
544  & variable_type,global_deriv_index,component_idx,analytic_dummy_values, &
545  & materials_physical_point(field_u_variable_type)%PTR%VALUES,VALUE,err,error,*999)
546  ELSE
547  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
548  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
549  & variable_type,global_deriv_index,component_idx,analytic_dummy_values, &
550  & materials_dummy_values,VALUE,err,error,*999)
551  ENDIF
552  ENDIF
553  !Loop over the versions
554  DO version_idx=1,domain_nodes%NODES(node_idx)%DERIVATIVES(derivative_idx)%numberOfVersions
555  local_ny=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP% &
556  & node_param2dof_map%NODES(node_idx)%DERIVATIVES(derivative_idx)%VERSIONS(version_idx)
557  CALL field_parametersetupdatelocaldof(dependent_field,variable_type, &
558  & field_analytic_values_set_type,local_ny,VALUE,err,error,*999)
559  ENDDO !version_idx
560  ENDDO !deriv_idx
561  ENDDO !node_idx
562  ELSE
563  CALL flagerror("Domain topology nodes is not associated.",err,error,*999)
564  ENDIF
565  CASE(field_grid_point_based_interpolation)
566  CALL flagerror("Not implemented.",err,error,*999)
567  CASE(field_gauss_point_based_interpolation)
568  domain_elements=>domain%TOPOLOGY%ELEMENTS
569  IF(ASSOCIATED(domain_elements)) THEN
570  !Loop over the local elements excluding the ghosts
571  DO element_idx=1,domain_elements%NUMBER_OF_ELEMENTS
572  basis=>domain_elements%ELEMENTS(element_idx)%BASIS
573  CALL field_interpolationparameterselementget(field_values_set_type,element_idx, &
574  & geometric_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
575  IF(ASSOCIATED(analytic_field)) THEN
576  CALL field_interpolationparameterselementget(field_values_set_type,element_idx, &
577  & analytic_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
578  ENDIF
579  IF(ASSOCIATED(materials_field)) THEN
580  CALL field_interpolationparameterselementget(field_values_set_type,element_idx, &
581  & materials_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
582  ENDIF
583  !Loop over the Gauss points in the element
584  DO gauss_idx=1,basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR% &
585  & number_of_gauss
586  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
587  & geometric_interp_point(field_u_variable_type)%PTR,err,error,*999)
588  CALL field_interpolatedpointmetricscalculate(coordinate_jacobian_no_type, &
589  & geometric_interpolated_point_metrics(field_u_variable_type)%PTR,err,error,*999)
590  CALL field_positionnormaltangentscalculateintptmetric( &
591  & geometric_interpolated_point_metrics(field_u_variable_type)%PTR,reversenormal, &
592  & position,normal,tangents,err,error,*999)
593  IF(ASSOCIATED(analytic_field)) THEN
594  CALL field_interpolategauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
595  & analytic_interp_point(field_u_variable_type)%PTR,err,error,*999)
596  ENDIF
597  IF(ASSOCIATED(materials_field)) THEN
598  CALL field_interpolategauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
599  & materials_interp_point(field_u_variable_type)%PTR,err,error,*999)
600  ENDIF
601 !! \todo Maybe do this with optional arguments?
602  IF(ASSOCIATED(analytic_field)) THEN
603  IF(ASSOCIATED(materials_field)) THEN
604  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
605  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
606  & variable_type,global_deriv_index,component_idx, &
607  & analytic_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
608  & materials_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
609  & VALUE,err,error,*999)
610  ELSE
611  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
612  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
613  & variable_type,global_deriv_index,component_idx, &
614  & analytic_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
615  & materials_dummy_values,VALUE,err,error,*999)
616  ENDIF
617  ELSE
618  IF(ASSOCIATED(materials_field)) THEN
619  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
620  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
621  & variable_type,global_deriv_index,component_idx,analytic_dummy_values, &
622  & materials_interp_point(field_u_variable_type)%PTR%VALUES(:,no_part_deriv), &
623  & VALUE,err,error,*999)
624  ELSE
625  CALL equations_set_analytic_functions_evaluate(equations_set,equations_set%ANALYTIC% &
626  & analytic_function_type,position,tangents,normal,equations_set%ANALYTIC%ANALYTIC_TIME, &
627  & variable_type,global_deriv_index,component_idx,analytic_dummy_values, &
628  & materials_dummy_values,VALUE,err,error,*999)
629  ENDIF
630  ENDIF
631  local_ny=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP% &
632  & gauss_point_param2dof_map%GAUSS_POINTS(gauss_idx,element_idx)
633  CALL field_parametersetupdatelocaldof(dependent_field,variable_type, &
634  & field_analytic_values_set_type,local_ny,VALUE,err,error,*999)
635  ENDDO !Gauss_idx
636  ENDDO !element_idx
637  ELSE
638  CALL flagerror("Domain topology elements is not associated.",err,error,*999)
639  ENDIF
640  CASE DEFAULT
641  local_error="The interpolation type of "//trim(number_to_vstring(field_variable% &
642  & components(component_idx)%INTERPOLATION_TYPE,"*",err,error))// &
643  & " for component "//trim(number_to_vstring(component_idx,"*",err,error))//" of variable type "// &
644  & trim(number_to_vstring(variable_type,"*",err,error))//" is invalid."
645  CALL flagerror(local_error,err,error,*999)
646  END SELECT
647  ELSE
648  CALL flagerror("Domain topology is not associated.",err,error,*999)
649  ENDIF
650  ELSE
651  CALL flagerror("Domain is not associated.",err,error,*999)
652  ENDIF
653  ENDDO !component_idx
654  CALL field_parametersetupdatestart(dependent_field,variable_type, &
655  & field_analytic_values_set_type,err,error,*999)
656  CALL field_parametersetupdatefinish(dependent_field,variable_type, &
657  & field_analytic_values_set_type,err,error,*999)
658  ELSE
659  CALL flagerror("Field variable is not associated.",err,error,*999)
660  ENDIF
661  ENDDO !variable_idx
662  IF(ASSOCIATED(materials_field)) THEN
663  CALL field_physical_points_finalise(materials_physical_point,err,error,*999)
664  CALL field_interpolated_points_finalise(materials_interp_point,err,error,*999)
665  CALL field_interpolation_parameters_finalise(materials_interp_parameters,err,error,*999)
666  ENDIF
667  IF(ASSOCIATED(analytic_field)) THEN
668  CALL field_physical_points_finalise(analytic_physical_point,err,error,*999)
669  CALL field_interpolated_points_finalise(analytic_interp_point,err,error,*999)
670  CALL field_interpolation_parameters_finalise(analytic_interp_parameters,err,error,*999)
671  ENDIF
672  CALL field_interpolatedpointsmetricsfinalise(geometric_interpolated_point_metrics,err,error,*999)
673  CALL field_interpolated_points_finalise(geometric_interp_point,err,error,*999)
674  CALL field_interpolation_parameters_finalise(geometric_interp_parameters,err,error,*999)
675 
676  ELSE
677  CALL flagerror("Equations set geometric field is not associated.",err,error,*999)
678  ENDIF
679  ELSE
680  CALL flagerror("Equations set dependent field is not associated.",err,error,*999)
681  ENDIF
682  ELSE
683  CALL flagerror("Equations set analytic has not been finished.",err,error,*999)
684  ENDIF
685  ELSE
686  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
687  ENDIF
688  ELSE
689  CALL flagerror("Equations set is not associated.",err,error,*999)
690  ENDIF
691 
692  exits("EQUATIONS_SET_ANALYTIC_EVALUATE")
693  RETURN
694 999 errorsexits("EQUATIONS_SET_ANALYTIC_EVALUATE",err,error)
695  RETURN 1
696 
697  END SUBROUTINE equations_set_analytic_evaluate
698 
699  !
700  !================================================================================================================================
701  !
702 
704  SUBROUTINE equations_set_analytic_finalise(EQUATIONS_SET_ANALYTIC,ERR,ERROR,*)
705 
706  !Argument variables
707  TYPE(equations_set_analytic_type), POINTER :: EQUATIONS_SET_ANALYTIC
708  INTEGER(INTG), INTENT(OUT) :: ERR
709  TYPE(varying_string), INTENT(OUT) :: ERROR
710  !Local Variables
711 
712  enters("EQUATIONS_SET_ANALYTIC_FINALISE",err,error,*999)
713 
714  IF(ASSOCIATED(equations_set_analytic)) THEN
715  DEALLOCATE(equations_set_analytic)
716  ENDIF
717 
718  exits("EQUATIONS_SET_ANALYTIC_FINALISE")
719  RETURN
720 999 errorsexits("EQUATIONS_SET_ANALYTIC_FINALISE",err,error)
721  RETURN 1
722  END SUBROUTINE equations_set_analytic_finalise
723 
724  !
725  !================================================================================================================================
726  !
727 
729  SUBROUTINE equations_set_analytic_functions_evaluate(EQUATIONS_SET,ANALYTIC_FUNCTION_TYPE,POSITION,TANGENTS,NORMAL,TIME, &
730  & variable_type,global_derivative,component_number,analytic_parameters,materials_parameters,VALUE,err,error,*)
731 
732  !Argument variables
733  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
734  INTEGER(INTG), INTENT(IN) :: ANALYTIC_FUNCTION_TYPE
735  REAL(DP), INTENT(IN) :: POSITION(:)
736  REAL(DP), INTENT(IN) :: TANGENTS(:,:)
737  REAL(DP), INTENT(IN) :: NORMAL(:)
738  REAL(DP), INTENT(IN) :: TIME
739  INTEGER(INTG), INTENT(IN) :: VARIABLE_TYPE
740  INTEGER(INTG), INTENT(IN) :: GLOBAL_DERIVATIVE
741  INTEGER(INTG), INTENT(IN) :: COMPONENT_NUMBER
742  REAL(DP), INTENT(IN) :: ANALYTIC_PARAMETERS(:)
743  REAL(DP), INTENT(IN) :: MATERIALS_PARAMETERS(:)
744  REAL(DP), INTENT(OUT) :: VALUE
745  INTEGER(INTG), INTENT(OUT) :: ERR
746  TYPE(varying_string), INTENT(OUT) :: ERROR
747  !Local Variables
748  TYPE(varying_string) :: LOCAL_ERROR
749 
750  enters("EQUATIONS_SET_ANALYTIC_FUNCTIONS_EVALUATE",err,error,*999)
751 
752  IF(ASSOCIATED(equations_set)) THEN
753  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
754  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
755  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
756  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
757  END IF
758  SELECT CASE(equations_set%SPECIFICATION(1))
759  CASE(equations_set_elasticity_class)
760  CALL flagerror("Not implemented.",err,error,*999)
761  CASE(equations_set_fluid_mechanics_class)
762  CALL flagerror("Not implemented.",err,error,*999)
763  CASE(equations_set_electromagnetics_class)
764  CALL flagerror("Not implemented.",err,error,*999)
765  CASE(equations_set_classical_field_class)
766  IF(SIZE(equations_set%SPECIFICATION,1)<2) THEN
767  CALL flagerror("Equations set specification must have at least two entries for a "// &
768  & "classical field equations set.",err,error,*999)
769  END IF
770  CALL classical_field_analytic_functions_evaluate(equations_set,equations_set%SPECIFICATION(2), &
771  & analytic_function_type,position,tangents,normal,time,variable_type,global_derivative, &
772  & component_number,analytic_parameters,materials_parameters,VALUE,err,error,*999)
773  CASE(equations_set_fitting_class)
774  CALL flagerror("Not implemented.",err,error,*999)
775  CASE(equations_set_bioelectrics_class)
776  CALL flagerror("Not implemented.",err,error,*999)
777  CASE(equations_set_modal_class)
778  CALL flagerror("Not implemented.",err,error,*999)
779  CASE(equations_set_multi_physics_class)
780  CALL flagerror("Not implemented.",err,error,*999)
781  CASE DEFAULT
782  local_error="The first equations set specification of "// &
783  & trim(number_to_vstring(equations_set%SPECIFICATION(1),"*",err,error))//" is not valid."
784  CALL flag_error(local_error,err,error,*999)
785  END SELECT
786  ELSE
787  CALL flagerror("Equations set is not associated.",err,error,*999)
788  ENDIF
789 
790  exits("EQUATIONS_SET_ANALYTIC_FUNCTIONS_EVALUATE")
791  RETURN
792 999 errorsexits("EQUATIONS_SET_ANALYTIC_FUNCTIONS_EVALUATE",err,error)
793  RETURN 1
794 
795  END SUBROUTINE equations_set_analytic_functions_evaluate
796 
797  !
798  !================================================================================================================================
799  !
800 
802  SUBROUTINE equations_set_analytic_initialise(EQUATIONS_SET,ERR,ERROR,*)
803 
804  !Argument variables
805  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
806  INTEGER(INTG), INTENT(OUT) :: ERR
807  TYPE(varying_string), INTENT(OUT) :: ERROR
808  !Local Variables
809  INTEGER(INTG) :: DUMMY_ERR
810  TYPE(varying_string) :: DUMMY_ERROR
811 
812  enters("EQUATIONS_SET_ANALYTIC_INITIALISE",err,error,*998)
813 
814  IF(ASSOCIATED(equations_set)) THEN
815  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
816  CALL flagerror("Analytic is already associated for this equations set.",err,error,*998)
817  ELSE
818  ALLOCATE(equations_set%ANALYTIC,stat=err)
819  IF(err/=0) CALL flagerror("Could not allocate equations set analytic.",err,error,*999)
820  equations_set%ANALYTIC%EQUATIONS_SET=>equations_set
821  equations_set%ANALYTIC%ANALYTIC_FINISHED=.false.
822  equations_set%ANALYTIC%ANALYTIC_FIELD_AUTO_CREATED=.false.
823  NULLIFY(equations_set%ANALYTIC%ANALYTIC_FIELD)
824  equations_set%ANALYTIC%ANALYTIC_TIME=0.0_dp
825  ENDIF
826  ELSE
827  CALL flagerror("Equations set is not associated.",err,error,*998)
828  ENDIF
829 
830  exits("EQUATIONS_SET_ANALYTIC_INITIALISE")
831  RETURN
832 999 CALL equations_set_analytic_finalise(equations_set%ANALYTIC,dummy_err,dummy_error,*998)
833 998 errorsexits("EQUATIONS_SET_ANALYTIC_INITIALISE",err,error)
834  RETURN 1
835 
836  END SUBROUTINE equations_set_analytic_initialise
837 
838  !
839  !================================================================================================================================
840  !
841 
843  SUBROUTINE equations_set_analytic_time_get(EQUATIONS_SET,TIME,ERR,ERROR,*)
844 
845  !Argument variables
846  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
847  REAL(DP), INTENT(OUT) :: TIME
848  INTEGER(INTG), INTENT(OUT) :: ERR
849  TYPE(varying_string), INTENT(OUT) :: ERROR
850  !Local Variables
851 
852  enters("EQUATIONS_SET_ANALYTIC_TIME_GET",err,error,*999)
853 
854  IF(ASSOCIATED(equations_set)) THEN
855  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
856  time=equations_set%ANALYTIC%ANALYTIC_TIME
857  ELSE
858  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
859  ENDIF
860  ELSE
861  CALL flagerror("Equations set is not associated.",err,error,*999)
862  ENDIF
863 
864  exits("EQUATIONS_SET_ANALYTIC_TIME_GET")
865  RETURN
866 999 errorsexits("EQUATIONS_SET_ANALYTIC_TIME_GET",err,error)
867  RETURN 1
868 
869  END SUBROUTINE equations_set_analytic_time_get
870 
871  !
872  !================================================================================================================================
873  !
874 
876  SUBROUTINE equations_set_analytic_time_set(EQUATIONS_SET,TIME,ERR,ERROR,*)
877 
878  !Argument variables
879  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
880  REAL(DP), INTENT(IN) :: TIME
881  INTEGER(INTG), INTENT(OUT) :: ERR
882  TYPE(varying_string), INTENT(OUT) :: ERROR
883  !Local Variables
884 
885  enters("EQUATIONS_SET_ANALYTIC_TIME_SET",err,error,*999)
886 
887  IF(ASSOCIATED(equations_set)) THEN
888  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
889  equations_set%ANALYTIC%ANALYTIC_TIME=time
890  ELSE
891  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
892  ENDIF
893  ELSE
894  CALL flagerror("Equations set is not associated.",err,error,*999)
895  ENDIF
896 
897  exits("EQUATIONS_SET_ANALYTIC_TIME_SET")
898  RETURN
899 999 errorsexits("EQUATIONS_SET_ANALYTIC_TIME_SET",err,error)
900  RETURN 1
901 
902  END SUBROUTINE equations_set_analytic_time_set
903 
904  !
905  !================================================================================================================================
906  !
907 
909  SUBROUTINE equations_set_analytic_user_param_set(EQUATIONS_SET,PARAM_IDX,PARAM,ERR,ERROR,*)
910  !Argument variables
911  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
912  INTEGER(INTG), INTENT(IN) :: PARAM_IDX
913  REAL(DP), INTENT(IN) :: PARAM
914  INTEGER(INTG), INTENT(OUT) :: ERR
915  TYPE(varying_string), INTENT(OUT) :: ERROR
916  !Local variables
917  TYPE(equations_set_analytic_type), POINTER :: ANALYTIC
918 
919  enters("EQUATIONS_SET_ANALYTIC_USER_PARAM_SET",err,error,*999)
920 
921  IF(ASSOCIATED(equations_set)) THEN
922  analytic=>equations_set%ANALYTIC
923  IF(ASSOCIATED(analytic)) THEN
924  IF(param_idx>0.AND.param_idx<=SIZE(analytic%ANALYTIC_USER_PARAMS)) THEN
925  !Set the value
926  analytic%ANALYTIC_USER_PARAMS(param_idx)=param
927  ELSE
928  CALL flagerror("Invalid parameter index.",err,error,*999)
929  ENDIF
930  ELSE
931  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
932  ENDIF
933  ELSE
934  CALL flagerror("Equations set is not associated.",err,error,*999)
935  ENDIF
936 
937  exits("EQUATIONS_SET_ANALYTIC_USER_PARAM_SET")
938  RETURN
939 999 errorsexits("EQUATIONS_SET_ANALYTIC_USER_PARAM_SET",err,error)
940  RETURN 1
941  END SUBROUTINE equations_set_analytic_user_param_set
942 
943  !
944  !================================================================================================================================
945  !
946 
948  SUBROUTINE equations_set_analytic_user_param_get(EQUATIONS_SET,PARAM_IDX,PARAM,ERR,ERROR,*)
949  !Argument variables
950  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
951  INTEGER(INTG), INTENT(IN) :: PARAM_IDX
952  REAL(DP), INTENT(OUT) :: PARAM
953  INTEGER(INTG), INTENT(OUT) :: ERR
954  TYPE(varying_string), INTENT(OUT) :: ERROR
955  !Local variables
956  TYPE(equations_set_analytic_type), POINTER :: ANALYTIC
957 
958  enters("EQUATIONS_SET_ANALYTIC_USER_PARAM_GET",err,error,*999)
959 
960  IF(ASSOCIATED(equations_set)) THEN
961  analytic=>equations_set%ANALYTIC
962  IF(ASSOCIATED(analytic)) THEN
963  IF(param_idx>0.AND.param_idx<=SIZE(analytic%ANALYTIC_USER_PARAMS)) THEN
964  !Set the value
965  param=analytic%ANALYTIC_USER_PARAMS(param_idx)
966  ELSE
967  CALL flagerror("Invalid parameter index.",err,error,*999)
968  ENDIF
969  ELSE
970  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
971  ENDIF
972  ELSE
973  CALL flagerror("Equations set is not associated.",err,error,*999)
974  ENDIF
975 
976  exits("EQUATIONS_SET_ANALYTIC_USER_PARAM_GET")
977  RETURN
978 999 errorsexits("EQUATIONS_SET_ANALYTIC_USER_PARAM_GET",err,error)
979  RETURN 1
980  END SUBROUTINE equations_set_analytic_user_param_get
981 
982  !
983  !================================================================================================================================
984  !
985 
987  SUBROUTINE equations_set_assemble(EQUATIONS_SET,ERR,ERROR,*)
988 
989  !Argument variables
990  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
991  INTEGER(INTG), INTENT(OUT) :: ERR
992  TYPE(varying_string), INTENT(OUT) :: ERROR
993  !Local Variables
994  TYPE(equations_type), POINTER :: EQUATIONS
995  TYPE(varying_string) :: LOCAL_ERROR
996 
997  enters("EQUATIONS_SET_ASSEMBLE",err,error,*999)
998 
999  IF(ASSOCIATED(equations_set)) THEN
1000  equations=>equations_set%EQUATIONS
1001  IF(ASSOCIATED(equations)) THEN
1002  IF(equations%EQUATIONS_FINISHED) THEN
1003  SELECT CASE(equations%TIME_DEPENDENCE)
1004  CASE(equations_static)
1005  SELECT CASE(equations%LINEARITY)
1006  CASE(equations_linear)
1007  SELECT CASE(equations_set%SOLUTION_METHOD)
1008  CASE(equations_set_fem_solution_method)
1009  CALL equations_set_assemble_static_linear_fem(equations_set,err,error,*999)
1010  CASE(equations_set_nodal_solution_method)
1011  CALL flagerror("Not implemented.",err,error,*999)
1012  CASE(equations_set_bem_solution_method)
1013  CALL flagerror("Not implemented.",err,error,*999)
1014  CASE(equations_set_fd_solution_method)
1015  CALL flagerror("Not implemented.",err,error,*999)
1016  CASE(equations_set_fv_solution_method)
1017  CALL flagerror("Not implemented.",err,error,*999)
1018  CASE(equations_set_gfem_solution_method)
1019  CALL flagerror("Not implemented.",err,error,*999)
1020  CASE(equations_set_gfv_solution_method)
1021  CALL flagerror("Not implemented.",err,error,*999)
1022  CASE DEFAULT
1023  local_error="The equations set solution method of "// &
1024  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
1025  & " is invalid."
1026  CALL flagerror(local_error,err,error,*999)
1027  END SELECT
1028  CASE(equations_nonlinear)
1029  SELECT CASE(equations_set%SOLUTION_METHOD)
1030  CASE(equations_set_fem_solution_method)
1031  CALL equations_set_assemble_static_nonlinear_fem(equations_set,err,error,*999)
1032  CASE(equations_set_nodal_solution_method)
1033  CALL equationsset_assemblestaticnonlinearnodal(equations_set,err,error,*999)
1034  CASE(equations_set_bem_solution_method)
1035  CALL flagerror("Not implemented.",err,error,*999)
1036  CASE(equations_set_fd_solution_method)
1037  CALL flagerror("Not implemented.",err,error,*999)
1038  CASE(equations_set_fv_solution_method)
1039  CALL flagerror("Not implemented.",err,error,*999)
1040  CASE(equations_set_gfem_solution_method)
1041  CALL flagerror("Not implemented.",err,error,*999)
1042  CASE(equations_set_gfv_solution_method)
1043  CALL flagerror("Not implemented.",err,error,*999)
1044  CASE DEFAULT
1045  local_error="The equations set solution method of "// &
1046  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
1047  & " is invalid."
1048  CALL flagerror(local_error,err,error,*999)
1049  END SELECT
1050  CASE(equations_nonlinear_bcs)
1051  CALL flagerror("Not implemented.",err,error,*999)
1052  CASE DEFAULT
1053  local_error="The equations linearity of "// &
1054  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))//" is invalid."
1055  CALL flagerror(local_error,err,error,*999)
1056  END SELECT
1057  CASE(equations_quasistatic)
1058 ! chrm, 17/09/09
1059  SELECT CASE(equations%LINEARITY)
1060  CASE(equations_linear)
1061  SELECT CASE(equations_set%SOLUTION_METHOD)
1062  CASE(equations_set_fem_solution_method)
1063  CALL equationsset_assemblequasistaticlinearfem(equations_set,err,error,*999)
1064  CASE(equations_set_bem_solution_method)
1065  CALL flagerror("Not implemented.",err,error,*999)
1066  CASE(equations_set_fd_solution_method)
1067  CALL flagerror("Not implemented.",err,error,*999)
1068  CASE(equations_set_fv_solution_method)
1069  CALL flagerror("Not implemented.",err,error,*999)
1070  CASE(equations_set_gfem_solution_method)
1071  CALL flagerror("Not implemented.",err,error,*999)
1072  CASE(equations_set_gfv_solution_method)
1073  CALL flagerror("Not implemented.",err,error,*999)
1074  CASE DEFAULT
1075  local_error="The equations set solution method of "// &
1076  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
1077  & " is invalid."
1078  CALL flagerror(local_error,err,error,*999)
1079  END SELECT
1080  CASE(equations_nonlinear)
1081  CALL equationsset_assemblequasistaticnonlinearfem(equations_set,err,error,*999)
1082  CASE(equations_nonlinear_bcs)
1083  CALL flagerror("Not implemented.",err,error,*999)
1084  CASE DEFAULT
1085  local_error="The equations linearity of "// &
1086  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))//" is invalid."
1087  CALL flagerror(local_error,err,error,*999)
1088  END SELECT
1089  CASE(equations_first_order_dynamic,equations_second_order_dynamic)
1090  SELECT CASE(equations%LINEARITY)
1091  CASE(equations_linear)
1092  SELECT CASE(equations_set%SOLUTION_METHOD)
1093  CASE(equations_set_fem_solution_method)
1094  CALL equations_set_assemble_dynamic_linear_fem(equations_set,err,error,*999)
1095  CASE(equations_set_bem_solution_method)
1096  CALL flagerror("Not implemented.",err,error,*999)
1097  CASE(equations_set_fd_solution_method)
1098  CALL flagerror("Not implemented.",err,error,*999)
1099  CASE(equations_set_fv_solution_method)
1100  CALL flagerror("Not implemented.",err,error,*999)
1101  CASE(equations_set_gfem_solution_method)
1102  CALL flagerror("Not implemented.",err,error,*999)
1103  CASE(equations_set_gfv_solution_method)
1104  CALL flagerror("Not implemented.",err,error,*999)
1105  CASE DEFAULT
1106  local_error="The equations set solution method of "// &
1107  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
1108  & " is invalid."
1109  CALL flagerror(local_error,err,error,*999)
1110  END SELECT
1111  CASE(equations_nonlinear)
1112  CALL flagerror("Not implemented.",err,error,*999)
1113  CASE(equations_nonlinear_bcs)
1114  CALL flagerror("Not implemented.",err,error,*999)
1115  CASE DEFAULT
1116  local_error="The equations set linearity of "// &
1117  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))//" is invalid."
1118  CALL flagerror(local_error,err,error,*999)
1119  END SELECT
1120  CASE(equations_time_stepping)
1121  CALL flagerror("Time stepping equations are not assembled.",err,error,*999)
1122  CASE DEFAULT
1123  local_error="The equations time dependence type of "// &
1124  & trim(number_to_vstring(equations%TIME_DEPENDENCE,"*",err,error))//" is invalid."
1125  CALL flagerror(local_error,err,error,*999)
1126  END SELECT
1127  ELSE
1128  CALL flagerror("Equations have not been finished.",err,error,*999)
1129  ENDIF
1130  ELSE
1131  CALL flagerror("Equations set equations is not associated.",err,error,*999)
1132  ENDIF
1133  ELSE
1134  CALL flagerror("Equations set is not associated.",err,error,*999)
1135  ENDIF
1136 
1137  exits("EQUATIONS_SET_ASSEMBLE")
1138  RETURN
1139 999 errorsexits("EQUATIONS_SET_ASSEMBLE",err,error)
1140  RETURN 1
1141  END SUBROUTINE equations_set_assemble
1142 
1143  !
1144  !================================================================================================================================
1145  !
1146 
1148  SUBROUTINE equations_set_assemble_dynamic_linear_fem(EQUATIONS_SET,ERR,ERROR,*)
1149 
1150  !Argument variables
1151  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1152  INTEGER(INTG), INTENT(OUT) :: ERR
1153  TYPE(varying_string), INTENT(OUT) :: ERROR
1154  !Local Variables
1155  INTEGER(INTG) :: element_idx,ne,NUMBER_OF_TIMES
1156  REAL(SP) :: ELEMENT_USER_ELAPSED,ELEMENT_SYSTEM_ELAPSED,USER_ELAPSED,USER_TIME1(1),USER_TIME2(1),USER_TIME3(1),USER_TIME4(1), &
1157  & USER_TIME5(1),USER_TIME6(1),SYSTEM_ELAPSED,SYSTEM_TIME1(1),SYSTEM_TIME2(1),SYSTEM_TIME3(1),SYSTEM_TIME4(1), &
1158  & SYSTEM_TIME5(1),SYSTEM_TIME6(1)
1159  TYPE(domain_mapping_type), POINTER :: ELEMENTS_MAPPING
1160  TYPE(equations_type), POINTER :: EQUATIONS
1161  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
1162  TYPE(field_type), POINTER :: DEPENDENT_FIELD
1163 
1164  enters("EQUATIONS_SET_ASSEMBLE_DYNAMIC_LINEAR_FEM",err,error,*999)
1165 
1166  IF(ASSOCIATED(equations_set)) THEN
1167  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
1168  IF(ASSOCIATED(dependent_field)) THEN
1169  equations=>equations_set%EQUATIONS
1170  IF(ASSOCIATED(equations)) THEN
1171  equations_matrices=>equations%EQUATIONS_MATRICES
1172  IF(ASSOCIATED(equations_matrices)) THEN
1173  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1174  CALL cpu_timer(user_cpu,user_time1,err,error,*999)
1175  CALL cpu_timer(system_cpu,system_time1,err,error,*999)
1176  ENDIF
1177  !Initialise the matrices and rhs vector
1178  CALL equations_matrices_values_initialise(equations_matrices,equations_matrices_linear_only,0.0_dp,err,error,*999)
1179  !Assemble the elements
1180  !Allocate the element matrices
1181  CALL equations_matrices_element_initialise(equations_matrices,err,error,*999)
1182  elements_mapping=>dependent_field%DECOMPOSITION%DOMAIN(dependent_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
1183  & mappings%ELEMENTS
1184  !Output timing information if required
1185  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1186  CALL cpu_timer(user_cpu,user_time2,err,error,*999)
1187  CALL cpu_timer(system_cpu,system_time2,err,error,*999)
1188  user_elapsed=user_time2(1)-user_time1(1)
1189  system_elapsed=system_time2(1)-system_time1(1)
1190  CALL write_string(general_output_type,"",err,error,*999)
1191  CALL write_string_value(general_output_type,"User time for equations setup and initialisation = ",user_elapsed, &
1192  & err,error,*999)
1193  CALL write_string_value(general_output_type,"System time for equations setup and initialisation = ",system_elapsed, &
1194  & err,error,*999)
1195  element_user_elapsed=0.0_sp
1196  element_system_elapsed=0.0_sp
1197  ENDIF
1198  number_of_times=0
1199  !Loop over the internal elements
1200  DO element_idx=elements_mapping%INTERNAL_START,elements_mapping%INTERNAL_FINISH
1201  ne=elements_mapping%DOMAIN_LIST(element_idx)
1202  number_of_times=number_of_times+1
1203  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1204  CALL equations_set_finite_element_calculate(equations_set,ne,err,error,*999)
1205  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1206  ENDDO !element_idx
1207  !Output timing information if required
1208  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1209  CALL cpu_timer(user_cpu,user_time3,err,error,*999)
1210  CALL cpu_timer(system_cpu,system_time3,err,error,*999)
1211  user_elapsed=user_time3(1)-user_time2(1)
1212  system_elapsed=system_time3(1)-system_time2(1)
1213  element_user_elapsed=user_elapsed
1214  element_system_elapsed=system_elapsed
1215  CALL write_string(general_output_type,"",err,error,*999)
1216  CALL write_string_value(general_output_type,"User time for internal equations assembly = ",user_elapsed, &
1217  & err,error,*999)
1218  CALL write_string_value(general_output_type,"System time for internal equations assembly = ",system_elapsed, &
1219  & err,error,*999)
1220  ENDIF
1221  !Output timing information if required
1222  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1223  CALL cpu_timer(user_cpu,user_time4,err,error,*999)
1224  CALL cpu_timer(system_cpu,system_time4,err,error,*999)
1225  user_elapsed=user_time4(1)-user_time3(1)
1226  system_elapsed=system_time4(1)-system_time3(1)
1227  CALL write_string_value(general_output_type,"User time for parameter transfer completion = ",user_elapsed, &
1228  & err,error,*999)
1229  CALL write_string_value(general_output_type,"System time for parameter transfer completion = ",system_elapsed, &
1230  & err,error,*999)
1231  ENDIF
1232  !Loop over the boundary and ghost elements
1233  DO element_idx=elements_mapping%BOUNDARY_START,elements_mapping%GHOST_FINISH
1234  ne=elements_mapping%DOMAIN_LIST(element_idx)
1235  number_of_times=number_of_times+1
1236  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1237  CALL equations_set_finite_element_calculate(equations_set,ne,err,error,*999)
1238  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1239  ENDDO !element_idx
1240  !Output timing information if required
1241  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1242  CALL cpu_timer(user_cpu,user_time5,err,error,*999)
1243  CALL cpu_timer(system_cpu,system_time5,err,error,*999)
1244  user_elapsed=user_time5(1)-user_time4(1)
1245  system_elapsed=system_time5(1)-system_time4(1)
1246  element_user_elapsed=element_user_elapsed+user_elapsed
1247  element_system_elapsed=element_system_elapsed+user_elapsed
1248  CALL write_string_value(general_output_type,"User time for boundary+ghost equations assembly = ",user_elapsed, &
1249  & err,error,*999)
1250  CALL write_string_value(general_output_type,"System time for boundary+ghost equations assembly = ",system_elapsed, &
1251  & err,error,*999)
1252  IF(number_of_times>0) THEN
1253  CALL write_string_value(general_output_type,"Average element user time for equations assembly = ", &
1254  & element_user_elapsed/number_of_times,err,error,*999)
1255  CALL write_string_value(general_output_type,"Average element system time for equations assembly = ", &
1256  & element_system_elapsed/number_of_times,err,error,*999)
1257  ENDIF
1258  ENDIF
1259  !Finalise the element matrices
1260  CALL equations_matrices_element_finalise(equations_matrices,err,error,*999)
1261  !Output equations matrices and RHS vector if required
1262  IF(equations%OUTPUT_TYPE>=equations_matrix_output) THEN
1263  CALL equations_matrices_output(general_output_type,equations_matrices,err,error,*999)
1264  ENDIF
1265  !Output timing information if required
1266  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1267  CALL cpu_timer(user_cpu,user_time6,err,error,*999)
1268  CALL cpu_timer(system_cpu,system_time6,err,error,*999)
1269  user_elapsed=user_time6(1)-user_time1(1)
1270  system_elapsed=system_time6(1)-system_time1(1)
1271  CALL write_string(general_output_type,"",err,error,*999)
1272  CALL write_string_value(general_output_type,"Total user time for equations assembly = ",user_elapsed, &
1273  & err,error,*999)
1274  CALL write_string_value(general_output_type,"Total system time for equations assembly = ",system_elapsed, &
1275  & err,error,*999)
1276  ENDIF
1277  ELSE
1278  CALL flagerror("Equations matrices is not associated",err,error,*999)
1279  ENDIF
1280  ELSE
1281  CALL flagerror("Equations is not associated",err,error,*999)
1282  ENDIF
1283  ELSE
1284  CALL flagerror("Dependent field is not associated",err,error,*999)
1285  ENDIF
1286  ELSE
1287  CALL flagerror("Equations set is not associated",err,error,*999)
1288  ENDIF
1289 
1290  exits("EQUATIONS_SET_ASSEMBLE_DYNAMIC_LINEAR_FEM")
1291  RETURN
1292 999 errorsexits("EQUATIONS_SET_ASSEMBLE_DYNAMIC_LINEAR_FEM",err,error)
1293  RETURN 1
1294  END SUBROUTINE equations_set_assemble_dynamic_linear_fem
1295 
1296  !
1297  !================================================================================================================================
1298  !
1299 
1301  SUBROUTINE equations_set_assemble_static_linear_fem(EQUATIONS_SET,ERR,ERROR,*)
1302 
1303  !Argument variables
1304  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1305  INTEGER(INTG), INTENT(OUT) :: ERR
1306  TYPE(varying_string), INTENT(OUT) :: ERROR
1307  !Local Variables
1308  INTEGER(INTG) :: element_idx,ne,NUMBER_OF_TIMES
1309  REAL(SP) :: ELEMENT_USER_ELAPSED,ELEMENT_SYSTEM_ELAPSED,USER_ELAPSED,USER_TIME1(1),USER_TIME2(1),USER_TIME3(1),USER_TIME4(1), &
1310  & USER_TIME5(1),USER_TIME6(1),SYSTEM_ELAPSED,SYSTEM_TIME1(1),SYSTEM_TIME2(1),SYSTEM_TIME3(1),SYSTEM_TIME4(1), &
1311  & SYSTEM_TIME5(1),SYSTEM_TIME6(1)
1312  TYPE(domain_mapping_type), POINTER :: ELEMENTS_MAPPING
1313  TYPE(equations_type), POINTER :: EQUATIONS
1314  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
1315  TYPE(field_type), POINTER :: DEPENDENT_FIELD
1316 
1317 !#ifdef TAUPROF
1318 ! CHARACTER(28) :: CVAR
1319 ! INTEGER :: PHASE(2)= (/ 0, 0 /)
1320 ! SAVE PHASE
1321 !#endif
1322 
1323  enters("EQUATIONS_SET_ASSEMBLE_STATIC_LINEAR_FEM",err,error,*999)
1324 
1325  IF(ASSOCIATED(equations_set)) THEN
1326  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
1327  IF(ASSOCIATED(dependent_field)) THEN
1328  equations=>equations_set%EQUATIONS
1329  IF(ASSOCIATED(equations)) THEN
1330  equations_matrices=>equations%EQUATIONS_MATRICES
1331  IF(ASSOCIATED(equations_matrices)) THEN
1332  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1333  CALL cpu_timer(user_cpu,user_time1,err,error,*999)
1334  CALL cpu_timer(system_cpu,system_time1,err,error,*999)
1335  ENDIF
1336  !Initialise the matrices and rhs vector
1337 #ifdef TAUPROF
1338  CALL tau_static_phase_start("EQUATIONS_MATRICES_VALUES_INITIALISE()")
1339 #endif
1340  CALL equations_matrices_values_initialise(equations_matrices,equations_matrices_linear_only,0.0_dp,err,error,*999)
1341 #ifdef TAUPROF
1342  CALL tau_static_phase_stop("EQUATIONS_MATRICES_VALUES_INITIALISE()")
1343 #endif
1344  !Assemble the elements
1345  !Allocate the element matrices
1346 #ifdef TAUPROF
1347  CALL tau_static_phase_start("EQUATIONS_MATRICES_ELEMENT_INITIALISE()")
1348 #endif
1349  CALL equations_matrices_element_initialise(equations_matrices,err,error,*999)
1350  elements_mapping=>dependent_field%DECOMPOSITION%DOMAIN(dependent_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
1351  & mappings%ELEMENTS
1352 #ifdef TAUPROF
1353  CALL tau_static_phase_stop("EQUATIONS_MATRICES_ELEMENT_INITIALISE()")
1354 #endif
1355  !Output timing information if required
1356  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1357  CALL cpu_timer(user_cpu,user_time2,err,error,*999)
1358  CALL cpu_timer(system_cpu,system_time2,err,error,*999)
1359  user_elapsed=user_time2(1)-user_time1(1)
1360  system_elapsed=system_time2(1)-system_time1(1)
1361  CALL write_string_value(general_output_type,"User time for equations setup and initialisation = ",user_elapsed, &
1362  & err,error,*999)
1363  CALL write_string_value(general_output_type,"System time for equations setup and initialisation = ",system_elapsed, &
1364  & err,error,*999)
1365  element_user_elapsed=0.0_sp
1366  element_system_elapsed=0.0_sp
1367  ENDIF
1368  number_of_times=0
1369  !Loop over the internal elements
1370 
1371 #ifdef TAUPROF
1372  CALL tau_static_phase_start("Internal Elements Loop")
1373 #endif
1374  DO element_idx=elements_mapping%INTERNAL_START,elements_mapping%INTERNAL_FINISH
1375 !#ifdef TAUPROF
1376 ! WRITE (CVAR,'(a23,i3)') 'Internal Elements Loop ',element_idx
1377 ! CALL TAU_PHASE_CREATE_DYNAMIC(PHASE,CVAR)
1378 ! CALL TAU_PHASE_START(PHASE)
1379 !#endif
1380  ne=elements_mapping%DOMAIN_LIST(element_idx)
1381  number_of_times=number_of_times+1
1382  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1383  CALL equations_set_finite_element_calculate(equations_set,ne,err,error,*999)
1384  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1385 !#ifdef TAUPROF
1386 ! CALL TAU_PHASE_STOP(PHASE)
1387 !#endif
1388  ENDDO !element_idx
1389 #ifdef TAUPROF
1390  CALL tau_static_phase_stop("Internal Elements Loop")
1391 #endif
1392 
1393  !Output timing information if required
1394  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1395  CALL cpu_timer(user_cpu,user_time3,err,error,*999)
1396  CALL cpu_timer(system_cpu,system_time3,err,error,*999)
1397  user_elapsed=user_time3(1)-user_time2(1)
1398  system_elapsed=system_time3(1)-system_time2(1)
1399  element_user_elapsed=user_elapsed
1400  element_system_elapsed=system_elapsed
1401  CALL write_string(general_output_type,"",err,error,*999)
1402  CALL write_string_value(general_output_type,"User time for internal equations assembly = ",user_elapsed, &
1403  & err,error,*999)
1404  CALL write_string_value(general_output_type,"System time for internal equations assembly = ",system_elapsed, &
1405  & err,error,*999)
1406  ENDIF
1407  !Output timing information if required
1408  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1409  CALL cpu_timer(user_cpu,user_time4,err,error,*999)
1410  CALL cpu_timer(system_cpu,system_time4,err,error,*999)
1411  user_elapsed=user_time4(1)-user_time3(1)
1412  system_elapsed=system_time4(1)-system_time3(1)
1413  CALL write_string_value(general_output_type,"User time for parameter transfer completion = ",user_elapsed, &
1414  & err,error,*999)
1415  CALL write_string_value(general_output_type,"System time for parameter transfer completion = ",system_elapsed, &
1416  & err,error,*999)
1417  ENDIF
1418  !Loop over the boundary and ghost elements
1419 #ifdef TAUPROF
1420  CALL tau_static_phase_start("Boundary and Ghost Elements Loop")
1421 #endif
1422  DO element_idx=elements_mapping%BOUNDARY_START,elements_mapping%GHOST_FINISH
1423  ne=elements_mapping%DOMAIN_LIST(element_idx)
1424  number_of_times=number_of_times+1
1425  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1426  CALL equations_set_finite_element_calculate(equations_set,ne,err,error,*999)
1427  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1428  ENDDO !element_idx
1429 #ifdef TAUPROF
1430  CALL tau_static_phase_stop("Boundary and Ghost Elements Loop")
1431 #endif
1432  !Output timing information if required
1433  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1434  CALL cpu_timer(user_cpu,user_time5,err,error,*999)
1435  CALL cpu_timer(system_cpu,system_time5,err,error,*999)
1436  user_elapsed=user_time5(1)-user_time4(1)
1437  system_elapsed=system_time5(1)-system_time4(1)
1438  element_user_elapsed=element_user_elapsed+user_elapsed
1439  element_system_elapsed=element_system_elapsed+user_elapsed
1440  CALL write_string_value(general_output_type,"User time for boundary+ghost equations assembly = ",user_elapsed, &
1441  & err,error,*999)
1442  CALL write_string_value(general_output_type,"System time for boundary+ghost equations assembly = ",system_elapsed, &
1443  & err,error,*999)
1444  IF(number_of_times>0) THEN
1445  CALL write_string_value(general_output_type,"Average element user time for equations assembly = ", &
1446  & element_user_elapsed/number_of_times,err,error,*999)
1447  CALL write_string_value(general_output_type,"Average element system time for equations assembly = ", &
1448  & element_system_elapsed/number_of_times,err,error,*999)
1449  ENDIF
1450  ENDIF
1451  !Finalise the element matrices
1452 #ifdef TAUPROF
1453  CALL tau_static_phase_start("EQUATIONS_MATRICES_ELEMENT_FINALISE()")
1454 #endif
1455  CALL equations_matrices_element_finalise(equations_matrices,err,error,*999)
1456 #ifdef TAUPROF
1457  CALL tau_static_phase_stop("EQUATIONS_MATRICES_ELEMENT_FINALISE()")
1458 #endif
1459  !Output equations matrices and vector if required
1460  IF(equations%OUTPUT_TYPE>=equations_matrix_output) THEN
1461  CALL equations_matrices_output(general_output_type,equations_matrices,err,error,*999)
1462  ENDIF
1463  !Output timing information if required
1464  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1465  CALL cpu_timer(user_cpu,user_time6,err,error,*999)
1466  CALL cpu_timer(system_cpu,system_time6,err,error,*999)
1467  user_elapsed=user_time6(1)-user_time1(1)
1468  system_elapsed=system_time6(1)-system_time1(1)
1469  CALL write_string(general_output_type,"",err,error,*999)
1470  CALL write_string_value(general_output_type,"Total user time for equations assembly = ",user_elapsed, &
1471  & err,error,*999)
1472  CALL write_string_value(general_output_type,"Total system time for equations assembly = ",system_elapsed, &
1473  & err,error,*999)
1474  ENDIF
1475  ELSE
1476  CALL flagerror("Equations matrices is not associated",err,error,*999)
1477  ENDIF
1478  ELSE
1479  CALL flagerror("Equations is not associated",err,error,*999)
1480  ENDIF
1481  ELSE
1482  CALL flagerror("Dependent field is not associated",err,error,*999)
1483  ENDIF
1484  ELSE
1485  CALL flagerror("Equations set is not associated",err,error,*999)
1486  ENDIF
1487 
1488  exits("EQUATIONS_SET_ASSEMBLE_STATIC_LINEAR_FEM")
1489  RETURN
1490 999 errorsexits("EQUATIONS_SET_ASSEMBLE_STATIC_LINEAR_FEM",err,error)
1491  RETURN 1
1492  END SUBROUTINE equations_set_assemble_static_linear_fem
1493 
1494  !
1495  !================================================================================================================================
1496  !
1497 
1499  SUBROUTINE equations_set_assemble_static_nonlinear_fem(EQUATIONS_SET,ERR,ERROR,*)
1500 
1501  !Argument variables
1502  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1503  INTEGER(INTG), INTENT(OUT) :: ERR
1504  TYPE(varying_string), INTENT(OUT) :: ERROR
1505  !Local Variables
1506  INTEGER(INTG) :: element_idx,ne,NUMBER_OF_TIMES
1507  REAL(SP) :: ELEMENT_USER_ELAPSED,ELEMENT_SYSTEM_ELAPSED,USER_ELAPSED,USER_TIME1(1),USER_TIME2(1),USER_TIME3(1),USER_TIME4(1), &
1508  & USER_TIME5(1),USER_TIME6(1),SYSTEM_ELAPSED,SYSTEM_TIME1(1),SYSTEM_TIME2(1),SYSTEM_TIME3(1),SYSTEM_TIME4(1), &
1509  & SYSTEM_TIME5(1),SYSTEM_TIME6(1)
1510  TYPE(domain_mapping_type), POINTER :: ELEMENTS_MAPPING
1511  TYPE(equations_type), POINTER :: EQUATIONS
1512  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
1513  TYPE(field_type), POINTER :: DEPENDENT_FIELD
1514 
1515  enters("EQUATIONS_SET_ASSEMBLE_STATIC_NONLINEAR_FEM",err,error,*999)
1516 
1517  IF(ASSOCIATED(equations_set)) THEN
1518  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
1519  IF(ASSOCIATED(dependent_field)) THEN
1520  equations=>equations_set%EQUATIONS
1521  IF(ASSOCIATED(equations)) THEN
1522  equations_matrices=>equations%EQUATIONS_MATRICES
1523  IF(ASSOCIATED(equations_matrices)) THEN
1524  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1525  CALL cpu_timer(user_cpu,user_time1,err,error,*999)
1526  CALL cpu_timer(system_cpu,system_time1,err,error,*999)
1527  ENDIF
1528  !Initialise the matrices and rhs vector
1529  CALL equations_matrices_values_initialise(equations_matrices,equations_matrices_nonlinear_only,0.0_dp,err,error,*999)
1530  !Assemble the elements
1531  !Allocate the element matrices
1532  CALL equations_matrices_element_initialise(equations_matrices,err,error,*999)
1533  elements_mapping=>dependent_field%DECOMPOSITION%DOMAIN(dependent_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
1534  & mappings%ELEMENTS
1535  !Output timing information if required
1536  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1537  CALL cpu_timer(user_cpu,user_time2,err,error,*999)
1538  CALL cpu_timer(system_cpu,system_time2,err,error,*999)
1539  user_elapsed=user_time2(1)-user_time1(1)
1540  system_elapsed=system_time2(1)-system_time1(1)
1541  CALL write_string_value(general_output_type,"User time for equations setup and initialisation = ",user_elapsed, &
1542  & err,error,*999)
1543  CALL write_string_value(general_output_type,"System time for equations setup and initialisation = ",system_elapsed, &
1544  & err,error,*999)
1545  element_user_elapsed=0.0_sp
1546  element_system_elapsed=0.0_sp
1547  ENDIF
1548  number_of_times=0
1549  !Loop over the internal elements
1550  DO element_idx=elements_mapping%INTERNAL_START,elements_mapping%INTERNAL_FINISH
1551  ne=elements_mapping%DOMAIN_LIST(element_idx)
1552  number_of_times=number_of_times+1
1553  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1554  CALL equationsset_finiteelementresidualevaluate(equations_set,ne,err,error,*999)
1555  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1556  ENDDO !element_idx
1557  !Output timing information if required
1558  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1559  CALL cpu_timer(user_cpu,user_time3,err,error,*999)
1560  CALL cpu_timer(system_cpu,system_time3,err,error,*999)
1561  user_elapsed=user_time3(1)-user_time2(1)
1562  system_elapsed=system_time3(1)-system_time2(1)
1563  element_user_elapsed=user_elapsed
1564  element_system_elapsed=system_elapsed
1565  CALL write_string(general_output_type,"",err,error,*999)
1566  CALL write_string_value(general_output_type,"User time for internal equations assembly = ",user_elapsed, &
1567  & err,error,*999)
1568  CALL write_string_value(general_output_type,"System time for internal equations assembly = ",system_elapsed, &
1569  & err,error,*999)
1570  ENDIF
1571  !Output timing information if required
1572  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1573  CALL cpu_timer(user_cpu,user_time4,err,error,*999)
1574  CALL cpu_timer(system_cpu,system_time4,err,error,*999)
1575  user_elapsed=user_time4(1)-user_time3(1)
1576  system_elapsed=system_time4(1)-system_time3(1)
1577  CALL write_string_value(general_output_type,"User time for parameter transfer completion = ",user_elapsed, &
1578  & err,error,*999)
1579  CALL write_string_value(general_output_type,"System time for parameter transfer completion = ",system_elapsed, &
1580  & err,error,*999)
1581  ENDIF
1582  !Loop over the boundary and ghost elements
1583  DO element_idx=elements_mapping%BOUNDARY_START,elements_mapping%GHOST_FINISH
1584  ne=elements_mapping%DOMAIN_LIST(element_idx)
1585  number_of_times=number_of_times+1
1586  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1587  CALL equationsset_finiteelementresidualevaluate(equations_set,ne,err,error,*999)
1588  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1589  ENDDO !element_idx
1590  !Output timing information if required
1591  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1592  CALL cpu_timer(user_cpu,user_time5,err,error,*999)
1593  CALL cpu_timer(system_cpu,system_time5,err,error,*999)
1594  user_elapsed=user_time5(1)-user_time4(1)
1595  system_elapsed=system_time5(1)-system_time4(1)
1596  element_user_elapsed=element_user_elapsed+user_elapsed
1597  element_system_elapsed=element_system_elapsed+user_elapsed
1598  CALL write_string_value(general_output_type,"User time for boundary+ghost equations assembly = ",user_elapsed, &
1599  & err,error,*999)
1600  CALL write_string_value(general_output_type,"System time for boundary+ghost equations assembly = ",system_elapsed, &
1601  & err,error,*999)
1602  IF(number_of_times>0) THEN
1603  CALL write_string_value(general_output_type,"Average element user time for equations assembly = ", &
1604  & element_user_elapsed/number_of_times,err,error,*999)
1605  CALL write_string_value(general_output_type,"Average element system time for equations assembly = ", &
1606  & element_system_elapsed/number_of_times,err,error,*999)
1607  ENDIF
1608  ENDIF
1609  !Finalise the element matrices
1610  CALL equations_matrices_element_finalise(equations_matrices,err,error,*999)
1611  !Output equations matrices and RHS vector if required
1612  IF(equations%OUTPUT_TYPE>=equations_matrix_output) THEN
1613  CALL equations_matrices_output(general_output_type,equations_matrices,err,error,*999)
1614  ENDIF
1615  !Output timing information if required
1616  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1617  CALL cpu_timer(user_cpu,user_time6,err,error,*999)
1618  CALL cpu_timer(system_cpu,system_time6,err,error,*999)
1619  user_elapsed=user_time6(1)-user_time1(1)
1620  system_elapsed=system_time6(1)-system_time1(1)
1621  CALL write_string(general_output_type,"",err,error,*999)
1622  CALL write_string_value(general_output_type,"Total user time for equations assembly = ",user_elapsed, &
1623  & err,error,*999)
1624  CALL write_string_value(general_output_type,"Total system time for equations assembly = ",system_elapsed, &
1625  & err,error,*999)
1626  ENDIF
1627  ELSE
1628  CALL flagerror("Equations matrices is not associated",err,error,*999)
1629  ENDIF
1630  ELSE
1631  CALL flagerror("Equations is not associated",err,error,*999)
1632  ENDIF
1633  ELSE
1634  CALL flagerror("Dependent field is not associated",err,error,*999)
1635  ENDIF
1636  ELSE
1637  CALL flagerror("Equations set is not associated",err,error,*999)
1638  ENDIF
1639 
1640  exits("EQUATIONS_SET_ASSEMBLE_STATIC_NONLINEAR_FEM")
1641  RETURN
1642 999 errorsexits("EQUATIONS_SET_ASSEMBLE_STATIC_NONLINEAR_FEM",err,error)
1643  RETURN 1
1644  END SUBROUTINE equations_set_assemble_static_nonlinear_fem
1645 
1646  !
1647  !================================================================================================================================
1648  !
1649 
1652  SUBROUTINE equationsset_assemblequasistaticnonlinearfem(EQUATIONS_SET,ERR,ERROR,*)
1653  !Argument variables
1654  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1655  INTEGER(INTG), INTENT(OUT) :: ERR
1656  TYPE(varying_string), INTENT(OUT) :: ERROR
1657 
1658  enters("EquationsSet_AssembleQuasistaticNonlinearFEM",err,error,*999)
1659 
1660  ! currently no difference
1661  CALL equations_set_assemble_static_nonlinear_fem(equations_set,err,error,*999)
1662 
1663  RETURN
1664 999 errors("EquationsSet_AssembleQuasistaticNonlinearFEM",err,error)
1665  exits("EquationsSet_AssembleQuasistaticNonlinearFEM")
1666  RETURN 1
1667 
1668  END SUBROUTINE equationsset_assemblequasistaticnonlinearfem
1669 
1670  !
1671  !================================================================================================================================
1672  !
1673 
1675  SUBROUTINE equationsset_assemblequasistaticlinearfem(EQUATIONS_SET,ERR,ERROR,*)
1676 
1677  !Argument variables
1678  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1679  INTEGER(INTG), INTENT(OUT) :: ERR
1680  TYPE(varying_string), INTENT(OUT) :: ERROR
1681  !Local Variables
1682  INTEGER(INTG) :: element_idx,ne,NUMBER_OF_TIMES
1683  REAL(SP) :: ELEMENT_USER_ELAPSED,ELEMENT_SYSTEM_ELAPSED,USER_ELAPSED,USER_TIME1(1),USER_TIME2(1),USER_TIME3(1),USER_TIME4(1), &
1684  & USER_TIME5(1),USER_TIME6(1),SYSTEM_ELAPSED,SYSTEM_TIME1(1),SYSTEM_TIME2(1),SYSTEM_TIME3(1),SYSTEM_TIME4(1), &
1685  & SYSTEM_TIME5(1),SYSTEM_TIME6(1)
1686  TYPE(domain_mapping_type), POINTER :: ELEMENTS_MAPPING
1687  TYPE(equations_type), POINTER :: EQUATIONS
1688  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
1689  TYPE(field_type), POINTER :: DEPENDENT_FIELD
1690 
1691  enters("EquationsSet_AssembleQuasistaticLinearFEM",err,error,*999)
1692 
1693  IF(ASSOCIATED(equations_set)) THEN
1694  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
1695  IF(ASSOCIATED(dependent_field)) THEN
1696  equations=>equations_set%EQUATIONS
1697  IF(ASSOCIATED(equations)) THEN
1698  equations_matrices=>equations%EQUATIONS_MATRICES
1699  IF(ASSOCIATED(equations_matrices)) THEN
1700  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1701  CALL cpu_timer(user_cpu,user_time1,err,error,*999)
1702  CALL cpu_timer(system_cpu,system_time1,err,error,*999)
1703  ENDIF
1704  !Initialise the matrices and rhs vector
1705  CALL equations_matrices_values_initialise(equations_matrices,equations_matrices_linear_only,0.0_dp,err,error,*999)
1706  !Assemble the elements
1707  !Allocate the element matrices
1708  CALL equations_matrices_element_initialise(equations_matrices,err,error,*999)
1709  elements_mapping=>dependent_field%DECOMPOSITION%DOMAIN(dependent_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
1710  & mappings%ELEMENTS
1711  !Output timing information if required
1712  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1713  CALL cpu_timer(user_cpu,user_time2,err,error,*999)
1714  CALL cpu_timer(system_cpu,system_time2,err,error,*999)
1715  user_elapsed=user_time2(1)-user_time1(1)
1716  system_elapsed=system_time2(1)-system_time1(1)
1717  CALL write_string_value(general_output_type,"User time for equations setup and initialisation = ",user_elapsed, &
1718  & err,error,*999)
1719  CALL write_string_value(general_output_type,"System time for equations setup and initialisation = ",system_elapsed, &
1720  & err,error,*999)
1721  element_user_elapsed=0.0_sp
1722  element_system_elapsed=0.0_sp
1723  ENDIF
1724  number_of_times=0
1725  !Loop over the internal elements
1726  DO element_idx=elements_mapping%INTERNAL_START,elements_mapping%INTERNAL_FINISH
1727  ne=elements_mapping%DOMAIN_LIST(element_idx)
1728  number_of_times=number_of_times+1
1729  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1730  CALL equations_set_finite_element_calculate(equations_set,ne,err,error,*999)
1731  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1732  ENDDO !element_idx
1733  !Output timing information if required
1734  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1735  CALL cpu_timer(user_cpu,user_time3,err,error,*999)
1736  CALL cpu_timer(system_cpu,system_time3,err,error,*999)
1737  user_elapsed=user_time3(1)-user_time2(1)
1738  system_elapsed=system_time3(1)-system_time2(1)
1739  element_user_elapsed=user_elapsed
1740  element_system_elapsed=system_elapsed
1741  CALL write_string(general_output_type,"",err,error,*999)
1742  CALL write_string_value(general_output_type,"User time for internal equations assembly = ",user_elapsed, &
1743  & err,error,*999)
1744  CALL write_string_value(general_output_type,"System time for internal equations assembly = ",system_elapsed, &
1745  & err,error,*999)
1746  ENDIF
1747  !Output timing information if required
1748  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1749  CALL cpu_timer(user_cpu,user_time4,err,error,*999)
1750  CALL cpu_timer(system_cpu,system_time4,err,error,*999)
1751  user_elapsed=user_time4(1)-user_time3(1)
1752  system_elapsed=system_time4(1)-system_time3(1)
1753  CALL write_string_value(general_output_type,"User time for parameter transfer completion = ",user_elapsed, &
1754  & err,error,*999)
1755  CALL write_string_value(general_output_type,"System time for parameter transfer completion = ",system_elapsed, &
1756  & err,error,*999)
1757  ENDIF
1758  !Loop over the boundary and ghost elements
1759  DO element_idx=elements_mapping%BOUNDARY_START,elements_mapping%GHOST_FINISH
1760  ne=elements_mapping%DOMAIN_LIST(element_idx)
1761  number_of_times=number_of_times+1
1762  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
1763  CALL equations_set_finite_element_calculate(equations_set,ne,err,error,*999)
1764  CALL equations_matrices_element_add(equations_matrices,err,error,*999)
1765  ENDDO !element_idx
1766  !Output timing information if required
1767  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1768  CALL cpu_timer(user_cpu,user_time5,err,error,*999)
1769  CALL cpu_timer(system_cpu,system_time5,err,error,*999)
1770  user_elapsed=user_time5(1)-user_time4(1)
1771  system_elapsed=system_time5(1)-system_time4(1)
1772  element_user_elapsed=element_user_elapsed+user_elapsed
1773  element_system_elapsed=element_system_elapsed+user_elapsed
1774  CALL write_string_value(general_output_type,"User time for boundary+ghost equations assembly = ",user_elapsed, &
1775  & err,error,*999)
1776  CALL write_string_value(general_output_type,"System time for boundary+ghost equations assembly = ",system_elapsed, &
1777  & err,error,*999)
1778  IF(number_of_times>0) THEN
1779  CALL write_string_value(general_output_type,"Average element user time for equations assembly = ", &
1780  & element_user_elapsed/number_of_times,err,error,*999)
1781  CALL write_string_value(general_output_type,"Average element system time for equations assembly = ", &
1782  & element_system_elapsed/number_of_times,err,error,*999)
1783  ENDIF
1784  ENDIF
1785  !Finalise the element matrices
1786  CALL equations_matrices_element_finalise(equations_matrices,err,error,*999)
1787  !Output equations matrices and RHS vector if required
1788  IF(equations%OUTPUT_TYPE>=equations_matrix_output) THEN
1789  CALL equations_matrices_output(general_output_type,equations_matrices,err,error,*999)
1790  ENDIF
1791  !Output timing information if required
1792  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
1793  CALL cpu_timer(user_cpu,user_time6,err,error,*999)
1794  CALL cpu_timer(system_cpu,system_time6,err,error,*999)
1795  user_elapsed=user_time6(1)-user_time1(1)
1796  system_elapsed=system_time6(1)-system_time1(1)
1797  CALL write_string(general_output_type,"",err,error,*999)
1798  CALL write_string_value(general_output_type,"Total user time for equations assembly = ",user_elapsed, &
1799  & err,error,*999)
1800  CALL write_string_value(general_output_type,"Total system time for equations assembly = ",system_elapsed, &
1801  & err,error,*999)
1802  ENDIF
1803  ELSE
1804  CALL flagerror("Equations matrices is not associated",err,error,*999)
1805  ENDIF
1806  ELSE
1807  CALL flagerror("Equations is not associated",err,error,*999)
1808  ENDIF
1809  ELSE
1810  CALL flagerror("Dependent field is not associated",err,error,*999)
1811  ENDIF
1812  ELSE
1813  CALL flagerror("Equations set is not associated",err,error,*999)
1814  ENDIF
1815 
1816  exits("EquationsSet_AssembleQuasistaticLinearFEM")
1817  RETURN
1818 999 errorsexits("EquationsSet_AssembleQuasistaticLinearFEM",err,error)
1819  RETURN 1
1820  END SUBROUTINE equationsset_assemblequasistaticlinearfem
1821 
1822  !
1823  !================================================================================================================================
1824  !
1825 
1827  SUBROUTINE equations_set_backsubstitute(EQUATIONS_SET,BOUNDARY_CONDITIONS,ERR,ERROR,*)
1828 
1829  !Argument variables
1830  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1831  TYPE(boundary_conditions_type), POINTER :: BOUNDARY_CONDITIONS
1832  INTEGER(INTG), INTENT(OUT) :: ERR
1833  TYPE(varying_string), INTENT(OUT) :: ERROR
1834  !Local Variables
1835  INTEGER(INTG) :: equations_column_idx,equations_column_number,equations_matrix_idx,equations_row_number, &
1836  & EQUATIONS_STORAGE_TYPE,rhs_boundary_condition,rhs_global_dof,rhs_variable_dof,RHS_VARIABLE_TYPE,variable_dof,VARIABLE_TYPE
1837  INTEGER(INTG), POINTER :: COLUMN_INDICES(:),ROW_INDICES(:)
1838  REAL(DP) :: DEPENDENT_VALUE,MATRIX_VALUE,RHS_VALUE,SOURCE_VALUE
1839  REAL(DP), POINTER :: DEPENDENT_PARAMETERS(:),EQUATIONS_MATRIX_DATA(:),SOURCE_VECTOR_DATA(:)
1840  TYPE(boundary_conditions_variable_type), POINTER :: RHS_BOUNDARY_CONDITIONS
1841  TYPE(domain_mapping_type), POINTER :: COLUMN_DOMAIN_MAPPING,RHS_DOMAIN_MAPPING
1842  TYPE(distributed_matrix_type), POINTER :: EQUATIONS_DISTRIBUTED_MATRIX
1843  TYPE(distributed_vector_type), POINTER :: SOURCE_DISTRIBUTED_VECTOR
1844  TYPE(equations_type), POINTER :: EQUATIONS
1845  TYPE(equations_mapping_type), POINTER :: EQUATIONS_MAPPING
1846  TYPE(equations_mapping_linear_type), POINTER :: LINEAR_MAPPING
1847  TYPE(equations_mapping_rhs_type), POINTER :: RHS_MAPPING
1848  TYPE(equations_mapping_source_type), POINTER :: SOURCE_MAPPING
1849  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
1850  TYPE(equations_matrices_dynamic_type), POINTER :: DYNAMIC_MATRICES
1851  TYPE(equations_matrices_linear_type), POINTER :: LINEAR_MATRICES
1852  TYPE(equations_matrices_source_type), POINTER :: SOURCE_VECTOR
1853  TYPE(equations_matrix_type), POINTER :: EQUATIONS_MATRIX
1854  TYPE(field_type), POINTER :: DEPENDENT_FIELD
1855  TYPE(field_variable_type), POINTER :: DEPENDENT_VARIABLE,RHS_VARIABLE
1856  TYPE(varying_string) :: LOCAL_ERROR
1857 
1858  NULLIFY(dependent_parameters)
1859  NULLIFY(equations_matrix_data)
1860  NULLIFY(source_vector_data)
1861 
1862  enters("EQUATIONS_SET_BACKSUBSTITUTE",err,error,*999)
1863 
1864  IF(ASSOCIATED(equations_set)) THEN
1865  IF(equations_set%EQUATIONS_SET_FINISHED) THEN
1866  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
1867  IF(ASSOCIATED(dependent_field)) THEN
1868  equations=>equations_set%EQUATIONS
1869  IF(ASSOCIATED(equations)) THEN
1870  equations_matrices=>equations%EQUATIONS_MATRICES
1871  IF(ASSOCIATED(equations_matrices)) THEN
1872  dynamic_matrices=>equations_matrices%DYNAMIC_MATRICES
1873  IF(ASSOCIATED(dynamic_matrices)) THEN
1874  !CALL FlagError("Not implemented.",ERR,ERROR,*999)
1875  ELSE
1876  linear_matrices=>equations_matrices%LINEAR_MATRICES
1877  IF(ASSOCIATED(linear_matrices)) THEN
1878  equations_mapping=>equations%EQUATIONS_MAPPING
1879  IF(ASSOCIATED(equations_mapping)) THEN
1880  linear_mapping=>equations_mapping%LINEAR_MAPPING
1881  IF(ASSOCIATED(linear_mapping)) THEN
1882  rhs_mapping=>equations_mapping%RHS_MAPPING
1883  source_mapping=>equations_mapping%SOURCE_MAPPING
1884  IF(ASSOCIATED(rhs_mapping)) THEN
1885  IF(ASSOCIATED(boundary_conditions)) THEN
1886  IF(ASSOCIATED(source_mapping)) THEN
1887  source_vector=>equations_matrices%SOURCE_VECTOR
1888  IF(ASSOCIATED(source_vector)) THEN
1889  source_distributed_vector=>source_vector%VECTOR
1890  IF(ASSOCIATED(source_distributed_vector)) THEN
1891  CALL distributed_vector_data_get(source_distributed_vector,source_vector_data,err,error,*999)
1892  ELSE
1893  CALL flagerror("Source distributed vector is not associated.",err,error,*999)
1894  ENDIF
1895  ELSE
1896  CALL flagerror("Source vector is not associated.",err,error,*999)
1897  ENDIF
1898  ENDIF
1899  rhs_variable=>rhs_mapping%RHS_VARIABLE
1900  IF(ASSOCIATED(rhs_variable)) THEN
1901  rhs_variable_type=rhs_variable%VARIABLE_TYPE
1902  rhs_domain_mapping=>rhs_variable%DOMAIN_MAPPING
1903  IF(ASSOCIATED(rhs_domain_mapping)) THEN
1904  CALL boundary_conditions_variable_get(boundary_conditions,rhs_variable,rhs_boundary_conditions, &
1905  & err,error,*999)
1906  IF(ASSOCIATED(rhs_boundary_conditions)) THEN
1907  !Loop over the equations matrices
1908  DO equations_matrix_idx=1,linear_matrices%NUMBER_OF_LINEAR_MATRICES
1909  dependent_variable=>linear_mapping%EQUATIONS_MATRIX_TO_VAR_MAPS(equations_matrix_idx)%VARIABLE
1910  IF(ASSOCIATED(dependent_variable)) THEN
1911  variable_type=dependent_variable%VARIABLE_TYPE
1912  !Get the dependent field variable parameters
1913  CALL field_parametersetdataget(dependent_field,variable_type,field_values_set_type, &
1914  & dependent_parameters,err,error,*999)
1915  equations_matrix=>linear_matrices%MATRICES(equations_matrix_idx)%PTR
1916  IF(ASSOCIATED(equations_matrix)) THEN
1917  column_domain_mapping=>linear_mapping%EQUATIONS_MATRIX_TO_VAR_MAPS(equations_matrix_idx)% &
1918  & column_dofs_mapping
1919  IF(ASSOCIATED(column_domain_mapping)) THEN
1920  equations_distributed_matrix=>equations_matrix%MATRIX
1921  IF(ASSOCIATED(equations_distributed_matrix)) THEN
1922  CALL distributed_matrix_storage_type_get(equations_distributed_matrix, &
1923  & equations_storage_type,err,error,*999)
1924  CALL distributed_matrix_data_get(equations_distributed_matrix,equations_matrix_data, &
1925  & err,error,*999)
1926  SELECT CASE(equations_storage_type)
1927  CASE(distributed_matrix_block_storage_type)
1928  !Loop over the non ghosted rows in the equations set
1929  DO equations_row_number=1,equations_mapping%NUMBER_OF_ROWS
1930  rhs_value=0.0_dp
1931  rhs_variable_dof=rhs_mapping%EQUATIONS_ROW_TO_RHS_DOF_MAP(equations_row_number)
1932  rhs_global_dof=rhs_domain_mapping%LOCAL_TO_GLOBAL_MAP(rhs_variable_dof)
1933  rhs_boundary_condition=rhs_boundary_conditions%DOF_TYPES(rhs_global_dof)
1934  !For free RHS DOFs, set the right hand side field values by multiplying the
1935  !row by the dependent variable value
1936  SELECT CASE(rhs_boundary_condition)
1937  CASE(boundary_condition_dof_free)
1938  !Back substitute
1939  !Loop over the local columns of the equations matrix
1940  DO equations_column_idx=1,column_domain_mapping%TOTAL_NUMBER_OF_LOCAL
1941  equations_column_number=column_domain_mapping%LOCAL_TO_GLOBAL_MAP( &
1942  & equations_column_idx)
1943  variable_dof=equations_column_idx
1944  matrix_value=equations_matrix_data(equations_row_number+ &
1945  & (equations_column_number-1)*equations_matrices%TOTAL_NUMBER_OF_ROWS)
1946  dependent_value=dependent_parameters(variable_dof)
1947  rhs_value=rhs_value+matrix_value*dependent_value
1948  ENDDO !equations_column_idx
1949  CASE(boundary_condition_dof_fixed)
1950  !Do nothing
1951  CASE(boundary_condition_dof_mixed)
1952  !Robin or is it Cauchy??? boundary conditions
1953  CALL flagerror("Not implemented.",err,error,*999)
1954  CASE DEFAULT
1955  local_error="The RHS variable boundary condition of "// &
1956  & trim(number_to_vstring(rhs_boundary_condition,"*",err,error))// &
1957  & " for RHS variable dof number "// &
1958  & trim(number_to_vstring(rhs_variable_dof,"*",err,error))//" is invalid."
1959  CALL flagerror(local_error,err,error,*999)
1960  END SELECT
1961  IF(ASSOCIATED(source_mapping)) THEN
1962  source_value=source_vector_data(equations_row_number)
1963  rhs_value=rhs_value-source_value
1964  ENDIF
1965  CALL field_parametersetupdatelocaldof(dependent_field,rhs_variable_type, &
1966  & field_values_set_type,rhs_variable_dof,rhs_value,err,error,*999)
1967  ENDDO !equations_row_number
1968  CASE(distributed_matrix_diagonal_storage_type)
1969  CALL flagerror("Not implemented.",err,error,*999)
1970  CASE(distributed_matrix_column_major_storage_type)
1971  CALL flagerror("Not implemented.",err,error,*999)
1972  CASE(distributed_matrix_row_major_storage_type)
1973  CALL flagerror("Not implemented.",err,error,*999)
1974  CASE(distributed_matrix_compressed_row_storage_type)
1975  CALL distributed_matrix_storage_locations_get(equations_distributed_matrix, &
1976  & row_indices,column_indices,err,error,*999)
1977  !Loop over the non-ghosted rows in the equations set
1978  DO equations_row_number=1,equations_mapping%NUMBER_OF_ROWS
1979  rhs_value=0.0_dp
1980  rhs_variable_dof=rhs_mapping%EQUATIONS_ROW_TO_RHS_DOF_MAP(equations_row_number)
1981  rhs_global_dof=rhs_domain_mapping%LOCAL_TO_GLOBAL_MAP(rhs_variable_dof)
1982  rhs_boundary_condition=rhs_boundary_conditions%DOF_TYPES(rhs_global_dof)
1983  SELECT CASE(rhs_boundary_condition)
1984  CASE(boundary_condition_dof_free)
1985  !Back substitute
1986  !Loop over the local columns of the equations matrix
1987  DO equations_column_idx=row_indices(equations_row_number), &
1988  row_indices(equations_row_number+1)-1
1989  equations_column_number=column_indices(equations_column_idx)
1990  variable_dof=equations_column_idx-row_indices(equations_row_number)+1
1991  matrix_value=equations_matrix_data(equations_column_idx)
1992  dependent_value=dependent_parameters(variable_dof)
1993  rhs_value=rhs_value+matrix_value*dependent_value
1994  ENDDO !equations_column_idx
1995  CASE(boundary_condition_dof_fixed)
1996  !Do nothing
1997  CASE(boundary_condition_dof_mixed)
1998  !Robin or is it Cauchy??? boundary conditions
1999  CALL flagerror("Not implemented.",err,error,*999)
2000  CASE DEFAULT
2001  local_error="The global boundary condition of "// &
2002  & trim(number_to_vstring(rhs_boundary_condition,"*",err,error))// &
2003  & " for RHS variable dof number "// &
2004  & trim(number_to_vstring(rhs_variable_dof,"*",err,error))//" is invalid."
2005  CALL flagerror(local_error,err,error,*999)
2006  END SELECT
2007  IF(ASSOCIATED(source_mapping)) THEN
2008  source_value=source_vector_data(equations_row_number)
2009  rhs_value=rhs_value-source_value
2010  ENDIF
2011  CALL field_parametersetupdatelocaldof(dependent_field,rhs_variable_type, &
2012  & field_values_set_type,rhs_variable_dof,rhs_value,err,error,*999)
2013  ENDDO !equations_row_number
2014  CASE(distributed_matrix_compressed_column_storage_type)
2015  CALL flagerror("Not implemented.",err,error,*999)
2016  CASE(distributed_matrix_row_column_storage_type)
2017  CALL flagerror("Not implemented.",err,error,*999)
2018  CASE DEFAULT
2019  local_error="The matrix storage type of "// &
2020  & trim(number_to_vstring(equations_storage_type,"*",err,error))//" is invalid."
2021  CALL flagerror(local_error,err,error,*999)
2022  END SELECT
2023  CALL distributed_matrix_data_restore(equations_distributed_matrix,equations_matrix_data, &
2024  & err,error,*999)
2025  ELSE
2026  CALL flagerror("Equations matrix distributed matrix is not associated.",err,error,*999)
2027  ENDIF
2028  ELSE
2029  CALL flagerror("Equations column domain mapping is not associated.",err,error,*999)
2030  ENDIF
2031  ELSE
2032  CALL flagerror("Equations equations matrix is not associated.",err,error,*999)
2033  ENDIF
2034  !Restore the dependent field variable parameters
2035  CALL field_parametersetdatarestore(dependent_field,variable_type,field_values_set_type, &
2036  & dependent_parameters,err,error,*999)
2037  ELSE
2038  CALL flagerror("Dependent variable is not associated.",err,error,*999)
2039  ENDIF
2040  ENDDO !equations_matrix_idx
2041  !Start the update of the field parameters
2042  CALL field_parametersetupdatestart(dependent_field,rhs_variable_type,field_values_set_type, &
2043  & err,error,*999)
2044  !Finish the update of the field parameters
2045  CALL field_parametersetupdatefinish(dependent_field,rhs_variable_type,field_values_set_type, &
2046  & err,error,*999)
2047  ELSE
2048  CALL flagerror("RHS boundary conditions variable is not associated.",err,error,*999)
2049  ENDIF
2050  ELSE
2051  CALL flagerror("RHS variable domain mapping is not associated.",err,error,*999)
2052  ENDIF
2053  ELSE
2054  CALL flagerror("RHS variable is not associated.",err,error,*999)
2055  ENDIF
2056  IF(ASSOCIATED(source_mapping)) THEN
2057  CALL distributed_vector_data_restore(source_distributed_vector,source_vector_data,err,error,*999)
2058  ENDIF
2059  ELSE
2060  CALL flagerror("Boundary conditions are not associated.",err,error,*999)
2061  ENDIF
2062  ELSE
2063  CALL flagerror("Equations mapping RHS mappings is not associated.",err,error,*999)
2064  ENDIF
2065  ELSE
2066  CALL flagerror("Equations mapping linear mapping is not associated.",err,error,*999)
2067  ENDIF
2068  ELSE
2069  CALL flagerror("Equations mapping is not associated.",err,error,*999)
2070  ENDIF
2071  ELSE
2072  CALL flagerror("Equations matrices linear matrices is not associated.",err,error,*999)
2073  ENDIF
2074  ENDIF
2075  ELSE
2076  CALL flagerror("Equations matrices is not associated.",err,error,*999)
2077  ENDIF
2078  ELSE
2079  CALL flagerror("Equations is not associated.",err,error,*999)
2080  ENDIF
2081  ELSE
2082  CALL flagerror("Dependent field is not associated.",err,error,*999)
2083  ENDIF
2084  ELSE
2085  CALL flagerror("Equations set has not been finished.",err,error,*999)
2086  ENDIF
2087  ELSE
2088  CALL flagerror("Equations set is not associated",err,error,*999)
2089  ENDIF
2090 
2091  exits("EQUATIONS_SET_BACKSUBSTITUTE")
2092  RETURN
2093 999 errorsexits("EQUATIONS_SET_BACKSUBSTITUTE",err,error)
2094  RETURN 1
2095 
2096  END SUBROUTINE equations_set_backsubstitute
2097 
2098  !
2099  !================================================================================================================================
2100  !
2101 
2103  SUBROUTINE equations_set_nonlinear_rhs_update(EQUATIONS_SET,BOUNDARY_CONDITIONS,ERR,ERROR,*)
2104 
2105  !Argument variables
2106  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2107  TYPE(boundary_conditions_type), POINTER :: BOUNDARY_CONDITIONS
2108  INTEGER(INTG), INTENT(OUT) :: ERR
2109  TYPE(varying_string), INTENT(OUT) :: ERROR
2110  !Local Variables
2111  INTEGER(INTG) :: variable_dof,row_idx,VARIABLE_TYPE,rhs_global_dof,rhs_boundary_condition,equations_matrix_idx
2112  REAL(DP) :: VALUE
2113  TYPE(equations_type), POINTER :: EQUATIONS
2114  TYPE(equations_mapping_type), POINTER :: EQUATIONS_MAPPING
2115  TYPE(equations_mapping_nonlinear_type), POINTER :: NONLINEAR_MAPPING
2116  TYPE(equations_mapping_rhs_type), POINTER :: RHS_MAPPING
2117  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
2118  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
2119  TYPE(distributed_vector_type), POINTER :: RESIDUAL_VECTOR
2120  TYPE(field_type), POINTER :: RHS_FIELD
2121  TYPE(field_variable_type), POINTER :: RHS_VARIABLE,RESIDUAL_VARIABLE
2122  TYPE(boundary_conditions_variable_type), POINTER :: RHS_BOUNDARY_CONDITIONS
2123  TYPE(domain_mapping_type), POINTER :: RHS_DOMAIN_MAPPING
2124  TYPE(varying_string) :: LOCAL_ERROR
2125 
2126  enters("EQUATIONS_SET_NONLINEAR_RHS_UPDATE",err,error,*999)
2127 
2128  IF(ASSOCIATED(equations_set)) THEN
2129  equations=>equations_set%EQUATIONS
2130  IF(ASSOCIATED(equations)) THEN
2131  equations_mapping=>equations%EQUATIONS_MAPPING
2132  IF(ASSOCIATED(equations_mapping)) THEN
2133  rhs_mapping=>equations_mapping%RHS_MAPPING
2134  IF(ASSOCIATED(rhs_mapping)) THEN
2135  rhs_variable=>rhs_mapping%RHS_VARIABLE
2136  IF(ASSOCIATED(rhs_variable)) THEN
2137  !Get the right hand side variable
2138  rhs_field=>rhs_variable%FIELD
2139  variable_type=rhs_variable%VARIABLE_TYPE
2140  ELSE
2141  CALL flagerror("RHS mapping RHS variable is not associated.",err,error,*999)
2142  ENDIF
2143  ELSE
2144  CALL flagerror("Equations mapping RHS mapping is not associated.",err,error,*999)
2145  ENDIF
2146  IF(ASSOCIATED(rhs_field)) THEN
2147  IF(ASSOCIATED(boundary_conditions)) THEN
2148  rhs_domain_mapping=>rhs_variable%DOMAIN_MAPPING
2149  IF(ASSOCIATED(rhs_domain_mapping)) THEN
2150  CALL boundary_conditions_variable_get(boundary_conditions,rhs_variable,rhs_boundary_conditions, &
2151  & err,error,*999)
2152  IF(ASSOCIATED(rhs_boundary_conditions)) THEN
2153  !Get the equations residual vector
2154  equations_matrices=>equations%EQUATIONS_MATRICES
2155  IF(ASSOCIATED(equations_matrices)) THEN
2156  nonlinear_matrices=>equations_matrices%NONLINEAR_MATRICES
2157  IF(ASSOCIATED(nonlinear_matrices)) THEN
2158  residual_vector=>nonlinear_matrices%RESIDUAL
2159  IF(ASSOCIATED(residual_vector)) THEN
2160  !Get mapping from equations rows to field dofs
2161  nonlinear_mapping=>equations_mapping%NONLINEAR_MAPPING
2162  IF(ASSOCIATED(nonlinear_mapping)) THEN
2163  DO equations_matrix_idx=1,nonlinear_mapping%NUMBER_OF_RESIDUAL_VARIABLES
2164  residual_variable=>nonlinear_mapping%JACOBIAN_TO_VAR_MAP(equations_matrix_idx)%VARIABLE
2165  IF(ASSOCIATED(residual_variable)) THEN
2166  DO row_idx=1,equations_mapping%NUMBER_OF_ROWS
2167  variable_dof=rhs_mapping%EQUATIONS_ROW_TO_RHS_DOF_MAP(row_idx)
2168  rhs_global_dof=rhs_domain_mapping%LOCAL_TO_GLOBAL_MAP(variable_dof)
2169  rhs_boundary_condition=rhs_boundary_conditions%DOF_TYPES(rhs_global_dof)
2170  SELECT CASE(rhs_boundary_condition)
2171  CASE(boundary_condition_dof_free)
2172  !Add residual to field value
2173  CALL distributed_vector_values_get(residual_vector,row_idx,VALUE,err,error,*999)
2174  CALL field_parametersetupdatelocaldof(rhs_field,variable_type,field_values_set_type, &
2175  & variable_dof,VALUE,err,error,*999)
2176  CASE(boundary_condition_dof_fixed)
2177  !Do nothing
2178  CASE(boundary_condition_dof_mixed)
2179  CALL flagerror("Not implemented.",err,error,*999)
2180  CASE DEFAULT
2181  local_error="The RHS variable boundary condition of "// &
2182  & trim(number_to_vstring(rhs_boundary_condition,"*",err,error))// &
2183  & " for RHS variable dof number "// &
2184  & trim(number_to_vstring(variable_dof,"*",err,error))//" is invalid."
2185  CALL flagerror(local_error,err,error,*999)
2186  END SELECT
2187  ENDDO
2188  ELSE
2189  CALL flagerror("Residual variable is not associated.",err,error,*999)
2190  ENDIF
2191  ENDDO !equations_matrix_idx
2192  ELSE
2193  CALL flagerror("Nonlinear mapping is not associated.",err,error,*999)
2194  ENDIF
2195  ELSE
2196  CALL flagerror("Residual vector is not associated.",err,error,*999)
2197  ENDIF
2198  ELSE
2199  CALL flagerror("Nonlinear matrices is not associated.",err,error,*999)
2200  ENDIF
2201  ELSE
2202  CALL flagerror("Equations matrices is not associated.",err,error,*999)
2203  ENDIF
2204  ELSE
2205  CALL flagerror("RHS boundary conditions variable is not associated.",err,error,*999)
2206  ENDIF
2207  ELSE
2208  CALL flagerror("RHS variable domain mapping is not associated.",err,error,*999)
2209  ENDIF
2210  ELSE
2211  CALL flagerror("Boundary conditions are not associated.",err,error,*999)
2212  ENDIF
2213  CALL field_parametersetupdatestart(rhs_field,variable_type,field_values_set_type,err,error,*999)
2214  CALL field_parametersetupdatefinish(rhs_field,variable_type,field_values_set_type,err,error,*999)
2215  ELSE
2216  CALL flagerror("RHS variable field is not associated.",err,error,*999)
2217  ENDIF
2218  ELSE
2219  CALL flagerror("Equations mapping is not associated.",err,error,*999)
2220  ENDIF
2221  ELSE
2222  CALL flagerror("Equations set equations is not associated.",err,error,*999)
2223  ENDIF
2224  ELSE
2225  CALL flagerror("Equations set is not associated.",err,error,*999)
2226  ENDIF
2227 
2228  exits("EQUATIONS_SET_NONLINEAR_RHS_UPDATE")
2229  RETURN
2230 999 errorsexits("EQUATIONS_SET_NONLINEAR_RHS_UPDATE",err,error)
2231  RETURN 1
2232 
2233  END SUBROUTINE equations_set_nonlinear_rhs_update
2234 
2235  !
2236  !================================================================================================================================
2237  !
2238 
2240  SUBROUTINE equations_set_boundary_conditions_analytic(EQUATIONS_SET,BOUNDARY_CONDITIONS,ERR,ERROR,*)
2241 
2242  !Argument variables
2243  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2244  TYPE(boundary_conditions_type), POINTER :: BOUNDARY_CONDITIONS
2245  INTEGER(INTG), INTENT(OUT) :: ERR
2246  TYPE(varying_string), INTENT(OUT) :: ERROR
2247  !Local Variables
2248  TYPE(varying_string) :: LOCAL_ERROR
2249 
2250  enters("EQUATIONS_SET_BOUNDARY_CONDITIONS_ANALYTIC",err,error,*999)
2251 
2252  IF(ASSOCIATED(equations_set)) THEN
2253  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
2254  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
2255  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
2256  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
2257  END IF
2258  IF(equations_set%DEPENDENT%DEPENDENT_FINISHED) THEN
2259  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
2260  IF(equations_set%ANALYTIC%ANALYTIC_FINISHED) THEN
2261  SELECT CASE(equations_set%SPECIFICATION(1))
2262  CASE(equations_set_elasticity_class)
2263  CALL elasticity_boundaryconditionsanalyticcalculate(equations_set,boundary_conditions,err,error,*999)
2264  CASE(equations_set_fluid_mechanics_class)
2265  CALL fluidmechanics_boundaryconditionsanalyticcalculate(equations_set,boundary_conditions,err,error,*999)
2266  CASE(equations_set_electromagnetics_class)
2267  CALL flagerror("Not implemented.",err,error,*999)
2268  CASE(equations_set_classical_field_class)
2269  CALL classicalfield_boundaryconditionsanalyticcalculate(equations_set,boundary_conditions,err,error,*999)
2270  CASE(equations_set_bioelectrics_class)
2271  CALL flagerror("Not implemented.",err,error,*999)
2272  CASE(equations_set_modal_class)
2273  CALL flagerror("Not implemented.",err,error,*999)
2274  CASE(equations_set_multi_physics_class)
2275  CALL flagerror("Not implemented.",err,error,*999)
2276  CASE DEFAULT
2277  local_error="The first equations set specification of "//trim(number_to_vstring(equations_set%SPECIFICATION(1),"*", &
2278  & err,error))//" is invalid."
2279  CALL flagerror(local_error,err,error,*999)
2280  END SELECT
2281  ELSE
2282  CALL flagerror("Equations set analytic has not been finished.",err,error,*999)
2283  ENDIF
2284  ELSE
2285  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
2286  ENDIF
2287  ELSE
2288  CALL flagerror("Equations set dependent has not been finished.",err,error,*999)
2289  ENDIF
2290  ELSE
2291  CALL flagerror("Equations set is not associated.",err,error,*999)
2292  ENDIF
2293 
2294  exits("EQUATIONS_SET_BOUNDARY_CONDITIONS_ANALYTIC")
2295  RETURN
2296 999 errorsexits("EQUATIONS_SET_BOUNDARY_CONDITIONS_ANALYTIC",err,error)
2297  RETURN 1
2298  END SUBROUTINE equations_set_boundary_conditions_analytic
2299 
2300  !
2301  !================================================================================================================================
2302  !
2303 
2305  SUBROUTINE equations_set_create_finish(EQUATIONS_SET,ERR,ERROR,*)
2306 
2307  !Argument variables
2308  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2309  INTEGER(INTG), INTENT(OUT) :: ERR
2310  TYPE(varying_string), INTENT(OUT) :: ERROR
2311  !Local Variables
2312  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
2313 
2314  enters("EQUATIONS_SET_CREATE_FINISH",err,error,*999)
2315 
2316  IF(ASSOCIATED(equations_set)) THEN
2317  IF(equations_set%EQUATIONS_SET_FINISHED) THEN
2318  CALL flagerror("Equations set has already been finished.",err,error,*999)
2319  ELSE
2320  equations_set_setup_info%SETUP_TYPE=equations_set_setup_initial_type
2321  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
2322  !Finish the equations set specific setup
2323  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
2324  equations_set_setup_info%SETUP_TYPE=equations_set_setup_geometry_type
2325  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
2326  !Finish the equations set specific geometry setup
2327  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
2328  !Finalise the setup
2329  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
2330  !Finish the equations set creation
2331  equations_set%EQUATIONS_SET_FINISHED=.true.
2332  ENDIF
2333  ELSE
2334  CALL flagerror("Equations set is not associated.",err,error,*999)
2335  ENDIF
2336 
2337  exits("EQUATIONS_SET_CREATE_FINISH")
2338  RETURN
2339 999 errorsexits("EQUATIONS_SET_CREATE_FINISH",err,error)
2340  RETURN 1
2341 
2342  END SUBROUTINE equations_set_create_finish
2343 
2344  !
2345  !================================================================================================================================
2346  !
2347 
2360  SUBROUTINE equations_set_create_start(USER_NUMBER,REGION,GEOM_FIBRE_FIELD,EQUATIONS_SET_SPECIFICATION,&
2361  & equations_set_field_user_number,equations_set_field_field,equations_set,err,error,*)
2362 
2363  !Argument variables
2364  INTEGER(INTG), INTENT(IN) :: USER_NUMBER
2365  TYPE(region_type), POINTER :: REGION
2366  TYPE(field_type), POINTER :: GEOM_FIBRE_FIELD
2367  INTEGER(INTG), INTENT(IN) :: EQUATIONS_SET_SPECIFICATION(:)
2368  INTEGER(INTG), INTENT(IN) :: EQUATIONS_SET_FIELD_USER_NUMBER
2369  TYPE(field_type), POINTER :: EQUATIONS_SET_FIELD_FIELD
2370  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2371  INTEGER(INTG), INTENT(OUT) :: ERR
2372  TYPE(varying_string), INTENT(OUT) :: ERROR
2373  !Local Variables
2374  INTEGER(INTG) :: DUMMY_ERR,equations_set_idx
2375  TYPE(equations_set_type), POINTER :: NEW_EQUATIONS_SET
2376  TYPE(equations_set_ptr_type), POINTER :: NEW_EQUATIONS_SETS(:)
2377  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
2378  TYPE(region_type), POINTER :: GEOM_FIBRE_FIELD_REGION,EQUATIONS_SET_FIELD_REGION
2379  TYPE(varying_string) :: DUMMY_ERROR,LOCAL_ERROR
2380  TYPE(equations_set_equations_set_field_type), POINTER :: EQUATIONS_EQUATIONS_SET_FIELD
2381  TYPE(field_type), POINTER :: FIELD
2382 
2383  NULLIFY(new_equations_set)
2384  NULLIFY(new_equations_sets)
2385  NULLIFY(equations_equations_set_field)
2386 
2387  enters("EQUATIONS_SET_CREATE_START",err,error,*997)
2388 
2389  IF(ASSOCIATED(region)) THEN
2390  IF(ASSOCIATED(region%EQUATIONS_SETS)) THEN
2391  CALL equations_set_user_number_find(user_number,region,new_equations_set,err,error,*997)
2392  IF(ASSOCIATED(new_equations_set)) THEN
2393  local_error="Equations set user number "//trim(number_to_vstring(user_number,"*",err,error))// &
2394  & " has already been created on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
2395  CALL flagerror(local_error,err,error,*997)
2396  ELSE
2397  NULLIFY(new_equations_set)
2398  IF(ASSOCIATED(geom_fibre_field)) THEN
2399  IF(geom_fibre_field%FIELD_FINISHED) THEN
2400  IF(geom_fibre_field%TYPE==field_geometric_type.OR.geom_fibre_field%TYPE==field_fibre_type) THEN
2401  geom_fibre_field_region=>geom_fibre_field%REGION
2402  IF(ASSOCIATED(geom_fibre_field_region)) THEN
2403  IF(geom_fibre_field_region%USER_NUMBER==region%USER_NUMBER) THEN
2404  IF(ASSOCIATED(equations_set_field_field)) THEN
2405  !Check the equations set field has been finished
2406  IF(equations_set_field_field%FIELD_FINISHED.eqv..true.) THEN
2407  !Check the user numbers match
2408  IF(equations_set_field_user_number/=equations_set_field_field%USER_NUMBER) THEN
2409  local_error="The specified equations set field user number of "// &
2410  & trim(number_to_vstring(equations_set_field_user_number,"*",err,error))// &
2411  & " does not match the user number of the specified equations set field of "// &
2412  & trim(number_to_vstring(equations_set_field_field%USER_NUMBER,"*",err,error))//"."
2413  CALL flagerror(local_error,err,error,*999)
2414  ENDIF
2415  equations_set_field_region=>equations_set_field_field%REGION
2416  IF(ASSOCIATED(equations_set_field_region)) THEN
2417  !Check the field is defined on the same region as the equations set
2418  IF(equations_set_field_region%USER_NUMBER/=region%USER_NUMBER) THEN
2419  local_error="Invalid region setup. The specified equations set field was created on region no. "// &
2420  & trim(number_to_vstring(equations_set_field_region%USER_NUMBER,"*",err,error))// &
2421  & " and the specified equations set has been created on region number "// &
2422  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
2423  CALL flagerror(local_error,err,error,*999)
2424  ENDIF
2425  !Check the specified equations set field has the same decomposition as the geometric field
2426  IF(ASSOCIATED(geom_fibre_field)) THEN
2427  IF(.NOT.ASSOCIATED(geom_fibre_field%DECOMPOSITION,equations_set_field_field%DECOMPOSITION)) THEN
2428  CALL flagerror("The specified equations set field does not have the same decomposition "// &
2429  & "as the geometric field for the specified equations set.",err,error,*999)
2430  ENDIF
2431  ELSE
2432  CALL flagerror("The geom. field is not associated for the specified equations set.",err,error,*999)
2433  ENDIF
2434 
2435  ELSE
2436  CALL flagerror("The specified equations set field region is not associated.",err,error,*999)
2437  ENDIF
2438  ELSE
2439  CALL flagerror("The specified equations set field has not been finished.",err,error,*999)
2440  ENDIF
2441  ELSE
2442  !Check the user number has not already been used for a field in this region.
2443  NULLIFY(field)
2444  CALL field_user_number_find(equations_set_field_user_number,region,field,err,error,*999)
2445  IF(ASSOCIATED(field)) THEN
2446  local_error="The specified equations set field user number of "// &
2447  & trim(number_to_vstring(equations_set_field_user_number,"*",err,error))// &
2448  & "has already been used to create a field on region number "// &
2449  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
2450  CALL flagerror(local_error,err,error,*999)
2451  ENDIF
2452  ENDIF
2453  !Initalise equations set
2454  CALL equations_set_initialise(new_equations_set,err,error,*999)
2455  !Set default equations set values
2456  new_equations_set%USER_NUMBER=user_number
2457  new_equations_set%GLOBAL_NUMBER=region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS+1
2458  new_equations_set%EQUATIONS_SETS=>region%EQUATIONS_SETS
2459  new_equations_set%REGION=>region
2460  !Set the equations set class, type and subtype
2461  CALL equationsset_specificationset(new_equations_set,equations_set_specification,err,error,*999)
2462  new_equations_set%EQUATIONS_SET_FINISHED=.false.
2463  !Initialise the setup
2464  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
2465  equations_set_setup_info%SETUP_TYPE=equations_set_setup_initial_type
2466  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
2467  !Here, we get a pointer to the equations_set_field; default is null
2468  equations_set_setup_info%FIELD_USER_NUMBER=equations_set_field_user_number
2469  equations_set_setup_info%FIELD=>equations_set_field_field
2470  !Start equations set specific setup
2471  CALL equations_set_setup(new_equations_set,equations_set_setup_info,err,error,*999)
2472  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
2473  !Set up the equations set geometric fields
2474  CALL equations_set_geometry_initialise(new_equations_set,err,error,*999)
2475  IF(geom_fibre_field%TYPE==field_geometric_type) THEN
2476  new_equations_set%GEOMETRY%GEOMETRIC_FIELD=>geom_fibre_field
2477  NULLIFY(new_equations_set%GEOMETRY%FIBRE_FIELD)
2478  ELSE
2479  new_equations_set%GEOMETRY%GEOMETRIC_FIELD=>geom_fibre_field%GEOMETRIC_FIELD
2480  new_equations_set%GEOMETRY%FIBRE_FIELD=>geom_fibre_field
2481  ENDIF
2482  equations_set_setup_info%SETUP_TYPE=equations_set_setup_geometry_type
2483  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
2484  equations_set_setup_info%FIELD_USER_NUMBER=geom_fibre_field%USER_NUMBER
2485  equations_set_setup_info%FIELD=>geom_fibre_field
2486  !Set up equations set specific geometry
2487  CALL equations_set_setup(new_equations_set,equations_set_setup_info,err,error,*999)
2488  !Finalise the setup
2489  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
2490  !Add new equations set into list of equations set in the region
2491  ALLOCATE(new_equations_sets(region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS+1),stat=err)
2492  IF(err/=0) CALL flagerror("Could not allocate new equations sets.",err,error,*999)
2493  DO equations_set_idx=1,region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS
2494  new_equations_sets(equations_set_idx)%PTR=>region%EQUATIONS_SETS%EQUATIONS_SETS(equations_set_idx)%PTR
2495  ENDDO !equations_set_idx
2496  new_equations_sets(region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS+1)%PTR=>new_equations_set
2497  IF(ASSOCIATED(region%EQUATIONS_SETS%EQUATIONS_SETS)) DEALLOCATE(region%EQUATIONS_SETS%EQUATIONS_SETS)
2498  region%EQUATIONS_SETS%EQUATIONS_SETS=>new_equations_sets
2499  region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS=region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS+1
2500  equations_set=>new_equations_set
2501  equations_equations_set_field=>equations_set%EQUATIONS_SET_FIELD
2502  !\todo check pointer setup
2503  IF(equations_equations_set_field%EQUATIONS_SET_FIELD_AUTO_CREATED) THEN
2504  equations_set_field_field=>equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET_FIELD_FIELD
2505  ELSE
2506  equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET_FIELD_FIELD=>equations_set_field_field
2507  ENDIF
2508  ELSE
2509  local_error="The geometric field region and the specified region do not match. "// &
2510  & "The geometric field was created on region number "// &
2511  & trim(number_to_vstring(geom_fibre_field_region%USER_NUMBER,"*",err,error))// &
2512  & " and the specified region number is "// &
2513  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
2514  CALL flagerror(local_error,err,error,*997)
2515  ENDIF
2516  ELSE
2517  CALL flagerror("The specified geometric fields region is not associated.",err,error,*997)
2518  ENDIF
2519  ELSE
2520  CALL flagerror("The specified geometric field is not a geometric or fibre field.",err,error,*997)
2521  ENDIF
2522  ELSE
2523  CALL flagerror("The specified geometric field is not finished.",err,error,*997)
2524  ENDIF
2525  ELSE
2526  CALL flagerror("The specified geometric field is not associated.",err,error,*997)
2527  ENDIF
2528  ENDIF
2529  ELSE
2530  local_error="The equations sets on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))// &
2531  & " are not associated."
2532  CALL flagerror(local_error,err,error,*997)
2533  ENDIF
2534  ELSE
2535  CALL flagerror("Region is not associated.",err,error,*997)
2536  ENDIF
2537 
2538  exits("EQUATIONS_SET_CREATE_START")
2539  RETURN
2540 999 IF(ASSOCIATED(new_equations_set))CALL equations_set_finalise(new_equations_set,dummy_err,dummy_error,*998)
2541 998 IF(ASSOCIATED(new_equations_sets)) DEALLOCATE(new_equations_sets)
2542 997 errorsexits("EQUATIONS_SET_CREATE_START",err,error)
2543  RETURN 1
2544  END SUBROUTINE equations_set_create_start
2545 
2546  !
2547  !================================================================================================================================
2548  !
2549 
2551  SUBROUTINE equations_set_destroy_number(USER_NUMBER,REGION,ERR,ERROR,*)
2552 
2553  !Argument variables
2554  INTEGER(INTG), INTENT(IN) :: USER_NUMBER
2555  TYPE(region_type), POINTER :: REGION
2556  INTEGER(INTG), INTENT(OUT) :: ERR
2557  TYPE(varying_string), INTENT(OUT) :: ERROR
2558  !Local Variables
2559  INTEGER(INTG) :: equations_set_idx,equations_set_position
2560  LOGICAL :: FOUND
2561  TYPE(varying_string) :: LOCAL_ERROR
2562  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2563  TYPE(equations_set_ptr_type), POINTER :: NEW_EQUATIONS_SETS(:)
2564 
2565  NULLIFY(new_equations_sets)
2566 
2567  enters("EQUATIONS_SET_DESTROY_NUMBER",err,error,*999)
2568 
2569  IF(ASSOCIATED(region)) THEN
2570  IF(ASSOCIATED(region%EQUATIONS_SETS)) THEN
2571 
2572  !Find the equations set identified by the user number
2573  found=.false.
2574  equations_set_position=0
2575  DO WHILE(equations_set_position<region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS.AND..NOT.found)
2576  equations_set_position=equations_set_position+1
2577  IF(region%EQUATIONS_SETS%EQUATIONS_SETS(equations_set_position)%PTR%USER_NUMBER==user_number)found=.true.
2578  ENDDO
2579 
2580  IF(found) THEN
2581 
2582  equations_set=>region%EQUATIONS_SETS%EQUATIONS_SETS(equations_set_position)%PTR
2583 
2584  !Destroy all the equations set components
2585  CALL equations_set_finalise(equations_set,err,error,*999)
2586 
2587  !Remove the equations set from the list of equations set
2588  IF(region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS>1) THEN
2589  ALLOCATE(new_equations_sets(region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS-1),stat=err)
2590  IF(err/=0) CALL flagerror("Could not allocate new equations sets.",err,error,*999)
2591  DO equations_set_idx=1,region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS
2592  IF(equations_set_idx<equations_set_position) THEN
2593  new_equations_sets(equations_set_idx)%PTR=>region%EQUATIONS_SETS%EQUATIONS_SETS(equations_set_idx)%PTR
2594  ELSE IF(equations_set_idx>equations_set_position) THEN
2595  region%EQUATIONS_SETS%EQUATIONS_SETS(equations_set_idx)%PTR%GLOBAL_NUMBER=region%EQUATIONS_SETS% &
2596  & equations_sets(equations_set_idx)%PTR%GLOBAL_NUMBER-1
2597  new_equations_sets(equations_set_idx-1)%PTR=>region%EQUATIONS_SETS%EQUATIONS_SETS(equations_set_idx)%PTR
2598  ENDIF
2599  ENDDO !equations_set_idx
2600  IF(ASSOCIATED(region%EQUATIONS_SETS%EQUATIONS_SETS)) DEALLOCATE(region%EQUATIONS_SETS%EQUATIONS_SETS)
2601  region%EQUATIONS_SETS%EQUATIONS_SETS=>new_equations_sets
2602  region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS=region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS-1
2603  ELSE
2604  DEALLOCATE(region%EQUATIONS_SETS%EQUATIONS_SETS)
2605  region%EQUATIONS_SETS%NUMBER_OF_EQUATIONS_SETS=0
2606  ENDIF
2607 
2608  ELSE
2609  local_error="Equations set number "//trim(number_to_vstring(user_number,"*",err,error))// &
2610  & " has not been created on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
2611  CALL flagerror(local_error,err,error,*999)
2612  ENDIF
2613  ELSE
2614  local_error="The equations sets on region number "//trim(number_to_vstring(region%USER_NUMBER,"*",err,error))// &
2615  & " are not associated."
2616  CALL flagerror(local_error,err,error,*999)
2617  ENDIF
2618  ELSE
2619  CALL flagerror("Region is not associated.",err,error,*998)
2620  ENDIF
2621 
2622  exits("EQUATIONS_SET_DESTROY_NUMBER")
2623  RETURN
2624 999 IF(ASSOCIATED(new_equations_sets)) DEALLOCATE(new_equations_sets)
2625 998 errorsexits("EQUATIONS_SET_DESTROY_NUMBER",err,error)
2626  RETURN 1
2627  END SUBROUTINE equations_set_destroy_number
2628 
2629  !
2630  !================================================================================================================================
2631  !
2632 
2634  SUBROUTINE equations_set_destroy(EQUATIONS_SET,ERR,ERROR,*)
2635 
2636  !Argument variables
2637  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2638  INTEGER(INTG), INTENT(OUT) :: ERR
2639  TYPE(varying_string), INTENT(OUT) :: ERROR
2640  !Local Variables
2641  INTEGER(INTG) :: equations_set_idx,equations_set_position
2642  TYPE(equations_sets_type), POINTER :: EQUATIONS_SETS
2643  TYPE(equations_set_ptr_type), POINTER :: NEW_EQUATIONS_SETS(:)
2644 
2645  NULLIFY(new_equations_sets)
2646 
2647  enters("EQUATIONS_SET_DESTROY",err,error,*999)
2648 
2649  IF(ASSOCIATED(equations_set)) THEN
2650  equations_sets=>equations_set%EQUATIONS_SETS
2651  IF(ASSOCIATED(equations_sets)) THEN
2652  equations_set_position=equations_set%GLOBAL_NUMBER
2653 
2654  !Destroy all the equations set components
2655  CALL equations_set_finalise(equations_set,err,error,*999)
2656 
2657  !Remove the equations set from the list of equations set
2658  IF(equations_sets%NUMBER_OF_EQUATIONS_SETS>1) THEN
2659  ALLOCATE(new_equations_sets(equations_sets%NUMBER_OF_EQUATIONS_SETS-1),stat=err)
2660  IF(err/=0) CALL flagerror("Could not allocate new equations sets.",err,error,*999)
2661  DO equations_set_idx=1,equations_sets%NUMBER_OF_EQUATIONS_SETS
2662  IF(equations_set_idx<equations_set_position) THEN
2663  new_equations_sets(equations_set_idx)%PTR=>equations_sets%EQUATIONS_SETS(equations_set_idx)%PTR
2664  ELSE IF(equations_set_idx>equations_set_position) THEN
2665  equations_sets%EQUATIONS_SETS(equations_set_idx)%PTR%GLOBAL_NUMBER=equations_sets% &
2666  & equations_sets(equations_set_idx)%PTR%GLOBAL_NUMBER-1
2667  new_equations_sets(equations_set_idx-1)%PTR=>equations_sets%EQUATIONS_SETS(equations_set_idx)%PTR
2668  ENDIF
2669  ENDDO !equations_set_idx
2670  IF(ASSOCIATED(equations_sets%EQUATIONS_SETS)) DEALLOCATE(equations_sets%EQUATIONS_SETS)
2671  equations_sets%EQUATIONS_SETS=>new_equations_sets
2672  equations_sets%NUMBER_OF_EQUATIONS_SETS=equations_sets%NUMBER_OF_EQUATIONS_SETS-1
2673  ELSE
2674  DEALLOCATE(equations_sets%EQUATIONS_SETS)
2675  equations_sets%NUMBER_OF_EQUATIONS_SETS=0
2676  ENDIF
2677 
2678  ELSE
2679  CALL flagerror("Equations set equations set is not associated.",err,error,*999)
2680  ENDIF
2681  ELSE
2682  CALL flagerror("Equations set is not associated.",err,error,*998)
2683  ENDIF
2684 
2685  exits("EQUATIONS_SET_DESTROY")
2686  RETURN
2687 999 IF(ASSOCIATED(new_equations_sets)) DEALLOCATE(new_equations_sets)
2688 998 errorsexits("EQUATIONS_SET_DESTROY",err,error)
2689  RETURN 1
2690 
2691  END SUBROUTINE equations_set_destroy
2692 
2693  !
2694  !================================================================================================================================
2695  !
2696 
2698  SUBROUTINE equations_set_finalise(EQUATIONS_SET,ERR,ERROR,*)
2699 
2700  !Argument variables
2701  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2702  INTEGER(INTG), INTENT(OUT) :: ERR
2703  TYPE(varying_string), INTENT(OUT) :: ERROR
2704  !Local Variables
2705 
2706  enters("EQUATIONS_SET_FINALISE",err,error,*999)
2707 
2708  IF(ASSOCIATED(equations_set)) THEN
2709  CALL equations_set_geometry_finalise(equations_set%GEOMETRY,err,error,*999)
2710  CALL equations_set_dependent_finalise(equations_set%DEPENDENT,err,error,*999)
2711  CALL equations_set_independent_finalise(equations_set%INDEPENDENT,err,error,*999)
2712  CALL equations_set_materials_finalise(equations_set%MATERIALS,err,error,*999)
2713  CALL equations_set_source_finalise(equations_set%SOURCE,err,error,*999)
2714  CALL equations_set_analytic_finalise(equations_set%ANALYTIC,err,error,*999)
2715  CALL equations_set_equations_set_field_finalise(equations_set%EQUATIONS_SET_FIELD,err,error,*999)
2716  CALL equationsset_derivedfinalise(equations_set%derived,err,error,*999)
2717  IF(ASSOCIATED(equations_set%EQUATIONS)) CALL equations_destroy(equations_set%EQUATIONS,err,error,*999)
2718  IF(ALLOCATED(equations_set%SPECIFICATION)) DEALLOCATE(equations_set%SPECIFICATION)
2719  DEALLOCATE(equations_set)
2720  ENDIF
2721 
2722  exits("EQUATIONS_SET_FINALISE")
2723  RETURN
2724 999 errorsexits("EQUATIONS_SET_FINALISE",err,error)
2725  RETURN 1
2726 
2727  END SUBROUTINE equations_set_finalise
2728 
2729  !
2730  !================================================================================================================================
2731  !
2732 
2734  SUBROUTINE equations_set_finite_element_calculate(EQUATIONS_SET,ELEMENT_NUMBER,ERR,ERROR,*)
2735 
2736  !Argument variables
2737  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2738  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
2739  INTEGER(INTG), INTENT(OUT) :: ERR
2740  TYPE(varying_string), INTENT(OUT) :: ERROR
2741  !Local Variables
2742  INTEGER(INTG) :: matrix_idx
2743  TYPE(element_matrix_type), POINTER :: ELEMENT_MATRIX
2744  TYPE(element_vector_type), POINTER :: ELEMENT_VECTOR
2745  TYPE(equations_type), POINTER :: EQUATIONS
2746  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
2747  TYPE(equations_matrices_dynamic_type), POINTER :: DYNAMIC_MATRICES
2748  TYPE(equations_matrices_linear_type), POINTER :: LINEAR_MATRICES
2749  TYPE(equations_matrices_rhs_type), POINTER :: RHS_VECTOR
2750  TYPE(equations_matrices_source_type), POINTER :: SOURCE_VECTOR
2751  TYPE(varying_string) :: LOCAL_ERROR
2752 
2753 #ifdef TAUPROF
2754  CALL tau_static_phase_start("EQUATIONS_SET_FINITE_ELEMENT_CALCULATE()")
2755 #endif
2756 
2757  enters("EQUATIONS_SET_FINITE_ELEMENT_CALCULATE",err,error,*999)
2758 
2759  IF(ASSOCIATED(equations_set)) THEN
2760  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
2761  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
2762  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
2763  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
2764  END IF
2765  SELECT CASE(equations_set%SPECIFICATION(1))
2766  CASE(equations_set_elasticity_class)
2767  CALL elasticity_finite_element_calculate(equations_set,element_number,err,error,*999)
2768  CASE(equations_set_fluid_mechanics_class)
2769  CALL fluid_mechanics_finite_element_calculate(equations_set,element_number,err,error,*999)
2770  CASE(equations_set_electromagnetics_class)
2771  CALL flagerror("Not implemented.",err,error,*999)
2772  CASE(equations_set_classical_field_class)
2773  CALL classical_field_finite_element_calculate(equations_set,element_number,err,error,*999)
2774  CASE(equations_set_fitting_class)
2775  CALL fitting_finite_element_calculate(equations_set,element_number,err,error,*999)
2776  CASE(equations_set_bioelectrics_class)
2777  IF(SIZE(equations_set%SPECIFICATION,1)<2) THEN
2778  CALL flagerror("Equations set specification must have at least two entries for a bioelectrics equation class.", &
2779  & err,error,*999)
2780  END IF
2781  IF(equations_set%SPECIFICATION(2) == equations_set_monodomain_strang_splitting_equation_type) THEN
2782  CALL monodomain_finiteelementcalculate(equations_set,element_number,err,error,*999)
2783  ELSE
2784  CALL bioelectric_finite_element_calculate(equations_set,element_number,err,error,*999)
2785  END IF
2786  CASE(equations_set_modal_class)
2787  CALL flagerror("Not implemented.",err,error,*999)
2788  CASE(equations_set_multi_physics_class)
2789  CALL multi_physics_finite_element_calculate(equations_set,element_number,err,error,*999)
2790  CASE DEFAULT
2791  local_error="The first equations set specification of "// &
2792  & trim(number_to_vstring(equations_set%SPECIFICATION(1),"*",err,error))//" is not valid."
2793  CALL flagerror(local_error,err,error,*999)
2794  END SELECT
2795  equations=>equations_set%EQUATIONS
2796  IF(ASSOCIATED(equations)) THEN
2797  IF(equations%OUTPUT_TYPE>=equations_element_matrix_output) THEN
2798  equations_matrices=>equations%EQUATIONS_MATRICES
2799  IF(ASSOCIATED(equations_matrices)) THEN
2800  CALL write_string(general_output_type,"Finite element stiffness matrices:",err,error,*999)
2801  CALL write_string_value(general_output_type,"Element number = ",element_number,err,error,*999)
2802  dynamic_matrices=>equations_matrices%DYNAMIC_MATRICES
2803  IF(ASSOCIATED(dynamic_matrices)) THEN
2804  CALL write_string(general_output_type,"Dynamic matrices:",err,error,*999)
2805  CALL write_string_value(general_output_type,"Number of element matrices = ",dynamic_matrices% &
2806  & number_of_dynamic_matrices,err,error,*999)
2807  DO matrix_idx=1,dynamic_matrices%NUMBER_OF_DYNAMIC_MATRICES
2808  CALL write_string_value(general_output_type,"Element matrix : ",matrix_idx,err,error,*999)
2809  CALL write_string_value(general_output_type," Update matrix = ",dynamic_matrices%MATRICES(matrix_idx)%PTR% &
2810  & update_matrix,err,error,*999)
2811  IF(dynamic_matrices%MATRICES(matrix_idx)%PTR%UPDATE_MATRIX) THEN
2812  element_matrix=>dynamic_matrices%MATRICES(matrix_idx)%PTR%ELEMENT_MATRIX
2813  CALL write_string_value(general_output_type," Number of rows = ",element_matrix%NUMBER_OF_ROWS,err,error,*999)
2814  CALL write_string_value(general_output_type," Number of columns = ",element_matrix%NUMBER_OF_COLUMNS, &
2815  & err,error,*999)
2816  CALL write_string_value(general_output_type," Maximum number of rows = ",element_matrix%MAX_NUMBER_OF_ROWS, &
2817  & err,error,*999)
2818  CALL write_string_value(general_output_type," Maximum number of columns = ",element_matrix% &
2819  & max_number_of_columns,err,error,*999)
2820  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,8,8,element_matrix%ROW_DOFS, &
2821  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
2822  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_COLUMNS,8,8,element_matrix% &
2823  & column_dofs,'(" Column dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
2824  CALL write_string_matrix(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,1,1,element_matrix% &
2825  & number_of_columns,8,8,element_matrix%MATRIX(1:element_matrix%NUMBER_OF_ROWS,1:element_matrix% &
2826  & number_of_columns),write_string_matrix_name_and_indices,'(" Matrix','(",I2,",:)',' :",8(X,E13.6))', &
2827  & '(16X,8(X,E13.6))',err,error,*999)
2828  ENDIF
2829  ENDDO !matrix_idx
2830  ENDIF
2831  linear_matrices=>equations_matrices%LINEAR_MATRICES
2832  IF(ASSOCIATED(linear_matrices)) THEN
2833  CALL write_string(general_output_type,"Linear matrices:",err,error,*999)
2834  CALL write_string_value(general_output_type,"Number of element matrices = ",linear_matrices% &
2835  & number_of_linear_matrices,err,error,*999)
2836  DO matrix_idx=1,linear_matrices%NUMBER_OF_LINEAR_MATRICES
2837  CALL write_string_value(general_output_type,"Element matrix : ",matrix_idx,err,error,*999)
2838  CALL write_string_value(general_output_type," Update matrix = ",linear_matrices%MATRICES(matrix_idx)%PTR% &
2839  & update_matrix,err,error,*999)
2840  IF(linear_matrices%MATRICES(matrix_idx)%PTR%UPDATE_MATRIX) THEN
2841  element_matrix=>linear_matrices%MATRICES(matrix_idx)%PTR%ELEMENT_MATRIX
2842  CALL write_string_value(general_output_type," Number of rows = ",element_matrix%NUMBER_OF_ROWS,err,error,*999)
2843  CALL write_string_value(general_output_type," Number of columns = ",element_matrix%NUMBER_OF_COLUMNS, &
2844  & err,error,*999)
2845  CALL write_string_value(general_output_type," Maximum number of rows = ",element_matrix%MAX_NUMBER_OF_ROWS, &
2846  & err,error,*999)
2847  CALL write_string_value(general_output_type," Maximum number of columns = ",element_matrix% &
2848  & max_number_of_columns,err,error,*999)
2849  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,8,8,element_matrix%ROW_DOFS, &
2850  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
2851  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_COLUMNS,8,8,element_matrix% &
2852  & column_dofs,'(" Column dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
2853  CALL write_string_matrix(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,1,1,element_matrix% &
2854  & number_of_columns,8,8,element_matrix%MATRIX(1:element_matrix%NUMBER_OF_ROWS,1:element_matrix% &
2855  & number_of_columns),write_string_matrix_name_and_indices,'(" Matrix','(",I2,",:)',' :",8(X,E13.6))', &
2856  & '(16X,8(X,E13.6))',err,error,*999)
2857  ENDIF
2858  ENDDO !matrix_idx
2859  ENDIF
2860  rhs_vector=>equations_matrices%RHS_VECTOR
2861  IF(ASSOCIATED(rhs_vector)) THEN
2862  CALL write_string(general_output_type,"Element RHS vector :",err,error,*999)
2863  CALL write_string_value(general_output_type," Update vector = ",rhs_vector%UPDATE_VECTOR,err,error,*999)
2864  IF(rhs_vector%UPDATE_VECTOR) THEN
2865  element_vector=>rhs_vector%ELEMENT_VECTOR
2866  CALL write_string_value(general_output_type," Number of rows = ",element_vector%NUMBER_OF_ROWS,err,error,*999)
2867  CALL write_string_value(general_output_type," Maximum number of rows = ",element_vector%MAX_NUMBER_OF_ROWS, &
2868  & err,error,*999)
2869  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%ROW_DOFS, &
2870  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
2871  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%VECTOR, &
2872  & '(" Vector(:):",8(X,E13.6))','(16X,8(X,E13.6))',err,error,*999)
2873  ENDIF
2874  ENDIF
2875  source_vector=>equations_matrices%SOURCE_VECTOR
2876  IF(ASSOCIATED(source_vector)) THEN
2877  CALL write_string(general_output_type,"Element source vector :",err,error,*999)
2878  CALL write_string_value(general_output_type," Update vector = ",source_vector%UPDATE_VECTOR,err,error,*999)
2879  IF(source_vector%UPDATE_VECTOR) THEN
2880  element_vector=>source_vector%ELEMENT_VECTOR
2881  CALL write_string_value(general_output_type," Number of rows = ",element_vector%NUMBER_OF_ROWS,err,error,*999)
2882  CALL write_string_value(general_output_type," Maximum number of rows = ",element_vector%MAX_NUMBER_OF_ROWS, &
2883  & err,error,*999)
2884  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%ROW_DOFS, &
2885  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
2886  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%VECTOR, &
2887  & '(" Vector(:):",8(X,E13.6))','(16X,8(X,E13.6))',err,error,*999)
2888  ENDIF
2889  ENDIF
2890  ELSE
2891  CALL flagerror("Equation matrices is not associated.",err,error,*999)
2892  ENDIF
2893  ENDIF
2894  ELSE
2895  CALL flagerror("Equations is not associated.",err,error,*999)
2896  ENDIF
2897  ELSE
2898  CALL flagerror("Equations set is not associated.",err,error,*999)
2899  ENDIF
2900 
2901 #ifdef TAUPROF
2902  CALL tau_static_phase_stop("EQUATIONS_SET_FINITE_ELEMENT_CALCULATE()")
2903 #endif
2904 
2905  exits("EQUATIONS_SET_FINITE_ELEMENT_CALCULATE")
2906  RETURN
2907 999 errorsexits("EQUATIONS_SET_FINITE_ELEMENT_CALCULATE",err,error)
2908  RETURN 1
2909 
2910  END SUBROUTINE equations_set_finite_element_calculate
2911 
2912  !
2913  !================================================================================================================================
2914  !
2915 
2917  SUBROUTINE equationsset_finiteelementjacobianevaluate(EQUATIONS_SET,ELEMENT_NUMBER,ERR,ERROR,*)
2918 
2919  !Argument variables
2920  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2921  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
2922  INTEGER(INTG), INTENT(OUT) :: ERR
2923  TYPE(varying_string), INTENT(OUT) :: ERROR
2924  !Local Variables
2925  INTEGER(INTG) :: matrix_idx
2926  TYPE(element_matrix_type), POINTER :: ELEMENT_MATRIX
2927  TYPE(equations_type), POINTER :: EQUATIONS
2928  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
2929  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
2930  TYPE(varying_string) :: LOCAL_ERROR
2931 
2932  enters("EquationsSet_FiniteElementJacobianEvaluate",err,error,*999)
2933 
2934  IF(ASSOCIATED(equations_set)) THEN
2935  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
2936  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
2937  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
2938  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
2939  END IF
2940  equations=>equations_set%EQUATIONS
2941  IF(ASSOCIATED(equations)) THEN
2942  equations_matrices=>equations%EQUATIONS_MATRICES
2943  IF(ASSOCIATED(equations_matrices)) THEN
2944  nonlinear_matrices=>equations_matrices%NONLINEAR_MATRICES
2945  IF(ASSOCIATED(nonlinear_matrices)) THEN
2946  DO matrix_idx=1,nonlinear_matrices%NUMBER_OF_JACOBIANS
2947  SELECT CASE(nonlinear_matrices%JACOBIANS(matrix_idx)%PTR%JACOBIAN_CALCULATION_TYPE)
2948  CASE(equations_jacobian_analytic_calculated)
2949  ! None of these routines currently support calculating off diagonal terms for coupled problems,
2950  ! but when one does we will have to pass through the matrix_idx parameter
2951  IF(matrix_idx>1) THEN
2952  CALL flagerror("Analytic off-diagonal Jacobian calculation not implemented.",err,error,*999)
2953  END IF
2954  SELECT CASE(equations_set%SPECIFICATION(1))
2955  CASE(equations_set_elasticity_class)
2956  CALL elasticity_finite_element_jacobian_evaluate(equations_set,element_number,err,error,*999)
2957  CASE(equations_set_fluid_mechanics_class)
2958  CALL fluidmechanics_finiteelementjacobianevaluate(equations_set,element_number,err,error,*999)
2959  CASE(equations_set_electromagnetics_class)
2960  CALL flagerror("Not implemented.",err,error,*999)
2961  CASE(equations_set_classical_field_class)
2962  CALL classicalfield_finiteelementjacobianevaluate(equations_set,element_number,err,error,*999)
2963  CASE(equations_set_bioelectrics_class)
2964  CALL flagerror("Not implemented.",err,error,*999)
2965  CASE(equations_set_modal_class)
2966  CALL flagerror("Not implemented.",err,error,*999)
2967  CASE(equations_set_multi_physics_class)
2968  CALL multiphysics_finiteelementjacobianevaluate(equations_set,element_number,err,error,*999)
2969  CASE DEFAULT
2970  local_error="The first equations set specification of"// &
2971  & trim(number_to_vstring(equations_set%SPECIFICATION(1),"*", &
2972  & err,error))//" is not valid."
2973  CALL flagerror(local_error,err,error,*999)
2974  END SELECT
2975  CASE(equations_jacobian_finite_difference_calculated)
2976  CALL equationsset_finiteelementjacobianevaluatefd(equations_set,element_number,matrix_idx,err,error,*999)
2977  CASE DEFAULT
2978  local_error="Jacobian calculation type "//trim(number_to_vstring(nonlinear_matrices%JACOBIANS(matrix_idx)%PTR% &
2979  & jacobian_calculation_type,"*",err,error))//" is not valid."
2980  CALL flagerror(local_error,err,error,*999)
2981  END SELECT
2982  END DO
2983  ELSE
2984  CALL flagerror("Equations nonlinear matrices is not associated.",err,error,*999)
2985  END IF
2986  ELSE
2987  CALL flagerror("Equations matrices is not associated.",err,error,*999)
2988  END IF
2989  IF(equations%OUTPUT_TYPE>=equations_element_matrix_output) THEN
2990  CALL write_string(general_output_type,"",err,error,*999)
2991  CALL write_string(general_output_type,"Finite element Jacobian matrix:",err,error,*999)
2992  CALL write_string_value(general_output_type,"Element number = ",element_number,err,error,*999)
2993  CALL write_string(general_output_type,"Element Jacobian:",err,error,*999)
2994  DO matrix_idx=1,nonlinear_matrices%NUMBER_OF_JACOBIANS
2995  CALL write_string_value(general_output_type," Jacobian number = ",matrix_idx,err,error,*999)
2996  CALL write_string_value(general_output_type," Update Jacobian = ",nonlinear_matrices%JACOBIANS(matrix_idx)%PTR% &
2997  & update_jacobian,err,error,*999)
2998  IF(nonlinear_matrices%JACOBIANS(matrix_idx)%PTR%UPDATE_JACOBIAN) THEN
2999  element_matrix=>nonlinear_matrices%JACOBIANS(matrix_idx)%PTR%ELEMENT_JACOBIAN
3000  CALL write_string_value(general_output_type," Number of rows = ",element_matrix%NUMBER_OF_ROWS,err,error,*999)
3001  CALL write_string_value(general_output_type," Number of columns = ",element_matrix%NUMBER_OF_COLUMNS, &
3002  & err,error,*999)
3003  CALL write_string_value(general_output_type," Maximum number of rows = ",element_matrix%MAX_NUMBER_OF_ROWS, &
3004  & err,error,*999)
3005  CALL write_string_value(general_output_type," Maximum number of columns = ",element_matrix% &
3006  & max_number_of_columns,err,error,*999)
3007  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,8,8,element_matrix%ROW_DOFS, &
3008  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3009  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_COLUMNS,8,8,element_matrix% &
3010  & column_dofs,'(" Column dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3011  CALL write_string_matrix(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,1,1,element_matrix% &
3012  & number_of_columns,8,8,element_matrix%MATRIX(1:element_matrix%NUMBER_OF_ROWS,1:element_matrix% &
3013  & number_of_columns),write_string_matrix_name_and_indices,'(" Matrix','(",I2,",:)',' :",8(X,E13.6))', &
3014  & '(16X,8(X,E13.6))',err,error,*999)
3015 !!TODO: Write out the element residual???
3016  END IF
3017  END DO
3018  END IF
3019  ELSE
3020  CALL flagerror("Equations is not associated.",err,error,*999)
3021  END IF
3022  ELSE
3023  CALL flagerror("Equations set is not associated.",err,error,*999)
3024  END IF
3025 
3026  exits("EquationsSet_FiniteElementJacobianEvaluate")
3027  RETURN
3028 999 errorsexits("EquationsSet_FiniteElementJacobianEvaluate",err,error)
3029  RETURN 1
3030 
3031  END SUBROUTINE equationsset_finiteelementjacobianevaluate
3032 
3033  !
3034  !================================================================================================================================
3035  !
3036 
3038  SUBROUTINE equationsset_finiteelementjacobianevaluatefd(equationsSet,elementNumber,jacobianNumber,err,error,*)
3039 
3040  !Argument variables
3041  TYPE(equations_set_type), POINTER :: equationsSet
3042  INTEGER(INTG), INTENT(IN) :: elementNumber
3043  INTEGER(INTG), INTENT(IN) :: jacobianNumber
3044  INTEGER(INTG), INTENT(OUT) :: err
3045  TYPE(varying_string), INTENT(OUT) :: error
3046  !Local Variables
3047  TYPE(equations_type), POINTER :: equations
3048  TYPE(equations_matrices_type), POINTER :: equationsMatrices
3049  TYPE(equations_matrices_nonlinear_type), POINTER :: nonlinearMatrices
3050  TYPE(equations_mapping_nonlinear_type), POINTER :: nonlinearMapping
3051  TYPE(domain_elements_type), POINTER :: elementsTopology
3052  TYPE(basis_type), POINTER :: basis
3053  TYPE(distributed_vector_type), POINTER :: parameters
3054  TYPE(field_variable_type), POINTER :: rowVariable,columnVariable
3055  TYPE(element_vector_type) :: elementVector
3056  INTEGER(INTG) :: componentIdx,localNy,version,derivativeIdx,derivative,nodeIdx,node,column
3057  INTEGER(INTG) :: componentInterpolationType
3058  INTEGER(INTG) :: numberOfRows
3059  REAL(DP) :: delta,origDepVar
3060 
3061  enters("EquationsSet_FiniteElementJacobianEvaluateFD",err,error,*999)
3062 
3063  IF(ASSOCIATED(equationsset)) THEN
3064  equations=>equationsset%EQUATIONS
3065  IF(ASSOCIATED(equations)) THEN
3066  equationsmatrices=>equations%EQUATIONS_MATRICES
3067  nonlinearmatrices=>equationsmatrices%NONLINEAR_MATRICES
3068  nonlinearmapping=>equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING
3069  ! The first residual variable is always the row variable, which is the variable the
3070  ! residual is calculated for
3071  rowvariable=>nonlinearmapping%RESIDUAL_VARIABLES(1)%PTR
3072  ! For coupled problems this routine will be called multiple times if multiple Jacobians use finite
3073  ! differencing, so make sure we only calculate the residual vector once, to save time and because
3074  ! it would otherwise add together
3075  IF(nonlinearmatrices%ELEMENT_RESIDUAL_CALCULATED/=elementnumber) THEN
3076  CALL equationsset_finiteelementresidualevaluate(equationsset,elementnumber,err,error,*999)
3077  END IF
3078  ! make a temporary copy of the unperturbed residuals
3079  elementvector=nonlinearmatrices%ELEMENT_RESIDUAL
3080  IF(jacobiannumber<=nonlinearmatrices%NUMBER_OF_JACOBIANS) THEN
3081  ! For coupled nonlinear problems there will be multiple Jacobians
3082  ! For this equations set, we calculate the residual for the row variable
3083  ! while pertubing parameters from the column variable.
3084  ! For non coupled problems these two variables will be the same
3085  columnvariable=>nonlinearmapping%RESIDUAL_VARIABLES(jacobiannumber)%PTR
3086  parameters=>columnvariable%PARAMETER_SETS%PARAMETER_SETS(field_values_set_type)%PTR%PARAMETERS ! vector of dependent variables, basically
3087  numberofrows=nonlinearmatrices%JACOBIANS(jacobiannumber)%PTR%ELEMENT_JACOBIAN%NUMBER_OF_ROWS
3088  IF(numberofrows/=nonlinearmatrices%ELEMENT_RESIDUAL%NUMBER_OF_ROWS) THEN
3089  CALL flagerror("Element matrix number of rows does not match element residual vector size.",err,error,*999)
3090  END IF
3091  ! determine step size
3092  CALL distributedvector_l2norm(parameters,delta,err,error,*999)
3093  delta=(1.0_dp+delta)*1e-6
3094  ! the actual finite differencing algorithm is about 4 lines but since the parameters are all
3095  ! distributed out, have to use proper field accessing routines..
3096  ! so let's just loop over component, node/el, derivative
3097  column=0 ! element jacobian matrix column number
3098  DO componentidx=1,columnvariable%NUMBER_OF_COMPONENTS
3099  elementstopology=>columnvariable%COMPONENTS(componentidx)%DOMAIN%TOPOLOGY%ELEMENTS
3100  componentinterpolationtype=columnvariable%COMPONENTS(componentidx)%INTERPOLATION_TYPE
3101  SELECT CASE (componentinterpolationtype)
3102  CASE (field_node_based_interpolation)
3103  basis=>elementstopology%ELEMENTS(elementnumber)%BASIS
3104  DO nodeidx=1,basis%NUMBER_OF_NODES
3105  node=elementstopology%ELEMENTS(elementnumber)%ELEMENT_NODES(nodeidx)
3106  DO derivativeidx=1,basis%NUMBER_OF_DERIVATIVES(nodeidx)
3107  derivative=elementstopology%ELEMENTS(elementnumber)%ELEMENT_DERIVATIVES(derivativeidx,nodeidx)
3108  version=elementstopology%ELEMENTS(elementnumber)%elementVersions(derivativeidx,nodeidx)
3109  localny=columnvariable%COMPONENTS(componentidx)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node)% &
3110  & derivatives(derivative)%VERSIONS(version)
3111  ! one-sided finite difference
3112  CALL distributed_vector_values_get(parameters,localny,origdepvar,err,error,*999)
3113  CALL distributed_vector_values_set(parameters,localny,origdepvar+delta,err,error,*999)
3114  nonlinearmatrices%ELEMENT_RESIDUAL%VECTOR=0.0_dp ! must remember to flush existing results, otherwise they're added
3115  CALL equationsset_finiteelementresidualevaluate(equationsset,elementnumber,err,error,*999)
3116  CALL distributed_vector_values_set(parameters,localny,origdepvar,err,error,*999)
3117  column=column+1
3118  nonlinearmatrices%JACOBIANS(jacobiannumber)%PTR%ELEMENT_JACOBIAN%MATRIX(1:numberofrows,column)= &
3119  & (nonlinearmatrices%ELEMENT_RESIDUAL%VECTOR(1:numberofrows)-elementvector%VECTOR(1:numberofrows))/delta
3120  ENDDO !derivativeIdx
3121  ENDDO !nodeIdx
3122  CASE (field_element_based_interpolation)
3123  localny=columnvariable%COMPONENTS(componentidx)%PARAM_TO_DOF_MAP%ELEMENT_PARAM2DOF_MAP%ELEMENTS(elementnumber)
3124  ! one-sided finite difference
3125  CALL distributed_vector_values_get(parameters,localny,origdepvar,err,error,*999)
3126  CALL distributed_vector_values_set(parameters,localny,origdepvar+delta,err,error,*999)
3127  nonlinearmatrices%ELEMENT_RESIDUAL%VECTOR=0.0_dp ! must remember to flush existing results, otherwise they're added
3128  CALL equationsset_finiteelementresidualevaluate(equationsset,elementnumber,err,error,*999)
3129  CALL distributed_vector_values_set(parameters,localny,origdepvar,err,error,*999)
3130  column=column+1
3131  nonlinearmatrices%JACOBIANS(jacobiannumber)%PTR%ELEMENT_JACOBIAN%MATRIX(1:numberofrows,column)= &
3132  & (nonlinearmatrices%ELEMENT_RESIDUAL%VECTOR(1:numberofrows)-elementvector%VECTOR(1:numberofrows))/delta
3133  CASE DEFAULT
3134  CALL flagerror("Unsupported type of interpolation.",err,error,*999)
3135  END SELECT
3136  END DO
3137  ! put the original residual back in
3138  nonlinearmatrices%ELEMENT_RESIDUAL=elementvector
3139  ELSE
3140  CALL flagerror("Invalid Jacobian number of "//trim(number_to_vstring(jacobiannumber,"*",err,error))// &
3141  & ". The number should be <= "//trim(number_to_vstring(nonlinearmatrices%NUMBER_OF_JACOBIANS,"*",err,error))// &
3142  & ".",err,error,*999)
3143  END IF
3144  ELSE
3145  CALL flagerror("Equations set equations is not associated.",err,error,*999)
3146  END IF
3147  ELSE
3148  CALL flagerror("Equations set is not associated.",err,error,*999)
3149  END IF
3150 
3151  exits("EquationsSet_FiniteElementJacobianEvaluateFD")
3152  RETURN
3153 999 errors("EquationsSet_FiniteElementJacobianEvaluateFD",err,error)
3154  exits("EquationsSet_FiniteElementJacobianEvaluateFD")
3155  RETURN 1
3156  END SUBROUTINE equationsset_finiteelementjacobianevaluatefd
3157 
3158  !
3159  !================================================================================================================================
3160  !
3161 
3163  SUBROUTINE equationsset_finiteelementresidualevaluate(EQUATIONS_SET,ELEMENT_NUMBER,ERR,ERROR,*)
3164 
3165  !Argument variables
3166  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3167  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
3168  INTEGER(INTG), INTENT(OUT) :: ERR
3169  TYPE(varying_string), INTENT(OUT) :: ERROR
3170  !Local Variables
3171  INTEGER(INTG) :: matrix_idx
3172  TYPE(element_matrix_type), POINTER :: ELEMENT_MATRIX
3173  TYPE(element_vector_type), POINTER :: ELEMENT_VECTOR
3174  TYPE(equations_type), POINTER :: EQUATIONS
3175  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
3176  TYPE(equations_matrices_dynamic_type), POINTER :: DYNAMIC_MATRICES
3177  TYPE(equations_matrices_linear_type), POINTER :: LINEAR_MATRICES
3178  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
3179  TYPE(equations_matrices_rhs_type), POINTER :: RHS_VECTOR
3180  TYPE(equations_matrices_source_type), POINTER :: SOURCE_VECTOR
3181  TYPE(varying_string) :: LOCAL_ERROR
3182 
3183  enters("EquationsSet_FiniteElementResidualEvaluate",err,error,*999)
3184 
3185  IF(ASSOCIATED(equations_set)) THEN
3186  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
3187  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
3188  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
3189  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
3190  END IF
3191  SELECT CASE(equations_set%SPECIFICATION(1))
3192  CASE(equations_set_elasticity_class)
3193  CALL elasticity_finite_element_residual_evaluate(equations_set,element_number,err,error,*999)
3194  CASE(equations_set_fluid_mechanics_class)
3195  CALL fluidmechanics_finiteelementresidualevaluate(equations_set,element_number,err,error,*999)
3196  CASE(equations_set_electromagnetics_class)
3197  CALL flagerror("Not implemented.",err,error,*999)
3198  CASE(equations_set_classical_field_class)
3199  CALL classicalfield_finiteelementresidualevaluate(equations_set,element_number,err,error,*999)
3200  CASE(equations_set_bioelectrics_class)
3201  CALL flagerror("Not implemented.",err,error,*999)
3202  CASE(equations_set_modal_class)
3203  CALL flagerror("Not implemented.",err,error,*999)
3204  CASE(equations_set_multi_physics_class)
3205  CALL multiphysics_finiteelementresidualevaluate(equations_set,element_number,err,error,*999)
3206  CASE DEFAULT
3207  local_error="The first equations set specification of "// &
3208  & trim(number_to_vstring(equations_set%SPECIFICATION(1),"*",err,error))//" is not valid."
3209  CALL flagerror(local_error,err,error,*999)
3210  END SELECT
3211  equations=>equations_set%EQUATIONS
3212  IF(ASSOCIATED(equations)) THEN
3213  equations_matrices=>equations%EQUATIONS_MATRICES
3214  IF(ASSOCIATED(equations_matrices)) THEN
3215  nonlinear_matrices=>equations_matrices%NONLINEAR_MATRICES
3216  IF(ASSOCIATED(nonlinear_matrices)) THEN
3217  nonlinear_matrices%ELEMENT_RESIDUAL_CALCULATED=element_number
3218  IF(equations%OUTPUT_TYPE>=equations_element_matrix_output) THEN
3219  CALL write_string(general_output_type,"",err,error,*999)
3220  CALL write_string(general_output_type,"Finite element residual matrices and vectors:",err,error,*999)
3221  CALL write_string_value(general_output_type,"Element number = ",element_number,err,error,*999)
3222  linear_matrices=>equations_matrices%LINEAR_MATRICES
3223  IF(ASSOCIATED(linear_matrices)) THEN
3224  CALL write_string(general_output_type,"Linear matrices:",err,error,*999)
3225  CALL write_string_value(general_output_type,"Number of element matrices = ",linear_matrices% &
3226  & number_of_linear_matrices,err,error,*999)
3227  DO matrix_idx=1,linear_matrices%NUMBER_OF_LINEAR_MATRICES
3228  CALL write_string_value(general_output_type,"Element matrix : ",matrix_idx,err,error,*999)
3229  CALL write_string_value(general_output_type," Update matrix = ",linear_matrices%MATRICES(matrix_idx)%PTR% &
3230  & update_matrix,err,error,*999)
3231  IF(linear_matrices%MATRICES(matrix_idx)%PTR%UPDATE_MATRIX) THEN
3232  element_matrix=>linear_matrices%MATRICES(matrix_idx)%PTR%ELEMENT_MATRIX
3233  CALL write_string_value(general_output_type," Number of rows = ",element_matrix%NUMBER_OF_ROWS,err,error,*999)
3234  CALL write_string_value(general_output_type," Number of columns = ",element_matrix%NUMBER_OF_COLUMNS, &
3235  & err,error,*999)
3236  CALL write_string_value(general_output_type," Maximum number of rows = ",element_matrix%MAX_NUMBER_OF_ROWS, &
3237  & err,error,*999)
3238  CALL write_string_value(general_output_type," Maximum number of columns = ",element_matrix% &
3239  & max_number_of_columns,err,error,*999)
3240  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,8,8,element_matrix%ROW_DOFS, &
3241  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3242  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_COLUMNS,8,8,element_matrix% &
3243  & column_dofs,'(" Column dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3244  CALL write_string_matrix(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,1,1,element_matrix% &
3245  & number_of_columns,8,8,element_matrix%MATRIX(1:element_matrix%NUMBER_OF_ROWS,1:element_matrix% &
3246  & number_of_columns),write_string_matrix_name_and_indices,'(" Matrix','(",I2,",:)',' :",8(X,E13.6))', &
3247  & '(16X,8(X,E13.6))',err,error,*999)
3248  ENDIF
3249  ENDDO !matrix_idx
3250  ENDIF
3251  dynamic_matrices=>equations_matrices%DYNAMIC_MATRICES
3252  IF(ASSOCIATED(dynamic_matrices)) THEN
3253  CALL write_string(general_output_type,"Dynamnic matrices:",err,error,*999)
3254  CALL write_string_value(general_output_type,"Number of element matrices = ",dynamic_matrices% &
3255  & number_of_dynamic_matrices,err,error,*999)
3256  DO matrix_idx=1,dynamic_matrices%NUMBER_OF_DYNAMIC_MATRICES
3257  CALL write_string_value(general_output_type,"Element matrix : ",matrix_idx,err,error,*999)
3258  CALL write_string_value(general_output_type," Update matrix = ",dynamic_matrices%MATRICES(matrix_idx)%PTR% &
3259  & update_matrix,err,error,*999)
3260  IF(dynamic_matrices%MATRICES(matrix_idx)%PTR%UPDATE_MATRIX) THEN
3261  element_matrix=>dynamic_matrices%MATRICES(matrix_idx)%PTR%ELEMENT_MATRIX
3262  CALL write_string_value(general_output_type," Number of rows = ",element_matrix%NUMBER_OF_ROWS,err,error,*999)
3263  CALL write_string_value(general_output_type," Number of columns = ",element_matrix%NUMBER_OF_COLUMNS, &
3264  & err,error,*999)
3265  CALL write_string_value(general_output_type," Maximum number of rows = ",element_matrix%MAX_NUMBER_OF_ROWS, &
3266  & err,error,*999)
3267  CALL write_string_value(general_output_type," Maximum number of columns = ",element_matrix% &
3268  & max_number_of_columns,err,error,*999)
3269  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,8,8,element_matrix%ROW_DOFS, &
3270  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3271  CALL write_string_vector(general_output_type,1,1,element_matrix%NUMBER_OF_COLUMNS,8,8,element_matrix% &
3272  & column_dofs,'(" Column dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3273  CALL write_string_matrix(general_output_type,1,1,element_matrix%NUMBER_OF_ROWS,1,1,element_matrix% &
3274  & number_of_columns,8,8,element_matrix%MATRIX(1:element_matrix%NUMBER_OF_ROWS,1:element_matrix% &
3275  & number_of_columns),write_string_matrix_name_and_indices,'(" Matrix','(",I2,",:)',' :",8(X,E13.6))', &
3276  & '(16X,8(X,E13.6))',err,error,*999)
3277  ENDIF
3278  ENDDO !matrix_idx
3279  ENDIF
3280  CALL write_string(general_output_type,"Element residual vector:",err,error,*999)
3281  CALL write_string_value(general_output_type," Update vector = ",nonlinear_matrices%UPDATE_RESIDUAL,err,error,*999)
3282  IF(nonlinear_matrices%UPDATE_RESIDUAL) THEN
3283  element_vector=>nonlinear_matrices%ELEMENT_RESIDUAL
3284  CALL write_string_value(general_output_type," Number of rows = ",element_vector%NUMBER_OF_ROWS,err,error,*999)
3285  CALL write_string_value(general_output_type," Maximum number of rows = ",element_vector%MAX_NUMBER_OF_ROWS, &
3286  & err,error,*999)
3287  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%ROW_DOFS, &
3288  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3289  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%VECTOR, &
3290  & '(" Vector(:):",8(X,E13.6))','(16X,8(X,E13.6))',err,error,*999)
3291  ENDIF
3292  rhs_vector=>equations_matrices%RHS_VECTOR
3293  IF(ASSOCIATED(rhs_vector)) THEN
3294  CALL write_string(general_output_type,"Element RHS vector :",err,error,*999)
3295  CALL write_string_value(general_output_type," Update vector = ",rhs_vector%UPDATE_VECTOR,err,error,*999)
3296  IF(rhs_vector%UPDATE_VECTOR) THEN
3297  element_vector=>rhs_vector%ELEMENT_VECTOR
3298  CALL write_string_value(general_output_type," Number of rows = ",element_vector%NUMBER_OF_ROWS,err,error,*999)
3299  CALL write_string_value(general_output_type," Maximum number of rows = ",element_vector%MAX_NUMBER_OF_ROWS, &
3300  & err,error,*999)
3301  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%ROW_DOFS, &
3302  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3303  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%VECTOR, &
3304  & '(" Vector(:) :",8(X,E13.6))','(16X,8(X,E13.6))',err,error,*999)
3305  ENDIF
3306  ENDIF
3307  source_vector=>equations_matrices%SOURCE_VECTOR
3308  IF(ASSOCIATED(source_vector)) THEN
3309  CALL write_string(general_output_type,"Element source vector :",err,error,*999)
3310  CALL write_string_value(general_output_type," Update vector = ",source_vector%UPDATE_VECTOR,err,error,*999)
3311  IF(source_vector%UPDATE_VECTOR) THEN
3312  element_vector=>source_vector%ELEMENT_VECTOR
3313  CALL write_string_value(general_output_type," Number of rows = ",element_vector%NUMBER_OF_ROWS,err,error,*999)
3314  CALL write_string_value(general_output_type," Maximum number of rows = ",element_vector%MAX_NUMBER_OF_ROWS, &
3315  & err,error,*999)
3316  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%ROW_DOFS, &
3317  & '(" Row dofs :",8(X,I13))','(16X,8(X,I13))',err,error,*999)
3318  CALL write_string_vector(general_output_type,1,1,element_vector%NUMBER_OF_ROWS,8,8,element_vector%VECTOR, &
3319  & '(" Vector(:) :",8(X,E13.6))','(16X,8(X,E13.6))',err,error,*999)
3320  ENDIF
3321  ENDIF
3322  ENDIF
3323  ELSE
3324  CALL flagerror("Equation nonlinear matrices not associated.",err,error,*999)
3325  ENDIF
3326  ELSE
3327  CALL flagerror("Equation matrices is not associated.",err,error,*999)
3328  ENDIF
3329  ELSE
3330  CALL flagerror("Equations is not associated.",err,error,*999)
3331  ENDIF
3332  ELSE
3333  CALL flagerror("Equations set is not associated.",err,error,*999)
3334  ENDIF
3335 
3336  exits("EquationsSet_FiniteElementResidualEvaluate")
3337  RETURN
3338 999 errorsexits("EquationsSet_FiniteElementResidualEvaluate",err,error)
3339  RETURN 1
3340 
3341  END SUBROUTINE equationsset_finiteelementresidualevaluate
3342 
3343  !
3344  !================================================================================================================================
3345  !
3346 
3348  SUBROUTINE equations_set_independent_create_finish(EQUATIONS_SET,ERR,ERROR,*)
3349 
3350  !Argument variables
3351  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3352  INTEGER(INTG), INTENT(OUT) :: ERR
3353  TYPE(varying_string), INTENT(OUT) :: ERROR
3354  !Local Variables
3355  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
3356  TYPE(field_type), POINTER :: INDEPENDENT_FIELD
3357 
3358  enters("EQUATIONS_SET_INDEPENDENT_CREATE_FINISH",err,error,*999)
3359 
3360  IF(ASSOCIATED(equations_set)) THEN
3361  IF(ASSOCIATED(equations_set%INDEPENDENT)) THEN
3362  IF(equations_set%INDEPENDENT%INDEPENDENT_FINISHED) THEN
3363  CALL flagerror("Equations set independent field has already been finished.",err,error,*999)
3364  ELSE
3365  !Initialise the setup
3366  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
3367  equations_set_setup_info%SETUP_TYPE=equations_set_setup_independent_type
3368  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
3369  independent_field=>equations_set%INDEPENDENT%INDEPENDENT_FIELD
3370  IF(ASSOCIATED(independent_field)) THEN
3371  equations_set_setup_info%FIELD_USER_NUMBER=independent_field%USER_NUMBER
3372  equations_set_setup_info%FIELD=>independent_field
3373  !Finish equations set specific startup
3374  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
3375  ELSE
3376  CALL flagerror("Equations set independent independent field is not associated.",err,error,*999)
3377  ENDIF
3378  !Finalise the setup
3379  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
3380  !Finish independent creation
3381  equations_set%INDEPENDENT%INDEPENDENT_FINISHED=.true.
3382  ENDIF
3383  ELSE
3384  CALL flagerror("The equations set independent is not associated",err,error,*999)
3385  ENDIF
3386  ELSE
3387  CALL flagerror("Equations set is not associated",err,error,*999)
3388  ENDIF
3389 
3390  exits("EQUATIONS_SET_INDEPENDENT_CREATE_FINISH")
3391  RETURN
3392 999 errorsexits("EQUATIONS_SET_INDEPENDENT_CREATE_FINISH",err,error)
3393  RETURN 1
3394  END SUBROUTINE equations_set_independent_create_finish
3395 
3396  !
3397  !================================================================================================================================
3398  !
3399 
3401  SUBROUTINE equations_set_independent_create_start(EQUATIONS_SET,INDEPENDENT_FIELD_USER_NUMBER,INDEPENDENT_FIELD,ERR,ERROR,*)
3402 
3403  !Argument variables
3404  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3405  INTEGER(INTG), INTENT(IN) :: INDEPENDENT_FIELD_USER_NUMBER
3406  TYPE(field_type), POINTER :: INDEPENDENT_FIELD
3407  INTEGER(INTG), INTENT(OUT) :: ERR
3408  TYPE(varying_string), INTENT(OUT) :: ERROR
3409  !Local Variables
3410  INTEGER(INTG) :: DUMMY_ERR
3411  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
3412  TYPE(field_type), POINTER :: FIELD,GEOMETRIC_FIELD
3413  TYPE(region_type), POINTER :: REGION,INDEPENDENT_FIELD_REGION
3414  TYPE(varying_string) :: DUMMY_ERROR,LOCAL_ERROR
3415 
3416  enters("EQUATIONS_SET_INDEPENDENT_CREATE_START",err,error,*998)
3417 
3418  IF(ASSOCIATED(equations_set)) THEN
3419  IF(ASSOCIATED(equations_set%INDEPENDENT)) THEN
3420  CALL flagerror("The equations set independent is already associated",err,error,*998)
3421  ELSE
3422  region=>equations_set%REGION
3423  IF(ASSOCIATED(region)) THEN
3424  IF(ASSOCIATED(independent_field)) THEN
3425  !Check the independent field has been finished
3426  IF(independent_field%FIELD_FINISHED) THEN
3427  !Check the user numbers match
3428  IF(independent_field_user_number/=independent_field%USER_NUMBER) THEN
3429  local_error="The specified independent field user number of "// &
3430  & trim(number_to_vstring(independent_field_user_number,"*",err,error))// &
3431  & " does not match the user number of the specified independent field of "// &
3432  & trim(number_to_vstring(independent_field%USER_NUMBER,"*",err,error))//"."
3433  CALL flagerror(local_error,err,error,*999)
3434  ENDIF
3435  independent_field_region=>independent_field%REGION
3436  IF(ASSOCIATED(independent_field_region)) THEN
3437  !Check the field is defined on the same region as the equations set
3438  IF(independent_field_region%USER_NUMBER/=region%USER_NUMBER) THEN
3439  local_error="Invalid region setup. The specified independent field has been created on region number "// &
3440  & trim(number_to_vstring(independent_field_region%USER_NUMBER,"*",err,error))// &
3441  & " and the specified equations set has been created on region number "// &
3442  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
3443  CALL flagerror(local_error,err,error,*999)
3444  ENDIF
3445  !Check the specified independent field has the same decomposition as the geometric field
3446  geometric_field=>equations_set%GEOMETRY%GEOMETRIC_FIELD
3447  IF(ASSOCIATED(geometric_field)) THEN
3448  IF(.NOT.ASSOCIATED(geometric_field%DECOMPOSITION,independent_field%DECOMPOSITION)) THEN
3449  CALL flagerror("The specified independent field does not have the same decomposition as the geometric "// &
3450  & "field for the specified equations set.",err,error,*999)
3451  ENDIF
3452  ELSE
3453  CALL flagerror("The geometric field is not associated for the specified equations set.",err,error,*999)
3454  ENDIF
3455  ELSE
3456  CALL flagerror("The specified independent field region is not associated.",err,error,*999)
3457  ENDIF
3458  ELSE
3459  CALL flagerror("The specified independent field has not been finished.",err,error,*999)
3460  ENDIF
3461  ELSE
3462  !Check the user number has not already been used for a field in this region.
3463  NULLIFY(field)
3464  CALL field_user_number_find(independent_field_user_number,region,field,err,error,*999)
3465  IF(ASSOCIATED(field)) THEN
3466  local_error="The specified independent field user number of "// &
3467  & trim(number_to_vstring(independent_field_user_number,"*",err,error))// &
3468  & "has already been used to create a field on region number "// &
3469  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
3470  CALL flagerror(local_error,err,error,*999)
3471  ENDIF
3472  ENDIF
3473  !Initialise the equations set independent
3474  CALL equations_set_independent_initialise(equations_set,err,error,*999)
3475  IF(.NOT.ASSOCIATED(independent_field)) equations_set%INDEPENDENT%INDEPENDENT_FIELD_AUTO_CREATED=.true.
3476  !Initialise the setup
3477  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
3478  equations_set_setup_info%SETUP_TYPE=equations_set_setup_independent_type
3479  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
3480  equations_set_setup_info%FIELD_USER_NUMBER=independent_field_user_number
3481  equations_set_setup_info%FIELD=>independent_field
3482  !Start equations set specific startup
3483  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
3484  !Finalise the setup
3485  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
3486  !Set pointers
3487  IF(equations_set%INDEPENDENT%INDEPENDENT_FIELD_AUTO_CREATED) THEN
3488  independent_field=>equations_set%INDEPENDENT%INDEPENDENT_FIELD
3489  ELSE
3490  equations_set%INDEPENDENT%INDEPENDENT_FIELD=>independent_field
3491  ENDIF
3492  ELSE
3493  CALL flagerror("Equation set region is not associated.",err,error,*999)
3494  ENDIF
3495  ENDIF
3496  ELSE
3497  CALL flagerror("Equations set is not associated",err,error,*998)
3498  ENDIF
3499 
3500  exits("EQUATIONS_SET_INDEPENDENT_CREATE_START")
3501  RETURN
3502 999 CALL equations_set_independent_finalise(equations_set%INDEPENDENT,dummy_err,dummy_error,*998)
3503 998 errorsexits("EQUATIONS_SET_INDEPENDENT_CREATE_START",err,error)
3504  RETURN 1
3505  END SUBROUTINE equations_set_independent_create_start
3506 
3507  !
3508  !================================================================================================================================
3509  !
3510 
3512  SUBROUTINE equations_set_independent_destroy(EQUATIONS_SET,ERR,ERROR,*)
3513 
3514  !Argument variables
3515  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3516  INTEGER(INTG), INTENT(OUT) :: ERR
3517  TYPE(varying_string), INTENT(OUT) :: ERROR
3518  !Local Variables
3519 
3520  enters("EQUATIONS_SET_INDEPENDENT_DESTROY",err,error,*999)
3521 
3522  IF(ASSOCIATED(equations_set)) THEN
3523  IF(ASSOCIATED(equations_set%INDEPENDENT)) THEN
3524  CALL equations_set_independent_finalise(equations_set%INDEPENDENT,err,error,*999)
3525  ELSE
3526  CALL flagerror("Equations set indpendent is not associated.",err,error,*999)
3527  ENDIF
3528  ELSE
3529  CALL flagerror("Equations set is not associated.",err,error,*999)
3530  ENDIF
3531 
3532  exits("EQUATIONS_SET_INDEPENDENT_DESTROY")
3533  RETURN
3534 999 errorsexits("EQUATIONS_SET_INDEPENDENT_DESTROY",err,error)
3535  RETURN 1
3536  END SUBROUTINE equations_set_independent_destroy
3537 
3538  !
3539  !================================================================================================================================
3540  !
3541 
3543  SUBROUTINE equations_set_independent_finalise(EQUATIONS_SET_INDEPENDENT,ERR,ERROR,*)
3544 
3545  !Argument variables
3546  TYPE(equations_set_independent_type), POINTER :: EQUATIONS_SET_INDEPENDENT
3547  INTEGER(INTG), INTENT(OUT) :: ERR
3548  TYPE(varying_string), INTENT(OUT) :: ERROR
3549  !Local Variables
3550 
3551  enters("EQUATIONS_SET_INDEPENDENT_FINALISE",err,error,*999)
3552 
3553  IF(ASSOCIATED(equations_set_independent)) THEN
3554  DEALLOCATE(equations_set_independent)
3555  ENDIF
3556 
3557  exits("EQUATIONS_SET_INDEPENDENT_FINALISE")
3558  RETURN
3559 999 errorsexits("EQUATIONS_SET_INDEPENDENT_FINALISE",err,error)
3560  RETURN 1
3561  END SUBROUTINE equations_set_independent_finalise
3562 
3563  !
3564  !================================================================================================================================
3565  !
3566 
3568  SUBROUTINE equations_set_independent_initialise(EQUATIONS_SET,ERR,ERROR,*)
3569 
3570  !Argument variables
3571  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3572  INTEGER(INTG), INTENT(OUT) :: ERR
3573  TYPE(varying_string), INTENT(OUT) :: ERROR
3574  !Local Variables
3575  INTEGER(INTG) :: DUMMY_ERR
3576  TYPE(varying_string) :: DUMMY_ERROR
3577 
3578  enters("EQUATIONS_SET_INDEPENDENT_INITIALISE",err,error,*998)
3579 
3580  IF(ASSOCIATED(equations_set)) THEN
3581  IF(ASSOCIATED(equations_set%INDEPENDENT)) THEN
3582  CALL flagerror("Independent field is already associated for these equations sets.",err,error,*998)
3583  ELSE
3584  ALLOCATE(equations_set%INDEPENDENT,stat=err)
3585  IF(err/=0) CALL flagerror("Could not allocate equations set independent field.",err,error,*999)
3586  equations_set%INDEPENDENT%EQUATIONS_SET=>equations_set
3587  equations_set%INDEPENDENT%INDEPENDENT_FINISHED=.false.
3588  equations_set%INDEPENDENT%INDEPENDENT_FIELD_AUTO_CREATED=.false.
3589  NULLIFY(equations_set%INDEPENDENT%INDEPENDENT_FIELD)
3590  ENDIF
3591  ELSE
3592  CALL flagerror("Equations set is not associated.",err,error,*998)
3593  ENDIF
3594 
3595  exits("EQUATIONS_SET_INDEPENDENT_INITIALISE")
3596  RETURN
3597 999 CALL equations_set_independent_finalise(equations_set%INDEPENDENT,dummy_err,dummy_error,*998)
3598 998 errorsexits("EQUATIONS_SET_INDEPENDENT_INITIALISE",err,error)
3599  RETURN 1
3600  END SUBROUTINE equations_set_independent_initialise
3601 
3602  !
3603  !================================================================================================================================
3604  !
3605 
3607  SUBROUTINE equations_set_initialise(EQUATIONS_SET,ERR,ERROR,*)
3608 
3609  !Argument variables
3610  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3611  INTEGER(INTG), INTENT(OUT) :: ERR
3612  TYPE(varying_string), INTENT(OUT) :: ERROR
3613  !Local Variables
3614  INTEGER(INTG) :: DUMMY_ERR
3615  TYPE(varying_string) :: DUMMY_ERROR
3616 
3617  enters("EQUATIONS_SET_INITIALISE",err,error,*998)
3618 
3619  IF(ASSOCIATED(equations_set)) THEN
3620  CALL flagerror("Equations set is already associated.",err,error,*998)
3621  ELSE
3622  ALLOCATE(equations_set,stat=err)
3623  IF(err/=0) CALL flagerror("Could not allocate equations set.",err,error,*999)
3624  equations_set%USER_NUMBER=0
3625  equations_set%GLOBAL_NUMBER=0
3626  equations_set%EQUATIONS_SET_FINISHED=.false.
3627  NULLIFY(equations_set%EQUATIONS_SETS)
3628  NULLIFY(equations_set%REGION)
3629  equations_set%SOLUTION_METHOD=0
3630  CALL equations_set_geometry_initialise(equations_set,err,error,*999)
3631  CALL equations_set_dependent_initialise(equations_set,err,error,*999)
3632  CALL equationsset_equationssetfieldinitialise(equations_set,err,error,*999)
3633  NULLIFY(equations_set%INDEPENDENT)
3634  NULLIFY(equations_set%MATERIALS)
3635  NULLIFY(equations_set%SOURCE)
3636  NULLIFY(equations_set%ANALYTIC)
3637  NULLIFY(equations_set%derived)
3638  NULLIFY(equations_set%EQUATIONS)
3639  NULLIFY(equations_set%BOUNDARY_CONDITIONS)
3640  ENDIF
3641 
3642  exits("EQUATIONS_SET_INITIALISE")
3643  RETURN
3644 999 CALL equations_set_finalise(equations_set,dummy_err,dummy_error,*998)
3645 998 errorsexits("EQUATIONS_SET_INITIALISE",err,error)
3646  RETURN 1
3647  END SUBROUTINE equations_set_initialise
3648 
3649  !
3650  !================================================================================================================================
3651  !
3652 
3654  SUBROUTINE equations_set_geometry_finalise(EQUATIONS_SET_GEOMETRY,ERR,ERROR,*)
3655 
3656  !Argument variables
3657  TYPE(equations_set_geometry_type) :: EQUATIONS_SET_GEOMETRY
3658  INTEGER(INTG), INTENT(OUT) :: ERR
3659  TYPE(varying_string), INTENT(OUT) :: ERROR
3660  !Local Variables
3661 
3662  enters("EQUATIONS_SET_GEOMETRY_FINALISE",err,error,*999)
3663 
3664  NULLIFY(equations_set_geometry%GEOMETRIC_FIELD)
3665  NULLIFY(equations_set_geometry%FIBRE_FIELD)
3666 
3667  exits("EQUATIONS_SET_GEOMETRY_FINALISE")
3668  RETURN
3669 999 errorsexits("EQUATIONS_SET_GEOMETRY_FINALISE",err,error)
3670  RETURN 1
3671  END SUBROUTINE equations_set_geometry_finalise
3672 
3673  !
3674  !================================================================================================================================
3675  !
3676 
3678  SUBROUTINE equations_set_geometry_initialise(EQUATIONS_SET,ERR,ERROR,*)
3679 
3680  !Argument variables
3681  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3682  INTEGER(INTG), INTENT(OUT) :: ERR
3683  TYPE(varying_string), INTENT(OUT) :: ERROR
3684  !Local Variables
3685 
3686  enters("EQUATIONS_SET_GEOMETRY_INITIALISE",err,error,*999)
3687 
3688  IF(ASSOCIATED(equations_set)) THEN
3689  equations_set%GEOMETRY%EQUATIONS_SET=>equations_set
3690  NULLIFY(equations_set%GEOMETRY%GEOMETRIC_FIELD)
3691  NULLIFY(equations_set%GEOMETRY%FIBRE_FIELD)
3692  ELSE
3693  CALL flagerror("Equations set is not associated.",err,error,*999)
3694  ENDIF
3695 
3696  exits("EQUATIONS_SET_GEOMETRY_INITIALISE")
3697  RETURN
3698 999 errorsexits("EQUATIONS_SET_GEOMETRY_INITIALISE",err,error)
3699  RETURN 1
3700  END SUBROUTINE equations_set_geometry_initialise
3701 
3702  !
3703  !================================================================================================================================
3704  !
3705 
3707  SUBROUTINE equations_set_materials_create_finish(EQUATIONS_SET,ERR,ERROR,*)
3708 
3709  !Argument variables
3710  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3711  INTEGER(INTG), INTENT(OUT) :: ERR
3712  TYPE(varying_string), INTENT(OUT) :: ERROR
3713  !Local Variables
3714  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
3715  TYPE(field_type), POINTER :: MATERIALS_FIELD
3716 
3717  enters("EQUATIONS_SET_MATERIALS_CREATE_FINISH",err,error,*999)
3718 
3719  IF(ASSOCIATED(equations_set)) THEN
3720  IF(ASSOCIATED(equations_set%MATERIALS)) THEN
3721  IF(equations_set%MATERIALS%MATERIALS_FINISHED) THEN
3722  CALL flagerror("Equations set materials has already been finished.",err,error,*999)
3723  ELSE
3724  !Initialise the setup
3725  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
3726  equations_set_setup_info%SETUP_TYPE=equations_set_setup_materials_type
3727  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
3728  materials_field=>equations_set%MATERIALS%MATERIALS_FIELD
3729  IF(ASSOCIATED(materials_field)) THEN
3730  equations_set_setup_info%FIELD_USER_NUMBER=materials_field%USER_NUMBER
3731  equations_set_setup_info%FIELD=>materials_field
3732  !Finish equations set specific startup
3733  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
3734  ELSE
3735  CALL flagerror("Equations set materials materials field is not associated.",err,error,*999)
3736  ENDIF
3737  !Finalise the setup
3738  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
3739  !Finish materials creation
3740  equations_set%MATERIALS%MATERIALS_FINISHED=.true.
3741  ENDIF
3742  ELSE
3743  CALL flagerror("The equations set materials is not associated",err,error,*999)
3744  ENDIF
3745  ELSE
3746  CALL flagerror("Equations set is not associated",err,error,*999)
3747  ENDIF
3748 
3749  exits("EQUATIONS_SET_MATERIALS_CREATE_FINISH")
3750  RETURN
3751 999 errorsexits("EQUATIONS_SET_MATERIALS_CREATE_FINISH",err,error)
3752  RETURN 1
3753  END SUBROUTINE equations_set_materials_create_finish
3754 
3755  !
3756  !================================================================================================================================
3757  !
3758 
3760  SUBROUTINE equations_set_materials_create_start(EQUATIONS_SET,MATERIALS_FIELD_USER_NUMBER,MATERIALS_FIELD,ERR,ERROR,*)
3761 
3762  !Argument variables
3763  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3764  INTEGER(INTG), INTENT(IN) :: MATERIALS_FIELD_USER_NUMBER
3765  TYPE(field_type), POINTER :: MATERIALS_FIELD
3766  INTEGER(INTG), INTENT(OUT) :: ERR
3767  TYPE(varying_string), INTENT(OUT) :: ERROR
3768  !Local Variables
3769  INTEGER(INTG) :: DUMMY_ERR
3770  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
3771  TYPE(field_type), POINTER :: FIELD,GEOMETRIC_FIELD
3772  TYPE(region_type), POINTER :: REGION,MATERIALS_FIELD_REGION
3773  TYPE(varying_string) :: DUMMY_ERROR,LOCAL_ERROR
3774 
3775  enters("EQUATIONS_SET_MATERIALS_CREATE_START",err,error,*998)
3776 
3777  IF(ASSOCIATED(equations_set)) THEN
3778  IF(ASSOCIATED(equations_set%MATERIALS)) THEN
3779  CALL flagerror("The equations set materials is already associated",err,error,*998)
3780  ELSE
3781  region=>equations_set%REGION
3782  IF(ASSOCIATED(region)) THEN
3783  IF(ASSOCIATED(materials_field)) THEN
3784  !Check the materials field has been finished
3785  IF(materials_field%FIELD_FINISHED) THEN
3786  !Check the user numbers match
3787  IF(materials_field_user_number/=materials_field%USER_NUMBER) THEN
3788  local_error="The specified materials field user number of "// &
3789  & trim(number_to_vstring(materials_field_user_number,"*",err,error))// &
3790  & " does not match the user number of the specified materials field of "// &
3791  & trim(number_to_vstring(materials_field%USER_NUMBER,"*",err,error))//"."
3792  CALL flagerror(local_error,err,error,*999)
3793  ENDIF
3794  materials_field_region=>materials_field%REGION
3795  IF(ASSOCIATED(materials_field_region)) THEN
3796  !Check the field is defined on the same region as the equations set
3797  IF(materials_field_region%USER_NUMBER/=region%USER_NUMBER) THEN
3798  local_error="Invalid region setup. The specified materials field has been created on region number "// &
3799  & trim(number_to_vstring(materials_field_region%USER_NUMBER,"*",err,error))// &
3800  & " and the specified equations set has been created on region number "// &
3801  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
3802  CALL flagerror(local_error,err,error,*999)
3803  ENDIF
3804  !Check the specified materials field has the same decomposition as the geometric field
3805  geometric_field=>equations_set%GEOMETRY%GEOMETRIC_FIELD
3806  IF(ASSOCIATED(geometric_field)) THEN
3807  IF(.NOT.ASSOCIATED(geometric_field%DECOMPOSITION,materials_field%DECOMPOSITION)) THEN
3808  CALL flagerror("The specified materials field does not have the same decomposition as the geometric "// &
3809  & "field for the specified equations set.",err,error,*999)
3810  ENDIF
3811  ELSE
3812  CALL flagerror("The geometric field is not associated for the specified equations set.",err,error,*999)
3813  ENDIF
3814  ELSE
3815  CALL flagerror("The specified materials field region is not associated.",err,error,*999)
3816  ENDIF
3817  ELSE
3818  CALL flagerror("The specified materials field has not been finished.",err,error,*999)
3819  ENDIF
3820  ELSE
3821  !Check the user number has not already been used for a field in this region.
3822  NULLIFY(field)
3823  CALL field_user_number_find(materials_field_user_number,region,field,err,error,*999)
3824  IF(ASSOCIATED(field)) THEN
3825  local_error="The specified materials field user number of "// &
3826  & trim(number_to_vstring(materials_field_user_number,"*",err,error))// &
3827  & "has already been used to create a field on region number "// &
3828  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
3829  CALL flagerror(local_error,err,error,*999)
3830  ENDIF
3831  ENDIF
3832  !Initialise the equations set materials
3833  CALL equations_set_materials_initialise(equations_set,err,error,*999)
3834  IF(.NOT.ASSOCIATED(materials_field)) equations_set%MATERIALS%MATERIALS_FIELD_AUTO_CREATED=.true.
3835  !Initialise the setup
3836  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
3837  equations_set_setup_info%SETUP_TYPE=equations_set_setup_materials_type
3838  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
3839  equations_set_setup_info%FIELD_USER_NUMBER=materials_field_user_number
3840  equations_set_setup_info%FIELD=>materials_field
3841  !Start equations set specific startup
3842  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
3843  !Finalise the setup
3844  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
3845  !Set pointers
3846  IF(equations_set%MATERIALS%MATERIALS_FIELD_AUTO_CREATED) THEN
3847  materials_field=>equations_set%MATERIALS%MATERIALS_FIELD
3848  ELSE
3849  equations_set%MATERIALS%MATERIALS_FIELD=>materials_field
3850  ENDIF
3851  ELSE
3852  CALL flagerror("Equation set region is not associated.",err,error,*999)
3853  ENDIF
3854  ENDIF
3855  ELSE
3856  CALL flagerror("Equations set is not associated",err,error,*998)
3857  ENDIF
3858 
3859  exits("EQUATIONS_SET_MATERIALS_CREATE_START")
3860  RETURN
3861 999 CALL equations_set_materials_finalise(equations_set%MATERIALS,dummy_err,dummy_error,*998)
3862 998 errorsexits("EQUATIONS_SET_MATERIALS_CREATE_START",err,error)
3863  RETURN 1
3864  END SUBROUTINE equations_set_materials_create_start
3865 
3866  !
3867  !================================================================================================================================
3868  !
3869 
3871  SUBROUTINE equations_set_materials_destroy(EQUATIONS_SET,ERR,ERROR,*)
3872 
3873  !Argument variables
3874  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3875  INTEGER(INTG), INTENT(OUT) :: ERR
3876  TYPE(varying_string), INTENT(OUT) :: ERROR
3877  !Local Variables
3878 
3879  enters("EQUATIONS_SET_MATERIALS_DESTROY",err,error,*999)
3880 
3881  IF(ASSOCIATED(equations_set)) THEN
3882  IF(ASSOCIATED(equations_set%MATERIALS)) THEN
3883  CALL equations_set_materials_finalise(equations_set%MATERIALS,err,error,*999)
3884  ELSE
3885  CALL flagerror("Equations set materials is not associated.",err,error,*999)
3886  ENDIF
3887  ELSE
3888  CALL flagerror("Equations set is not associated.",err,error,*999)
3889  ENDIF
3890 
3891  exits("EQUATIONS_SET_MATERIALS_DESTROY")
3892  RETURN
3893 999 errorsexits("EQUATIONS_SET_MATERIALS_DESTROY",err,error)
3894  RETURN 1
3895  END SUBROUTINE equations_set_materials_destroy
3896 
3897  !
3898  !================================================================================================================================
3899  !
3900 
3902  SUBROUTINE equations_set_materials_finalise(EQUATIONS_SET_MATERIALS,ERR,ERROR,*)
3903 
3904  !Argument variables
3905  TYPE(equations_set_materials_type), POINTER :: EQUATIONS_SET_MATERIALS
3906  INTEGER(INTG), INTENT(OUT) :: ERR
3907  TYPE(varying_string), INTENT(OUT) :: ERROR
3908  !Local Variables
3909 
3910  enters("EQUATIONS_SET_MATERIALS_FINALISE",err,error,*999)
3911 
3912  IF(ASSOCIATED(equations_set_materials)) THEN
3913  DEALLOCATE(equations_set_materials)
3914  ENDIF
3915 
3916  exits("EQUATIONS_SET_MATERIALS_FINALISE")
3917  RETURN
3918 999 errorsexits("EQUATIONS_SET_MATERIALS_FINALISE",err,error)
3919  RETURN 1
3920  END SUBROUTINE equations_set_materials_finalise
3921 
3922  !
3923  !================================================================================================================================
3924  !
3925 
3927  SUBROUTINE equations_set_materials_initialise(EQUATIONS_SET,ERR,ERROR,*)
3928 
3929  !Argument variables
3930  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3931  INTEGER(INTG), INTENT(OUT) :: ERR
3932  TYPE(varying_string), INTENT(OUT) :: ERROR
3933  !Local Variables
3934  INTEGER(INTG) :: DUMMY_ERR
3935  TYPE(varying_string) :: DUMMY_ERROR
3936 
3937  enters("EQUATIONS_SET_MATERIALS_INITIALISE",err,error,*998)
3938 
3939  IF(ASSOCIATED(equations_set)) THEN
3940  IF(ASSOCIATED(equations_set%MATERIALS)) THEN
3941  CALL flagerror("Materials is already associated for these equations sets.",err,error,*998)
3942  ELSE
3943  ALLOCATE(equations_set%MATERIALS,stat=err)
3944  IF(err/=0) CALL flagerror("Could not allocate equations set materials.",err,error,*999)
3945  equations_set%MATERIALS%EQUATIONS_SET=>equations_set
3946  equations_set%MATERIALS%MATERIALS_FINISHED=.false.
3947  equations_set%MATERIALS%MATERIALS_FIELD_AUTO_CREATED=.false.
3948  NULLIFY(equations_set%MATERIALS%MATERIALS_FIELD)
3949  ENDIF
3950  ELSE
3951  CALL flagerror("Equations set is not associated",err,error,*998)
3952  ENDIF
3953 
3954  exits("EQUATIONS_SET_MATERIALS_INITIALISE")
3955  RETURN
3956 999 CALL equations_set_materials_finalise(equations_set%MATERIALS,dummy_err,dummy_error,*998)
3957 998 errorsexits("EQUATIONS_SET_MATERIALS_INITIALISE",err,error)
3958  RETURN 1
3959  END SUBROUTINE equations_set_materials_initialise
3960 
3961  !
3962  !
3963  !================================================================================================================================
3964  !
3965 
3967  SUBROUTINE equations_set_dependent_create_finish(EQUATIONS_SET,ERR,ERROR,*)
3968 
3969  !Argument variables
3970  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3971  INTEGER(INTG), INTENT(OUT) :: ERR
3972  TYPE(varying_string), INTENT(OUT) :: ERROR
3973  !Local Variables
3974  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
3975  TYPE(field_type), POINTER :: DEPENDENT_FIELD
3976 
3977  enters("EQUATIONS_SET_DEPENDENT_CREATE_FINISH",err,error,*999)
3978 
3979  IF(ASSOCIATED(equations_set)) THEN
3980  IF(equations_set%DEPENDENT%DEPENDENT_FINISHED) THEN
3981  CALL flagerror("Equations set dependent has already been finished",err,error,*999)
3982  ELSE
3983  !Initialise the setup
3984  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
3985  equations_set_setup_info%SETUP_TYPE=equations_set_setup_dependent_type
3986  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
3987  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
3988  IF(ASSOCIATED(dependent_field)) THEN
3989  equations_set_setup_info%FIELD_USER_NUMBER=dependent_field%USER_NUMBER
3990  equations_set_setup_info%FIELD=>dependent_field
3991  !Finish equations set specific setup
3992  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
3993  ELSE
3994  CALL flagerror("Equations set dependent dependent field is not associated.",err,error,*999)
3995  ENDIF
3996  !Finalise the setup
3997  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
3998  !Finish the equations set creation
3999  equations_set%DEPENDENT%DEPENDENT_FINISHED=.true.
4000  ENDIF
4001  ELSE
4002  CALL flagerror("Equations set is not associated",err,error,*999)
4003  ENDIF
4004 
4005  exits("EQUATIONS_SET_DEPENDENT_CREATE_FINISH")
4006  RETURN
4007 999 errorsexits("EQUATIONS_SET_DEPENDENT_CREATE_FINISH",err,error)
4008  RETURN 1
4009  END SUBROUTINE equations_set_dependent_create_finish
4010 
4011  !
4012  !================================================================================================================================
4013  !
4014 
4016  SUBROUTINE equations_set_dependent_create_start(EQUATIONS_SET,DEPENDENT_FIELD_USER_NUMBER,DEPENDENT_FIELD,ERR,ERROR,*)
4017 
4018  !Argument variables
4019  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4020  INTEGER(INTG), INTENT(IN) :: DEPENDENT_FIELD_USER_NUMBER
4021  TYPE(field_type), POINTER :: DEPENDENT_FIELD
4022  INTEGER(INTG), INTENT(OUT) :: ERR
4023  TYPE(varying_string), INTENT(OUT) :: ERROR
4024  !Local Variables
4025  INTEGER(INTG) :: DUMMY_ERR
4026  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
4027  TYPE(field_type), POINTER :: FIELD,GEOMETRIC_FIELD
4028  TYPE(region_type), POINTER :: REGION,DEPENDENT_FIELD_REGION
4029  TYPE(varying_string) :: DUMMY_ERROR,LOCAL_ERROR
4030 
4031  enters("EQUATIONS_SET_DEPENDENT_CREATE_START",err,error,*998)
4032 
4033  IF(ASSOCIATED(equations_set)) THEN
4034  IF(equations_set%DEPENDENT%DEPENDENT_FINISHED) THEN
4035  CALL flagerror("The equations set dependent has been finished.",err,error,*999)
4036  ELSE
4037  region=>equations_set%REGION
4038  IF(ASSOCIATED(region)) THEN
4039  IF(ASSOCIATED(dependent_field)) THEN
4040  !Check the dependent field has been finished
4041  IF(dependent_field%FIELD_FINISHED) THEN
4042  !Check the user numbers match
4043  IF(dependent_field_user_number/=dependent_field%USER_NUMBER) THEN
4044  local_error="The specified dependent field user number of "// &
4045  & trim(number_to_vstring(dependent_field_user_number,"*",err,error))// &
4046  & " does not match the user number of the specified dependent field of "// &
4047  & trim(number_to_vstring(dependent_field%USER_NUMBER,"*",err,error))//"."
4048  CALL flagerror(local_error,err,error,*999)
4049  ENDIF
4050  dependent_field_region=>dependent_field%REGION
4051  IF(ASSOCIATED(dependent_field_region)) THEN
4052  !Check the field is defined on the same region as the equations set
4053  IF(dependent_field_region%USER_NUMBER/=region%USER_NUMBER) THEN
4054  local_error="Invalid region setup. The specified dependent field has been created on region number "// &
4055  & trim(number_to_vstring(dependent_field_region%USER_NUMBER,"*",err,error))// &
4056  & " and the specified equations set has been created on region number "// &
4057  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
4058  CALL flagerror(local_error,err,error,*999)
4059  ENDIF
4060  !Check the specified dependent field has the same decomposition as the geometric field
4061  geometric_field=>equations_set%GEOMETRY%GEOMETRIC_FIELD
4062  IF(ASSOCIATED(geometric_field)) THEN
4063  IF(.NOT.ASSOCIATED(geometric_field%DECOMPOSITION,dependent_field%DECOMPOSITION)) THEN
4064  CALL flagerror("The specified dependent field does not have the same decomposition as the geometric "// &
4065  & "field for the specified equations set.",err,error,*999)
4066  ENDIF
4067  ELSE
4068  CALL flagerror("The geometric field is not associated for the specified equations set.",err,error,*999)
4069  ENDIF
4070  ELSE
4071  CALL flagerror("The specified dependent field region is not associated.",err,error,*999)
4072  ENDIF
4073  ELSE
4074  CALL flagerror("The specified dependent field has not been finished.",err,error,*999)
4075  ENDIF
4076  ELSE
4077  !Check the user number has not already been used for a field in this region.
4078  NULLIFY(field)
4079  CALL field_user_number_find(dependent_field_user_number,region,field,err,error,*999)
4080  IF(ASSOCIATED(field)) THEN
4081  local_error="The specified dependent field user number of "// &
4082  & trim(number_to_vstring(dependent_field_user_number,"*",err,error))// &
4083  & " has already been used to create a field on region number "// &
4084  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
4085  CALL flagerror(local_error,err,error,*999)
4086  ENDIF
4087  equations_set%DEPENDENT%DEPENDENT_FIELD_AUTO_CREATED=.true.
4088  ENDIF
4089  !Initialise the setup
4090  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
4091  equations_set_setup_info%SETUP_TYPE=equations_set_setup_dependent_type
4092  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
4093  equations_set_setup_info%FIELD_USER_NUMBER=dependent_field_user_number
4094  equations_set_setup_info%FIELD=>dependent_field
4095  !Start the equations set specfic solution setup
4096  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4097  !Finalise the setup
4098  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
4099  !Set pointers
4100  IF(equations_set%DEPENDENT%DEPENDENT_FIELD_AUTO_CREATED) THEN
4101  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
4102  ELSE
4103  equations_set%DEPENDENT%DEPENDENT_FIELD=>dependent_field
4104  ENDIF
4105  ELSE
4106  CALL flagerror("Equation set region is not associated.",err,error,*999)
4107  ENDIF
4108  ENDIF
4109  ELSE
4110  CALL flagerror("Equations_set is not associated.",err,error,*998)
4111  ENDIF
4112 
4113  exits("EQUATIONS_SET_DEPENDENT_CREATE_START")
4114  RETURN
4115 999 CALL equations_set_dependent_finalise(equations_set%DEPENDENT,dummy_err,dummy_error,*998)
4116 998 errorsexits("EQUATIONS_SET_DEPENDENT_CREATE_START",err,error)
4117  RETURN 1
4118  END SUBROUTINE equations_set_dependent_create_start
4119 
4120  !
4121  !================================================================================================================================
4122  !
4123 
4125  SUBROUTINE equations_set_dependent_destroy(EQUATIONS_SET,ERR,ERROR,*)
4126 
4127  !Argument variables
4128  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4129  INTEGER(INTG), INTENT(OUT) :: ERR
4130  TYPE(varying_string), INTENT(OUT) :: ERROR
4131  !Local Variables
4132 
4133  enters("EQUATIONS_SET_DEPENDENT_DESTROY",err,error,*999)
4134 
4135  IF(ASSOCIATED(equations_set)) THEN
4136  CALL equations_set_dependent_finalise(equations_set%DEPENDENT,err,error,*999)
4137  ELSE
4138  CALL flagerror("Equations set is not associated",err,error,*999)
4139  ENDIF
4140 
4141  exits("EQUATIONS_SET_DEPENDENT_DESTROY")
4142  RETURN
4143 999 errorsexits("EQUATIONS_SET_DEPENDENT_DESTROY",err,error)
4144  RETURN 1
4145  END SUBROUTINE equations_set_dependent_destroy
4146 
4147  !
4148  !================================================================================================================================
4149  !
4150 
4152  SUBROUTINE equations_set_dependent_finalise(EQUATIONS_SET_DEPENDENT,ERR,ERROR,*)
4153 
4154  !Argument variables
4155  TYPE(equations_set_dependent_type) :: EQUATIONS_SET_DEPENDENT
4156  INTEGER(INTG), INTENT(OUT) :: ERR
4157  TYPE(varying_string), INTENT(OUT) :: ERROR
4158  !Local Variables
4159 
4160  enters("EQUATIONS_SET_DEPENDENT_FINALISE",err,error,*999)
4161 
4162  NULLIFY(equations_set_dependent%EQUATIONS_SET)
4163  equations_set_dependent%DEPENDENT_FINISHED=.false.
4164  equations_set_dependent%DEPENDENT_FIELD_AUTO_CREATED=.false.
4165  NULLIFY(equations_set_dependent%DEPENDENT_FIELD)
4166 
4167  exits("EQUATIONS_SET_DEPENDENT_FINALISE")
4168  RETURN
4169 999 errorsexits("EQUATIONS_SET_DEPENDENT_FINALISE",err,error)
4170  RETURN 1
4171  END SUBROUTINE equations_set_dependent_finalise
4172 
4173  !
4174  !================================================================================================================================
4175  !
4176 
4178  SUBROUTINE equations_set_dependent_initialise(EQUATIONS_SET,ERR,ERROR,*)
4179 
4180  !Argument variables
4181  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4182  INTEGER(INTG), INTENT(OUT) :: ERR
4183  TYPE(varying_string), INTENT(OUT) :: ERROR
4184  !Local Variables
4185 
4186  enters("EQUATIONS_SET_DEPENDENT_INITIALISE",err,error,*999)
4187 
4188  IF(ASSOCIATED(equations_set)) THEN
4189  equations_set%DEPENDENT%EQUATIONS_SET=>equations_set
4190  equations_set%DEPENDENT%DEPENDENT_FINISHED=.false.
4191  equations_set%DEPENDENT%DEPENDENT_FIELD_AUTO_CREATED=.false.
4192  NULLIFY(equations_set%DEPENDENT%DEPENDENT_FIELD)
4193  ELSE
4194  CALL flagerror("Equations set is not associated.",err,error,*999)
4195  ENDIF
4196 
4197  exits("EQUATIONS_SET_DEPENDENT_INITIALISE")
4198  RETURN
4199 999 errorsexits("EQUATIONS_SET_DEPENDENT_INITIALISE",err,error)
4200  RETURN 1
4201  END SUBROUTINE equations_set_dependent_initialise
4202 
4203  !
4204  !================================================================================================================================
4205  !
4206 
4208  SUBROUTINE equationsset_derivedcreatefinish(equationsSet,err,error,*)
4209 
4210  !Argument variables
4211  TYPE(equations_set_type), POINTER :: equationsSet
4212  INTEGER(INTG), INTENT(OUT) :: err
4213  TYPE(varying_string), INTENT(OUT) :: error
4214  !Local Variables
4215  TYPE(equations_set_setup_type) :: equationsSetSetupInfo
4216  TYPE(field_type), POINTER :: derivedField
4217 
4218  enters("EquationsSet_DerivedCreateFinish",err,error,*999)
4219 
4220  IF(ASSOCIATED(equationsset)) THEN
4221  IF(ASSOCIATED(equationsset%derived)) THEN
4222  IF(equationsset%derived%derivedFinished) THEN
4223  CALL flagerror("Equations set derived field information has already been finished",err,error,*999)
4224  ELSE
4225  !Initialise the setup
4226  CALL equations_set_setup_initialise(equationssetsetupinfo,err,error,*999)
4227  equationssetsetupinfo%SETUP_TYPE=equations_set_setup_derived_type
4228  equationssetsetupinfo%ACTION_TYPE=equations_set_setup_finish_action
4229  derivedfield=>equationsset%derived%derivedField
4230  IF(ASSOCIATED(derivedfield)) THEN
4231  equationssetsetupinfo%FIELD_USER_NUMBER=derivedfield%USER_NUMBER
4232  equationssetsetupinfo%field=>derivedfield
4233  !Finish equations set specific setup
4234  CALL equations_set_setup(equationsset,equationssetsetupinfo,err,error,*999)
4235  ELSE
4236  CALL flagerror("Equations set derived field is not associated.",err,error,*999)
4237  END IF
4238  !Finalise the setup
4239  CALL equations_set_setup_finalise(equationssetsetupinfo,err,error,*999)
4240  !Finish the equations set derived creation
4241  equationsset%derived%derivedFinished=.true.
4242  END IF
4243  ELSE
4244  CALL flagerror("Equations set derived is not associated",err,error,*999)
4245  END IF
4246  ELSE
4247  CALL flagerror("Equations set is not associated",err,error,*999)
4248  END IF
4249 
4250  exits("EquationsSet_DerivedCreateFinish")
4251  RETURN
4252 999 errorsexits("EquationsSet_DerivedCreateFinish",err,error)
4253  RETURN 1
4254  END SUBROUTINE equationsset_derivedcreatefinish
4255 
4256  !
4257  !================================================================================================================================
4258  !
4259 
4261  SUBROUTINE equationsset_derivedcreatestart(equationsSet,derivedFieldUserNumber,derivedField,err,error,*)
4262 
4263  !Argument variables
4264  TYPE(equations_set_type), POINTER :: equationsSet
4265  INTEGER(INTG), INTENT(IN) :: derivedFieldUserNumber
4266  TYPE(field_type), POINTER :: derivedField
4267  INTEGER(INTG), INTENT(OUT) :: err
4268  TYPE(varying_string), INTENT(OUT) :: error
4269  !Local Variables
4270  INTEGER(INTG) :: dummyErr
4271  TYPE(equations_set_setup_type) :: equationsSetSetupInfo
4272  TYPE(field_type), POINTER :: field,geometricField
4273  TYPE(region_type), POINTER :: region,derivedFieldRegion
4274  TYPE(varying_string) :: dummyError,localError
4275 
4276  enters("EquationsSet_DerivedCreateStart",err,error,*998)
4277 
4278  IF(ASSOCIATED(equationsset)) THEN
4279  IF(ASSOCIATED(equationsset%derived)) THEN
4280  CALL flagerror("Equations set derived is already associated.",err,error,*998)
4281  ELSE
4282  region=>equationsset%REGION
4283  IF(ASSOCIATED(region)) THEN
4284  IF(ASSOCIATED(derivedfield)) THEN
4285  !Check the derived field has been finished
4286  IF(derivedfield%FIELD_FINISHED) THEN
4287  !Check the user numbers match
4288  IF(derivedfieldusernumber/=derivedfield%USER_NUMBER) THEN
4289  localerror="The specified derived field user number of "// &
4290  & trim(number_to_vstring(derivedfieldusernumber,"*",err,error))// &
4291  & " does not match the user number of the specified derived field of "// &
4292  & trim(number_to_vstring(derivedfield%USER_NUMBER,"*",err,error))//"."
4293  CALL flagerror(localerror,err,error,*999)
4294  END IF
4295  derivedfieldregion=>derivedfield%REGION
4296  IF(ASSOCIATED(derivedfieldregion)) THEN
4297  !Check the field is defined on the same region as the equations set
4298  IF(derivedfieldregion%USER_NUMBER/=region%USER_NUMBER) THEN
4299  localerror="Invalid region setup. The specified derived field has been created on region number "// &
4300  & trim(number_to_vstring(derivedfieldregion%USER_NUMBER,"*",err,error))// &
4301  & " and the specified equations set has been created on region number "// &
4302  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
4303  CALL flagerror(localerror,err,error,*999)
4304  END IF
4305  !Check the specified derived field has the same decomposition as the geometric field
4306  geometricfield=>equationsset%GEOMETRY%GEOMETRIC_FIELD
4307  IF(ASSOCIATED(geometricfield)) THEN
4308  IF(.NOT.ASSOCIATED(geometricfield%DECOMPOSITION,derivedfield%DECOMPOSITION)) THEN
4309  CALL flagerror("The specified derived field does not have the same decomposition as the geometric "// &
4310  & "field for the specified equations set.",err,error,*999)
4311  END IF
4312  ELSE
4313  CALL flagerror("The geometric field is not associated for the specified equations set.",err,error,*999)
4314  END IF
4315  ELSE
4316  CALL flagerror("The specified derived field region is not associated.",err,error,*999)
4317  END IF
4318  ELSE
4319  CALL flagerror("The specified derived field has not been finished.",err,error,*999)
4320  END IF
4321  ELSE
4322  !Check the user number has not already been used for a field in this region.
4323  NULLIFY(field)
4324  CALL field_user_number_find(derivedfieldusernumber,region,field,err,error,*999)
4325  IF(ASSOCIATED(field)) THEN
4326  localerror="The specified derived field user number of "// &
4327  & trim(number_to_vstring(derivedfieldusernumber,"*",err,error))// &
4328  & " has already been used to create a field on region number "// &
4329  & trim(number_to_vstring(region%USER_NUMBER,"*",err,error))//"."
4330  CALL flagerror(localerror,err,error,*999)
4331  END IF
4332  equationsset%derived%derivedFieldAutoCreated=.true.
4333  END IF
4334  CALL equationsset_derivedinitialise(equationsset,err,error,*999)
4335  !Initialise the setup
4336  CALL equations_set_setup_initialise(equationssetsetupinfo,err,error,*999)
4337  equationssetsetupinfo%SETUP_TYPE=equations_set_setup_derived_type
4338  equationssetsetupinfo%ACTION_TYPE=equations_set_setup_start_action
4339  equationssetsetupinfo%FIELD_USER_NUMBER=derivedfieldusernumber
4340  equationssetsetupinfo%FIELD=>derivedfield
4341  !Start the equations set specfic solution setup
4342  CALL equations_set_setup(equationsset,equationssetsetupinfo,err,error,*999)
4343  !Finalise the setup
4344  CALL equations_set_setup_finalise(equationssetsetupinfo,err,error,*999)
4345  !Set pointers
4346  IF(.NOT.equationsset%derived%derivedFieldAutoCreated) THEN
4347  equationsset%derived%derivedField=>derivedfield
4348  END IF
4349  ELSE
4350  CALL flagerror("Equation set region is not associated.",err,error,*999)
4351  END IF
4352  END IF
4353  ELSE
4354  CALL flagerror("Equations set is not associated.",err,error,*998)
4355  END IF
4356 
4357  exits("EquationsSet_DerivedCreateStart")
4358  RETURN
4359 999 CALL equationsset_derivedfinalise(equationsset%derived,dummyerr,dummyerror,*998)
4360 998 errorsexits("EquationsSet_DerivedCreateStart",err,error)
4361  RETURN 1
4362  END SUBROUTINE equationsset_derivedcreatestart
4363 
4364  !
4365  !================================================================================================================================
4366  !
4367 
4369  SUBROUTINE equationsset_deriveddestroy(equationsSet,err,error,*)
4370 
4371  !Argument variables
4372  TYPE(equations_set_type), POINTER :: equationsSet
4373  INTEGER(INTG), INTENT(OUT) :: err
4374  TYPE(varying_string), INTENT(OUT) :: error
4375  !Local Variables
4376 
4377  enters("EquationsSet_DerivedDestroy",err,error,*999)
4378 
4379  IF(ASSOCIATED(equationsset)) THEN
4380  CALL equationsset_derivedfinalise(equationsset%derived,err,error,*999)
4381  ELSE
4382  CALL flagerror("Equations set is not associated",err,error,*999)
4383  END IF
4384 
4385  exits("EquationsSet_DerivedDestroy")
4386  RETURN
4387 999 errorsexits("EquationsSet_DerivedDestroy",err,error)
4388  RETURN 1
4389  END SUBROUTINE equationsset_deriveddestroy
4390 
4391  !
4392  !================================================================================================================================
4393  !
4394 
4396  SUBROUTINE equationsset_derivedfinalise(equationsSetDerived,err,error,*)
4397 
4398  !Argument variables
4399  TYPE(equationssetderivedtype), POINTER :: equationsSetDerived
4400  INTEGER(INTG), INTENT(OUT) :: err
4401  TYPE(varying_string), INTENT(OUT) :: error
4402 
4403  enters("EquationsSet_DerivedFinalise",err,error,*999)
4404 
4405  IF(ASSOCIATED(equationssetderived)) THEN
4406  IF(ALLOCATED(equationssetderived%variableTypes)) DEALLOCATE(equationssetderived%variableTypes)
4407  DEALLOCATE(equationssetderived)
4408  END IF
4409 
4410  exits("EquationsSet_DerivedFinalise")
4411  RETURN
4412 999 errorsexits("EquationsSet_DerivedFinalise",err,error)
4413  RETURN 1
4414  END SUBROUTINE equationsset_derivedfinalise
4415 
4416  !
4417  !================================================================================================================================
4418  !
4419 
4421  SUBROUTINE equationsset_derivedinitialise(equationsSet,err,error,*)
4422 
4423  !Argument variables
4424  TYPE(equations_set_type), POINTER :: equationsSet
4425  INTEGER(INTG), INTENT(OUT) :: err
4426  TYPE(varying_string), INTENT(OUT) :: error
4427 
4428  enters("EquationsSet_DerivedInitialise",err,error,*999)
4429 
4430  IF(ASSOCIATED(equationsset)) THEN
4431  IF(ASSOCIATED(equationsset%derived)) THEN
4432  CALL flagerror("Derived information is already associated for this equations set.",err,error,*998)
4433  ELSE
4434  ALLOCATE(equationsset%derived,stat=err)
4435  IF(err/=0) CALL flagerror("Could not allocate equations set derived information.",err,error,*998)
4436  ALLOCATE(equationsset%derived%variableTypes(equations_set_number_of_derived_types),stat=err)
4437  IF(err/=0) CALL flagerror("Could not allocate equations set derived variable types.",err,error,*999)
4438  equationsset%derived%variableTypes=0
4439  equationsset%derived%numberOfVariables=0
4440  equationsset%derived%equationsSet=>equationsset
4441  equationsset%derived%derivedFinished=.false.
4442  equationsset%derived%derivedFieldAutoCreated=.false.
4443  NULLIFY(equationsset%derived%derivedField)
4444  END IF
4445  ELSE
4446  CALL flagerror("Equations set is not associated.",err,error,*999)
4447  END IF
4448 
4449  exits("EquationsSet_DerivedInitialise")
4450  RETURN
4451 999 CALL equationsset_derivedfinalise(equationsset%derived,err,error,*999)
4452 998 errorsexits("EquationsSet_DerivedInitialise",err,error)
4453  RETURN 1
4454  END SUBROUTINE equationsset_derivedinitialise
4455 
4456  !
4457  !================================================================================================================================
4458  !
4459 
4461  SUBROUTINE equations_set_equations_set_field_finalise(EQUATIONS_SET_FIELD,ERR,ERROR,*)
4462 
4463  !Argument variables
4464  TYPE(equations_set_equations_set_field_type) :: EQUATIONS_SET_FIELD
4465  INTEGER(INTG), INTENT(OUT) :: ERR
4466  TYPE(varying_string), INTENT(OUT) :: ERROR
4467  !Local Variables
4468 
4469  enters("EQUATIONS_SET_EQUATIONS_SET_FIELD_FINALISE",err,error,*999)
4470 
4471  NULLIFY(equations_set_field%EQUATIONS_SET)
4472  equations_set_field%EQUATIONS_SET_FIELD_FINISHED=.false.
4473  equations_set_field%EQUATIONS_SET_FIELD_AUTO_CREATED=.false.
4474  NULLIFY(equations_set_field%EQUATIONS_SET_FIELD_FIELD)
4475 
4476  exits("EQUATIONS_SET_EQUATIONS_SET_FIELD_FINALISE")
4477  RETURN
4478 999 errorsexits("EQUATIONS_SET_EQUATIONS_SET_FIELD_FINALISE",err,error)
4479  RETURN 1
4480  END SUBROUTINE equations_set_equations_set_field_finalise
4481 
4482  !
4483  !================================================================================================================================
4484  !
4486  SUBROUTINE equationsset_equationssetfieldinitialise(EQUATIONS_SET,ERR,ERROR,*)
4487 
4488  !Argument variables
4489  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4490  INTEGER(INTG), INTENT(OUT) :: ERR
4491  TYPE(varying_string), INTENT(OUT) :: ERROR
4492  !Local Variables
4493 
4494  enters("EquationsSet_EquationsSetFieldInitialise",err,error,*999)
4495 
4496  IF(ASSOCIATED(equations_set)) THEN
4497  equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET=>equations_set
4498  equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET_FIELD_FINISHED=.false.
4499  equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET_FIELD_AUTO_CREATED=.true.
4500  NULLIFY(equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET_FIELD_FIELD)
4501  ELSE
4502  CALL flagerror("Equations set is not associated.",err,error,*999)
4503  ENDIF
4504 
4505  exits("EquationsSet_EquationsSetFieldInitialise")
4506  RETURN
4507 999 errorsexits("EquationsSet_EquationsSetFieldInitialise",err,error)
4508  RETURN 1
4509 
4510  END SUBROUTINE equationsset_equationssetfieldinitialise
4511 
4512  !
4513  !================================================================================================================================
4514  !
4515 
4516 
4517 
4519  SUBROUTINE equations_set_setup(EQUATIONS_SET,EQUATIONS_SET_SETUP_INFO,ERR,ERROR,*)
4520 
4521  !Argument variables
4522  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4523  TYPE(equations_set_setup_type), INTENT(INOUT) :: EQUATIONS_SET_SETUP_INFO
4524  INTEGER(INTG), INTENT(OUT) :: ERR
4525  TYPE(varying_string), INTENT(OUT) :: ERROR
4526  !Local Variables
4527  TYPE(varying_string) :: LOCAL_ERROR
4528 
4529  enters("EQUATIONS_SET_SETUP",err,error,*999)
4530 
4531  IF(ASSOCIATED(equations_set)) THEN
4532  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
4533  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
4534  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
4535  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
4536  END IF
4537  SELECT CASE(equations_set%SPECIFICATION(1))
4538  CASE(equations_set_elasticity_class)
4539  CALL elasticity_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4540  CASE(equations_set_fluid_mechanics_class)
4541  CALL fluid_mechanics_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4542  CASE(equations_set_electromagnetics_class)
4543  CALL flagerror("Not implemented.",err,error,*999)
4544  CASE(equations_set_classical_field_class)
4545  CALL classical_field_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4546  CASE(equations_set_bioelectrics_class)
4547  IF(SIZE(equations_set%SPECIFICATION,1)<2) THEN
4548  CALL flagerror("Equations set specification must have at least two entries for a bioelectrics equation class.", &
4549  & err,error,*999)
4550  END IF
4551  IF(equations_set%SPECIFICATION(2) == equations_set_monodomain_strang_splitting_equation_type) THEN
4552  CALL monodomain_equation_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4553  ELSE
4554  CALL bioelectric_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4555  END IF
4556  CASE(equations_set_fitting_class)
4557  CALL fitting_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4558  CASE(equations_set_modal_class)
4559  CALL flagerror("Not implemented.",err,error,*999)
4560  CASE(equations_set_multi_physics_class)
4561  CALL multi_physics_equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4562  CASE DEFAULT
4563  local_error="The first equations set specification of "// &
4564  & trim(number_to_vstring(equations_set%SPECIFICATION(1),"*",err,error))//" is not valid."
4565  CALL flagerror(local_error,err,error,*999)
4566  END SELECT
4567  ELSE
4568  CALL flagerror("Equations set is not associated.",err,error,*999)
4569  ENDIF
4570 
4571  exits("EQUATIONS_SET_SETUP")
4572  RETURN
4573 999 errorsexits("EQUATIONS_SET_SETUP",err,error)
4574  RETURN 1
4575  END SUBROUTINE equations_set_setup
4576 
4577  !
4578  !================================================================================================================================
4579  !
4580 
4582  SUBROUTINE equations_set_equations_create_finish(EQUATIONS_SET,ERR,ERROR,*)
4583 
4584  !Argument variables
4585  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4586  INTEGER(INTG), INTENT(OUT) :: ERR
4587  TYPE(varying_string), INTENT(OUT) :: ERROR
4588  !Local Variables
4589  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
4590 
4591  enters("EQUATIONS_SET_EQUATIONS_CREATE_FINISH",err,error,*999)
4592 
4593  IF(ASSOCIATED(equations_set)) THEN
4594  !Initialise the setup
4595  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
4596  equations_set_setup_info%SETUP_TYPE=equations_set_setup_equations_type
4597  equations_set_setup_info%ACTION_TYPE=equations_set_setup_finish_action
4598  !Finish the equations specific solution setup.
4599  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4600  !Finalise the setup
4601  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
4602  ELSE
4603  CALL flagerror("Equations set is not associated.",err,error,*999)
4604  ENDIF
4605 
4606  exits("EQUATIONS_SET_EQUATIONS_CREATE_FINISH")
4607  RETURN
4608 999 errorsexits("EQUATIONS_SET_EQUATIONS_CREATE_FINISH",err,error)
4609  RETURN 1
4610  END SUBROUTINE equations_set_equations_create_finish
4611 
4612  !
4613  !================================================================================================================================
4614  !
4615 
4627  SUBROUTINE equations_set_equations_create_start(EQUATIONS_SET,EQUATIONS,ERR,ERROR,*)
4628 
4629  !Argument variables
4630  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4631  TYPE(equations_type), POINTER :: EQUATIONS
4632  INTEGER(INTG), INTENT(OUT) :: ERR
4633  TYPE(varying_string), INTENT(OUT) :: ERROR
4634  !Local Variables
4635  TYPE(equations_set_setup_type) :: EQUATIONS_SET_SETUP_INFO
4636 
4637  enters("EQUATIONS_SET_EQUATIONS_CREATE_START",err,error,*999)
4638 
4639  IF(ASSOCIATED(equations_set)) THEN
4640  IF(ASSOCIATED(equations)) THEN
4641  CALL flagerror("Equations is already associated.",err,error,*999)
4642  ELSE
4643  !Initialise the setup
4644  CALL equations_set_setup_initialise(equations_set_setup_info,err,error,*999)
4645  equations_set_setup_info%SETUP_TYPE=equations_set_setup_equations_type
4646  equations_set_setup_info%ACTION_TYPE=equations_set_setup_start_action
4647  !Start the equations set specific solution setup
4648  CALL equations_set_setup(equations_set,equations_set_setup_info,err,error,*999)
4649  !Finalise the setup
4650  CALL equations_set_setup_finalise(equations_set_setup_info,err,error,*999)
4651  !Return the pointer
4652  equations=>equations_set%EQUATIONS
4653  ENDIF
4654  ELSE
4655  CALL flagerror("Equations set is not associated.",err,error,*999)
4656  ENDIF
4657 
4658  exits("EQUATIONS_SET_EQUATIONS_CREATE_START")
4659  RETURN
4660 999 errorsexits("EQUATIONS_SET_EQUATIONS_CREATE_START",err,error)
4661  RETURN 1
4662  END SUBROUTINE equations_set_equations_create_start
4663 
4664  !
4665  !================================================================================================================================
4666  !
4667 
4669  SUBROUTINE equations_set_equations_destroy(EQUATIONS_SET,ERR,ERROR,*)
4670 
4671  !Argument variables
4672  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4673  INTEGER(INTG), INTENT(OUT) :: ERR
4674  TYPE(varying_string), INTENT(OUT) :: ERROR
4675  !Local Variables
4676 
4677  enters("EQUATIONS_SET_EQUATIONS_DESTROY",err,error,*999)
4678 
4679  IF(ASSOCIATED(equations_set)) THEN
4680  IF(ASSOCIATED(equations_set%EQUATIONS)) THEN
4681  CALL equations_finalise(equations_set%EQUATIONS,err,error,*999)
4682  ELSE
4683  CALL flagerror("Equations set equations is not associated.",err,error,*999)
4684  ENDIF
4685  ELSE
4686  CALL flagerror("Equations set is not associated.",err,error,*999)
4687  ENDIF
4688 
4689  exits("EQUATIONS_SET_EQUATIONS_DESTROY")
4690  RETURN
4691 999 errorsexits("EQUATIONS_SET_EQUATIONS_DESTROY",err,error)
4692  RETURN 1
4693  END SUBROUTINE equations_set_equations_destroy
4694 
4695  !
4696  !================================================================================================================================
4697  !
4698 
4700  SUBROUTINE equations_set_jacobian_evaluate(EQUATIONS_SET,ERR,ERROR,*)
4701 
4702  !Argument variables
4703  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4704  INTEGER(INTG), INTENT(OUT) :: ERR
4705  TYPE(varying_string), INTENT(OUT) :: ERROR
4706  !Local Variables
4707  TYPE(equations_type), POINTER :: EQUATIONS
4708  TYPE(varying_string) :: LOCAL_ERROR
4709 
4710  enters("EQUATIONS_SET_JACOBIAN_EVALUATE",err,error,*999)
4711 
4712  IF(ASSOCIATED(equations_set)) THEN
4713  equations=>equations_set%EQUATIONS
4714  IF(ASSOCIATED(equations)) THEN
4715  IF(equations%EQUATIONS_FINISHED) THEN
4716  SELECT CASE(equations%LINEARITY)
4717  CASE(equations_linear)
4718  SELECT CASE(equations%TIME_DEPENDENCE)
4719  CASE(equations_static)
4720  SELECT CASE(equations_set%SOLUTION_METHOD)
4721  CASE(equations_set_fem_solution_method)
4722  CALL equations_set_assemble_static_linear_fem(equations_set,err,error,*999)
4723  CASE(equations_set_bem_solution_method)
4724  CALL flagerror("Not implemented.",err,error,*999)
4725  CASE(equations_set_fd_solution_method)
4726  CALL flagerror("Not implemented.",err,error,*999)
4727  CASE(equations_set_fv_solution_method)
4728  CALL flagerror("Not implemented.",err,error,*999)
4729  CASE(equations_set_gfem_solution_method)
4730  CALL flagerror("Not implemented.",err,error,*999)
4731  CASE(equations_set_gfv_solution_method)
4732  CALL flagerror("Not implemented.",err,error,*999)
4733  CASE DEFAULT
4734  local_error="The equations set solution method of "// &
4735  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
4736  & " is invalid."
4737  CALL flagerror(local_error,err,error,*999)
4738  END SELECT
4739  CASE(equations_quasistatic)
4740  SELECT CASE(equations_set%SOLUTION_METHOD)
4741  CASE(equations_set_fem_solution_method)
4742  CALL equationsset_assemblequasistaticlinearfem(equations_set,err,error,*999)
4743  CASE(equations_set_bem_solution_method)
4744  CALL flagerror("Not implemented.",err,error,*999)
4745  CASE(equations_set_fd_solution_method)
4746  CALL flagerror("Not implemented.",err,error,*999)
4747  CASE(equations_set_fv_solution_method)
4748  CALL flagerror("Not implemented.",err,error,*999)
4749  CASE(equations_set_gfem_solution_method)
4750  CALL flagerror("Not implemented.",err,error,*999)
4751  CASE(equations_set_gfv_solution_method)
4752  CALL flagerror("Not implemented.",err,error,*999)
4753  CASE DEFAULT
4754  local_error="The equations set solution method of "// &
4755  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
4756  & " is invalid."
4757  CALL flagerror(local_error,err,error,*999)
4758  END SELECT
4759  CASE(equations_first_order_dynamic,equations_second_order_dynamic)
4760  SELECT CASE(equations_set%SOLUTION_METHOD)
4761  CASE(equations_set_fem_solution_method)
4762  CALL equations_set_assemble_dynamic_linear_fem(equations_set,err,error,*999)
4763  CASE(equations_set_bem_solution_method)
4764  CALL flagerror("Not implemented.",err,error,*999)
4765  CASE(equations_set_fd_solution_method)
4766  CALL flagerror("Not implemented.",err,error,*999)
4767  CASE(equations_set_fv_solution_method)
4768  CALL flagerror("Not implemented.",err,error,*999)
4769  CASE(equations_set_gfem_solution_method)
4770  CALL flagerror("Not implemented.",err,error,*999)
4771  CASE(equations_set_gfv_solution_method)
4772  CALL flagerror("Not implemented.",err,error,*999)
4773  CASE DEFAULT
4774  local_error="The equations set solution method of "// &
4775  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
4776  & " is invalid."
4777  CALL flagerror(local_error,err,error,*999)
4778  END SELECT
4779  CASE DEFAULT
4780  local_error="The equations time dependence type of "// &
4781  & trim(number_to_vstring(equations%TIME_DEPENDENCE,"*",err,error))//" is invalid."
4782  CALL flagerror(local_error,err,error,*999)
4783  END SELECT
4784  CASE(equations_nonlinear)
4785  SELECT CASE(equations%TIME_DEPENDENCE)
4786  CASE(equations_static)
4787  SELECT CASE(equations_set%SOLUTION_METHOD)
4788  CASE(equations_set_fem_solution_method)
4789  CALL equations_set_jacobian_evaluate_static_fem(equations_set,err,error,*999)
4790  CASE(equations_set_nodal_solution_method)
4791  CALL equationsset_jacobianevaluatestaticnodal(equations_set,err,error,*999)
4792  CASE(equations_set_bem_solution_method)
4793  CALL flagerror("Not implemented.",err,error,*999)
4794  CASE(equations_set_fd_solution_method)
4795  CALL flagerror("Not implemented.",err,error,*999)
4796  CASE(equations_set_fv_solution_method)
4797  CALL flagerror("Not implemented.",err,error,*999)
4798  CASE(equations_set_gfem_solution_method)
4799  CALL flagerror("Not implemented.",err,error,*999)
4800  CASE(equations_set_gfv_solution_method)
4801  CALL flagerror("Not implemented.",err,error,*999)
4802  CASE DEFAULT
4803  local_error="The equations set solution method of "// &
4804  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
4805  & " is invalid."
4806  CALL flagerror(local_error,err,error,*999)
4807  END SELECT
4808  CASE(equations_quasistatic)
4809  SELECT CASE(equations_set%SOLUTION_METHOD)
4810  CASE(equations_set_fem_solution_method)
4811  CALL equations_set_jacobian_evaluate_static_fem(equations_set,err,error,*999)
4812  CASE(equations_set_bem_solution_method)
4813  CALL flagerror("Not implemented.",err,error,*999)
4814  CASE(equations_set_fd_solution_method)
4815  CALL flagerror("Not implemented.",err,error,*999)
4816  CASE(equations_set_fv_solution_method)
4817  CALL flagerror("Not implemented.",err,error,*999)
4818  CASE(equations_set_gfem_solution_method)
4819  CALL flagerror("Not implemented.",err,error,*999)
4820  CASE(equations_set_gfv_solution_method)
4821  CALL flagerror("Not implemented.",err,error,*999)
4822  CASE DEFAULT
4823  local_error="The equations set solution method of "// &
4824  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
4825  & " is invalid."
4826  CALL flagerror(local_error,err,error,*999)
4827  END SELECT
4828  CASE(equations_first_order_dynamic,equations_second_order_dynamic)
4829 ! sebk 15/09/09
4830  SELECT CASE(equations_set%SOLUTION_METHOD)
4831  CASE(equations_set_fem_solution_method)
4832  CALL equations_set_jacobian_evaluate_dynamic_fem(equations_set,err,error,*999)
4833  CASE(equations_set_bem_solution_method)
4834  CALL flagerror("Not implemented.",err,error,*999)
4835  CASE(equations_set_fd_solution_method)
4836  CALL flagerror("Not implemented.",err,error,*999)
4837  CASE(equations_set_fv_solution_method)
4838  CALL flagerror("Not implemented.",err,error,*999)
4839  CASE(equations_set_gfem_solution_method)
4840  CALL flagerror("Not implemented.",err,error,*999)
4841  CASE(equations_set_gfv_solution_method)
4842  CALL flagerror("Not implemented.",err,error,*999)
4843  CASE DEFAULT
4844  local_error="The equations set solution method of "// &
4845  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
4846  & " is invalid."
4847  CALL flagerror(local_error,err,error,*999)
4848  END SELECT
4849  CASE(equations_time_stepping)
4850  CALL flagerror("Not implemented.",err,error,*999)
4851  CASE DEFAULT
4852  local_error="The equations set time dependence type of "// &
4853  & trim(number_to_vstring(equations%TIME_DEPENDENCE,"*",err,error))//" is invalid."
4854  CALL flagerror(local_error,err,error,*999)
4855  END SELECT
4856  CASE(equations_nonlinear_bcs)
4857  CALL flagerror("Not implemented.",err,error,*999)
4858  CASE DEFAULT
4859  local_error="The equations linearity of "// &
4860  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))//" is invalid."
4861  CALL flagerror(local_error,err,error,*999)
4862  END SELECT
4863  ELSE
4864  CALL flagerror("Equations have not been finished.",err,error,*999)
4865  ENDIF
4866  ELSE
4867  CALL flagerror("Equations set equations is not associated.",err,error,*999)
4868  ENDIF
4869  ELSE
4870  CALL flagerror("Equations set is not associated.",err,error,*999)
4871  ENDIF
4872 
4873  exits("EQUATIONS_SET_JACOBIAN_EVALUATE")
4874  RETURN
4875 999 errorsexits("EQUATIONS_SET_JACOBIAN_EVALUATE",err,error)
4876  RETURN 1
4877  END SUBROUTINE equations_set_jacobian_evaluate
4878 
4879  !
4880  !================================================================================================================================
4881  !
4882 
4884  SUBROUTINE equations_set_jacobian_evaluate_static_fem(EQUATIONS_SET,ERR,ERROR,*)
4885 
4886  !Argument variables
4887  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
4888  INTEGER(INTG), INTENT(OUT) :: ERR
4889  TYPE(varying_string), INTENT(OUT) :: ERROR
4890  !Local Variables
4891  INTEGER(INTG) :: element_idx,ne,NUMBER_OF_TIMES
4892  REAL(SP) :: ELEMENT_USER_ELAPSED,ELEMENT_SYSTEM_ELAPSED,USER_ELAPSED,USER_TIME1(1),USER_TIME2(1),USER_TIME3(1),USER_TIME4(1), &
4893  & USER_TIME5(1),USER_TIME6(1),SYSTEM_ELAPSED,SYSTEM_TIME1(1),SYSTEM_TIME2(1),SYSTEM_TIME3(1),SYSTEM_TIME4(1), &
4894  & SYSTEM_TIME5(1),SYSTEM_TIME6(1)
4895  TYPE(domain_mapping_type), POINTER :: ELEMENTS_MAPPING
4896  TYPE(equations_type), POINTER :: EQUATIONS
4897  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
4898  TYPE(field_type), POINTER :: DEPENDENT_FIELD
4899 
4900  enters("EQUATIONS_SET_JACOBIAN_EVALUATE_STATIC_FEM",err,error,*999)
4901 
4902  IF(ASSOCIATED(equations_set)) THEN
4903  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
4904  IF(ASSOCIATED(dependent_field)) THEN
4905  equations=>equations_set%EQUATIONS
4906  IF(ASSOCIATED(equations)) THEN
4907  equations_matrices=>equations%EQUATIONS_MATRICES
4908  IF(ASSOCIATED(equations_matrices)) THEN
4909  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
4910  CALL cpu_timer(user_cpu,user_time1,err,error,*999)
4911  CALL cpu_timer(system_cpu,system_time1,err,error,*999)
4912  ENDIF
4913 !!Do we need to transfer parameter sets???
4914  !Initialise the matrices and rhs vector
4915  CALL equations_matrices_values_initialise(equations_matrices,equations_matrices_jacobian_only,0.0_dp,err,error,*999)
4916  !Assemble the elements
4917  !Allocate the element matrices
4918  CALL equations_matrices_element_initialise(equations_matrices,err,error,*999)
4919  elements_mapping=>dependent_field%DECOMPOSITION%DOMAIN(dependent_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
4920  & mappings%ELEMENTS
4921  !Output timing information if required
4922  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
4923  CALL cpu_timer(user_cpu,user_time2,err,error,*999)
4924  CALL cpu_timer(system_cpu,system_time2,err,error,*999)
4925  user_elapsed=user_time2(1)-user_time1(1)
4926  system_elapsed=system_time2(1)-system_time1(1)
4927  CALL write_string_value(general_output_type,"User time for equations setup and initialisation = ",user_elapsed, &
4928  & err,error,*999)
4929  CALL write_string_value(general_output_type,"System time for equations setup and initialisation = ",system_elapsed, &
4930  & err,error,*999)
4931  element_user_elapsed=0.0_sp
4932  element_system_elapsed=0.0_sp
4933  ENDIF
4934  number_of_times=0
4935  !Loop over the internal elements
4936  DO element_idx=elements_mapping%INTERNAL_START,elements_mapping%INTERNAL_FINISH
4937  ne=elements_mapping%DOMAIN_LIST(element_idx)
4938  number_of_times=number_of_times+1
4939  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
4940  CALL equationsset_finiteelementjacobianevaluate(equations_set,ne,err,error,*999)
4941  CALL equations_matrices_jacobian_element_add(equations_matrices,err,error,*999)
4942  ENDDO !element_idx
4943  !Output timing information if required
4944  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
4945  CALL cpu_timer(user_cpu,user_time3,err,error,*999)
4946  CALL cpu_timer(system_cpu,system_time3,err,error,*999)
4947  user_elapsed=user_time3(1)-user_time2(1)
4948  system_elapsed=system_time3(1)-system_time2(1)
4949  element_user_elapsed=user_elapsed
4950  element_system_elapsed=system_elapsed
4951  CALL write_string(general_output_type,"",err,error,*999)
4952  CALL write_string_value(general_output_type,"User time for internal equations assembly = ",user_elapsed, &
4953  & err,error,*999)
4954  CALL write_string_value(general_output_type,"System time for internal equations assembly = ",system_elapsed, &
4955  & err,error,*999)
4956  ENDIF
4957  !Output timing information if required
4958  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
4959  CALL cpu_timer(user_cpu,user_time4,err,error,*999)
4960  CALL cpu_timer(system_cpu,system_time4,err,error,*999)
4961  user_elapsed=user_time4(1)-user_time3(1)
4962  system_elapsed=system_time4(1)-system_time3(1)
4963  CALL write_string_value(general_output_type,"User time for parameter transfer completion = ",user_elapsed, &
4964  & err,error,*999)
4965  CALL write_string_value(general_output_type,"System time for parameter transfer completion = ",system_elapsed, &
4966  & err,error,*999)
4967  ENDIF
4968  !Loop over the boundary and ghost elements
4969  DO element_idx=elements_mapping%BOUNDARY_START,elements_mapping%GHOST_FINISH
4970  ne=elements_mapping%DOMAIN_LIST(element_idx)
4971  number_of_times=number_of_times+1
4972  CALL equations_matrices_element_calculate(equations_matrices,ne,err,error,*999)
4973  CALL equationsset_finiteelementjacobianevaluate(equations_set,ne,err,error,*999)
4974  CALL equations_matrices_jacobian_element_add(equations_matrices,err,error,*999)
4975  ENDDO !element_idx
4976  !Output timing information if required
4977  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
4978  CALL cpu_timer(user_cpu,user_time5,err,error,*999)
4979  CALL cpu_timer(system_cpu,system_time5,err,error,*999)
4980  user_elapsed=user_time5(1)-user_time4(1)
4981  system_elapsed=system_time5(1)-system_time4(1)
4982  element_user_elapsed=element_user_elapsed+user_elapsed
4983  element_system_elapsed=element_system_elapsed+user_elapsed
4984  CALL write_string_value(general_output_type,"User time for boundary+ghost equations assembly = ",user_elapsed, &
4985  & err,error,*999)
4986  CALL write_string_value(general_output_type,"System time for boundary+ghost equations assembly = ",system_elapsed, &
4987  & err,error,*999)
4988  IF(number_of_times>0) THEN
4989  CALL write_string_value(general_output_type,"Average element user time for equations assembly = ", &
4990  & element_user_elapsed/number_of_times,err,error,*999)
4991  CALL write_string_value(general_output_type,"Average element system time for equations assembly = ", &
4992  & element_system_elapsed/number_of_times,err,error,*999)
4993  ENDIF
4994  ENDIF
4995  !Finalise the element matrices
4996  CALL equations_matrices_element_finalise(equations_matrices,err,error,*999)
4997  !Output equations matrices and RHS vector if required
4998  IF(equations%OUTPUT_TYPE>=equations_matrix_output) THEN
4999  CALL equations_matrices_jacobian_output(general_output_type,equations_matrices,err,error,*999)
5000  ENDIF
5001  !Output timing information if required
5002  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
5003  CALL cpu_timer(user_cpu,user_time6,err,error,*999)
5004  CALL cpu_timer(system_cpu,system_time6,err,error,*999)
5005  user_elapsed=user_time6(1)-user_time1(1)
5006  system_elapsed=system_time6(1)-system_time1(1)
5007  CALL write_string(general_output_type,"",err,error,*999)
5008  CALL write_string_value(general_output_type,"Total user time for equations assembly = ",user_elapsed, &
5009  & err,error,*999)
5010  CALL write_string_value(general_output_type,"Total system time for equations assembly = ",system_elapsed, &
5011  & err,error,*999)
5012  ENDIF
5013  ELSE
5014  CALL flagerror("Equations matrices is not associated",err,error,*999)
5015  ENDIF
5016  ELSE
5017  CALL flagerror("Equations is not associated",err,error,*999)
5018  ENDIF
5019  ELSE
5020  CALL flagerror("Dependent field is not associated",err,error,*999)
5021  ENDIF
5022  ELSE
5023  CALL flagerror("Equations set is not associated.",err,error,*999)
5024  ENDIF
5025 
5026  exits("EQUATIONS_SET_JACOBIAN_EVALUATE_STATIC_FEM")
5027  RETURN
5028 999 errorsexits("EQUATIONS_SET_JACOBIAN_EVALUATE_STATIC_FEM",err,error)
5029  RETURN 1
5030  END SUBROUTINE equations_set_jacobian_evaluate_static_fem
5031 
5032  !
5033  !================================================================================================================================
5034  !
5035 
5037  SUBROUTINE equations_set_jacobian_evaluate_dynamic_fem(EQUATIONS_SET,ERR,ERROR,*)
5038 
5039  !Argument variables
5040  TYPE(