OpenCMISS-Iron Internal API Documentation
finite_elasticity_routines.f90
Go to the documentation of this file.
1 
43 
45 MODULE finite_elasticity_routines
46 
47  USE base_routines
48  USE basis_routines
49  USE boundary_conditions_routines
50  USE comp_environment
51  USE constants
52  USE control_loop_routines
53  USE coordinate_routines
54  USE distributed_matrix_vector
55  USE domain_mappings
56  USE equations_routines
57  USE equations_mapping_routines
58  USE equations_matrices_routines
59  USE equations_set_constants
60  USE field_routines
61  USE field_io_routines
62  USE fluid_mechanics_io_routines
63  USE generated_mesh_routines
64  USE input_output
65  USE iso_varying_string
66  USE kinds
67  USE lapack
68  USE maths
69  USE matrix_vector
70  USE mesh_routines
71 #ifndef NOMPIMOD
72  USE mpi
73 #endif
74  USE problem_constants
75  USE solver_routines
76  USE strings
77  USE timer
78  USE types
79 
80 #include "macros.h"
81 
82  IMPLICIT NONE
83 
84 #ifdef NOMPIMOD
85 #include "mpif.h"
86 #endif
87 
88  PRIVATE
89 
90  !Module parameters
91 
96  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_pin_idx=1
97  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_pout_idx=2
98  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_lambda_idx=3
99  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_tsi_idx=4
100  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_rin_idx=5
101  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_rout_idx=6
102  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_c1_idx=7
103  INTEGER(INTG), PARAMETER :: finite_elasticity_analytic_cylinder_param_c2_idx=8
105 
106  !Module types
107 
108  !Module variables
109 
110  !Interfaces
111 
112  PUBLIC finite_elasticity_analytic_cylinder_param_pin_idx,finite_elasticity_analytic_cylinder_param_pout_idx, &
113  & finite_elasticity_analytic_cylinder_param_lambda_idx, finite_elasticity_analytic_cylinder_param_tsi_idx, &
114  & finite_elasticity_analytic_cylinder_param_rin_idx, finite_elasticity_analytic_cylinder_param_rout_idx, &
115  & finite_elasticity_analytic_cylinder_param_c1_idx, finite_elasticity_analytic_cylinder_param_c2_idx
116 
117  PUBLIC finiteelasticity_boundaryconditionsanalyticcalculate, &
118  & finiteelasticity_finiteelementresidualevaluate,finiteelasticity_finiteelementjacobianevaluate, &
119  & finite_elasticity_equations_set_setup,finiteelasticity_equationssetsolutionmethodset, &
120  & finiteelasticity_equationssetspecificationset,finiteelasticity_problemspecificationset,finite_elasticity_problem_setup, &
121  & finiteelasticity_contactproblemspecificationset,finiteelasticity_contactproblemsetup, &
122  & finite_elasticity_post_solve,finite_elasticity_post_solve_output_data, &
123  & finite_elasticity_pre_solve,finiteelasticity_controltimelooppreloop,finiteelasticity_controlloadincrementlooppostloop, &
124  & evaluate_chapelle_function, get_darcy_finite_elasticity_parameters, &
125  & finiteelasticity_gaussdeformationgradienttensor,finite_elasticity_load_increment_apply, &
126  & finiteelasticity_straincalculate, &
127  & finiteelasticity_finiteelementpreresidualevaluate,finiteelasticity_finiteelementpostresidualevaluate
128 
129  PUBLIC finiteelasticityequationsset_derivedvariablecalculate, &
130  & finiteelasticity_tensorinterpolatexi
131 
132 CONTAINS
133 
134  !
135  !================================================================================================================================
136  !
137 
139  SUBROUTINE finiteelasticity_boundaryconditionsanalyticcalculate(EQUATIONS_SET,BOUNDARY_CONDITIONS,ERR,ERROR,*)
140  !Argument variables
141  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
142  TYPE(boundary_conditions_type), POINTER :: BOUNDARY_CONDITIONS
143  INTEGER(INTG), INTENT(OUT) :: ERR
144  TYPE(varying_string), INTENT(OUT) :: ERROR
145  !Local variables
146  INTEGER(INTG) :: node_idx,component_idx,deriv_idx,variable_idx,dim_idx,local_ny,variable_type
147  INTEGER(INTG) :: NUMBER_OF_DIMENSIONS,user_node,global_node,local_node
148  REAL(DP) :: X(3),DEFORMED_X(3),P
149  REAL(DP), POINTER :: GEOMETRIC_PARAMETERS(:)
150  TYPE(domain_type), POINTER :: DOMAIN,DOMAIN_PRESSURE
151  TYPE(domain_nodes_type), POINTER :: DOMAIN_NODES,DOMAIN_PRESSURE_NODES
152  TYPE(decomposition_type), POINTER :: DECOMPOSITION
153  TYPE(mesh_type), POINTER :: MESH
154  TYPE(generated_mesh_type), POINTER :: GENERATED_MESH
155  TYPE(domain_mapping_type), POINTER :: NODES_MAPPING
156  TYPE(field_type), POINTER :: DEPENDENT_FIELD,GEOMETRIC_FIELD
157  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE,GEOMETRIC_VARIABLE
158  !BC stuff
159  INTEGER(INTG),ALLOCATABLE :: INNER_SURFACE_NODES(:),OUTER_SURFACE_NODES(:),TOP_SURFACE_NODES(:),BOTTOM_SURFACE_NODES(:)
160  INTEGER(INTG) :: INNER_NORMAL_XI,OUTER_NORMAL_XI,TOP_NORMAL_XI,BOTTOM_NORMAL_XI,MESH_COMPONENT
161  INTEGER(INTG) :: MY_COMPUTATIONAL_NODE_NUMBER, DOMAIN_NUMBER, MPI_IERROR
162  REAL(DP) :: PIN,POUT,LAMBDA,DEFORMED_Z
163  LOGICAL :: X_FIXED,Y_FIXED,NODE_EXISTS, X_OKAY,Y_OKAY
164  TYPE(varying_string) :: LOCAL_ERROR
165 
166  NULLIFY(geometric_parameters)
167 
168  enters("FiniteElasticity_BoundaryConditionsAnalyticCalculate",err,error,*999)
169 
170  my_computational_node_number=computational_node_number_get(err,error)
171 
172  IF(ASSOCIATED(equations_set)) THEN
173  IF(ASSOCIATED(equations_set%ANALYTIC)) THEN
174  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
175  IF(ASSOCIATED(dependent_field)) THEN
176  geometric_field=>equations_set%GEOMETRY%GEOMETRIC_FIELD
177  IF(ASSOCIATED(geometric_field)) THEN
178  CALL field_number_of_components_get(geometric_field,field_u_variable_type,number_of_dimensions,err,error,*999)
179  !Get access to geometric coordinates
180  NULLIFY(geometric_variable)
181  CALL field_variable_get(geometric_field,field_u_variable_type,geometric_variable,err,error,*999)
182  mesh_component=geometric_variable%COMPONENTS(1)%MESH_COMPONENT_NUMBER
183  CALL field_parameter_set_data_get(geometric_field,field_u_variable_type,field_values_set_type,geometric_parameters, &
184  & err,error,*999)
185  !Assign BC here - it's complicated so separate from analytic calculations
186  IF(ASSOCIATED(boundary_conditions)) THEN
187  decomposition=>dependent_field%DECOMPOSITION
188  IF(ASSOCIATED(decomposition)) THEN
189  mesh=>decomposition%MESH
190  IF(ASSOCIATED(mesh)) THEN
191  generated_mesh=>mesh%GENERATED_MESH
192  IF(ASSOCIATED(generated_mesh)) THEN
193  nodes_mapping=>decomposition%DOMAIN(1)%PTR%MAPPINGS%NODES !HACK - ALL CHECKING INTERMEDIATE SKIPPED
194  IF(ASSOCIATED(nodes_mapping)) THEN
195  !Get surfaces (hardcoded): fix two nodes on the bottom face, pressure conditions inside & outside
196  CALL generated_mesh_surface_get(generated_mesh,mesh_component,1_intg, &
197  & inner_surface_nodes,inner_normal_xi,err,error,*999) !Inner
198  CALL generated_mesh_surface_get(generated_mesh,mesh_component,2_intg, &
199  & outer_surface_nodes,outer_normal_xi,err,error,*999) !Outer
200  CALL generated_mesh_surface_get(generated_mesh,mesh_component,3_intg, &
201  & top_surface_nodes,top_normal_xi,err,error,*999) !Top
202  CALL generated_mesh_surface_get(generated_mesh,mesh_component,4_intg, &
203  & bottom_surface_nodes,bottom_normal_xi,err,error,*999) !Bottom
204  !Set all inner surface nodes to inner pressure (- sign is to make positive P into a compressive force) ?
205  pin=equations_set%ANALYTIC%ANALYTIC_USER_PARAMS(finite_elasticity_analytic_cylinder_param_pin_idx)
206  DO node_idx=1,SIZE(inner_surface_nodes,1)
207  user_node=inner_surface_nodes(node_idx)
208  !Need to test if this node is in current decomposition
209  CALL decomposition_node_domain_get(decomposition,user_node,1,domain_number,err,error,*999)
210  IF(domain_number==my_computational_node_number) THEN
211  !Default to version 1 of each node derivative
212  CALL boundary_conditions_set_node(boundary_conditions,dependent_field,field_deludeln_variable_type,1,1, &
213  & user_node,abs(inner_normal_xi),boundary_condition_pressure_incremented,pin,err,error,*999)
214  ENDIF
215  ENDDO
216  !Set all outer surface nodes to outer pressure
217  pout=equations_set%ANALYTIC%ANALYTIC_USER_PARAMS(finite_elasticity_analytic_cylinder_param_pout_idx)
218  DO node_idx=1,SIZE(outer_surface_nodes,1)
219  user_node=outer_surface_nodes(node_idx)
220  !Need to test if this node is in current decomposition
221  CALL decomposition_node_domain_get(decomposition,user_node,1,domain_number,err,error,*999)
222  IF(domain_number==my_computational_node_number) THEN
223  !Default to version 1 of each node derivative
224  CALL boundary_conditions_set_node(boundary_conditions,dependent_field,field_deludeln_variable_type,1,1, &
225  & user_node,abs(outer_normal_xi),boundary_condition_pressure_incremented,pout,err,error,*999)
226  ENDIF
227  ENDDO
228  !Set all top nodes fixed in z plane at lambda*height
229  lambda=equations_set%ANALYTIC%ANALYTIC_USER_PARAMS(finite_elasticity_analytic_cylinder_param_lambda_idx)
230  DO node_idx=1,SIZE(top_surface_nodes,1)
231  user_node=top_surface_nodes(node_idx)
232  !Need to test if this node is in current decomposition
233  CALL decomposition_node_domain_get(decomposition,user_node,1,domain_number,err,error,*999)
234  IF(domain_number==my_computational_node_number) THEN
235  CALL meshtopologynodecheckexists(mesh,1,user_node,node_exists,global_node,err,error,*999)
236  IF(.NOT.node_exists) cycle
237  CALL domain_mappings_global_to_local_get(nodes_mapping,global_node,node_exists,local_node,err,error,*999)
238  !Default to version 1 of each node derivative
239  local_ny=geometric_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_node)% &
240  & derivatives(1)%VERSIONS(1)
241  deformed_z=geometric_parameters(local_ny)*lambda
242  !Default to version 1 of each node derivative
243  CALL boundary_conditions_set_node(boundary_conditions,dependent_field,field_u_variable_type,1,1, &
244  & user_node,abs(top_normal_xi),boundary_condition_fixed,deformed_z,err,error,*999)
245  ENDIF
246  ENDDO
247  !Set all bottom nodes fixed in z plane
248  DO node_idx=1,SIZE(bottom_surface_nodes,1)
249  user_node=bottom_surface_nodes(node_idx)
250  !Need to check this node exists in the current domain
251  CALL decomposition_node_domain_get(decomposition,user_node,1,domain_number,err,error,*999)
252  IF(domain_number==my_computational_node_number) THEN
253  !Default to version 1 of each node derivative
254  CALL boundary_conditions_set_node(boundary_conditions,dependent_field,field_u_variable_type,1,1, &
255  & user_node,abs(bottom_normal_xi),boundary_condition_fixed,0.0_dp,err,error,*999)
256  ENDIF
257  ENDDO
258  !Set two nodes on the bottom surface to axial displacement only:
259  !Easier for parallel: Fix everything that can be fixed !!!
260  x_fixed=.false.
261  y_fixed=.false.
262  DO node_idx=1,SIZE(bottom_surface_nodes,1)
263  user_node=bottom_surface_nodes(node_idx)
264  CALL decomposition_node_domain_get(decomposition,user_node,1,domain_number,err,error,*999)
265  IF(domain_number==my_computational_node_number) THEN
266  CALL meshtopologynodecheckexists(mesh,1,user_node,node_exists,global_node,err,error,*999)
267  IF(.NOT.node_exists) cycle
268  CALL domain_mappings_global_to_local_get(nodes_mapping,global_node,node_exists,local_node,err,error,*999)
269  !Default to version 1 of each node derivative
270  local_ny=geometric_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_node)% &
271  & derivatives(1)%VERSIONS(1)
272  x(1)=geometric_parameters(local_ny)
273  CALL meshtopologynodecheckexists(mesh,1,user_node,node_exists,global_node,err,error,*999)
274  IF(.NOT.node_exists) cycle
275  CALL domain_mappings_global_to_local_get(nodes_mapping,global_node,node_exists,local_node, &
276  & err,error,*999)
277  !Default to version 1 of each node derivative
278  local_ny=geometric_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(local_node)% &
279  & derivatives(1)%VERSIONS(1)
280  x(2)=geometric_parameters(local_ny)
281  IF(abs(x(1))<1e-7_dp) THEN
282  !Default to version 1 of each node derivative
283  CALL boundary_conditions_set_node(boundary_conditions,dependent_field,field_u_variable_type,1,1, &
284  & user_node,1,boundary_condition_fixed,0.0_dp,err,error,*999)
285 
286  x_fixed=.true.
287  ENDIF
288  IF(abs(x(2))<1e-7_dp) THEN
289  !Default to version 1 of each node derivative
290  CALL boundary_conditions_set_node(boundary_conditions,dependent_field,field_u_variable_type,1,1, &
291  & user_node,2,boundary_condition_fixed,0.0_dp,err,error,*999)
292 
293  y_fixed=.true.
294  ENDIF
295  ENDIF
296  ENDDO
297  !Check it went well
298  CALL mpi_reduce(x_fixed,x_okay,1,mpi_logical,mpi_lor,0,mpi_comm_world,mpi_ierror)
299  CALL mpi_reduce(y_fixed,y_okay,1,mpi_logical,mpi_lor,0,mpi_comm_world,mpi_ierror)
300  IF(my_computational_node_number==0) THEN
301  IF(.NOT.(x_okay.AND.y_okay)) THEN
302  CALL flagerror("Could not fix nodes to prevent rigid body motion",err,error,*999)
303  ENDIF
304  ENDIF
305  ELSE
306  CALL flagerror("Domain nodes mapping is not associated.",err,error,*999)
307  ENDIF
308  ELSE
309  CALL flagerror("Generated mesh is not associated. For the Cylinder analytic solution, "// &
310  & "it must be available for automatic boundary condition assignment",err,error,*999)
311  ENDIF
312  ELSE
313  CALL flagerror("Mesh is not associated",err,error,*999)
314  ENDIF
315  ELSE
316  CALL flagerror("Decomposition is not associated",err,error,*999)
317  ENDIF
318 
319  !Now calculate analytic solution
320  DO variable_idx=1,dependent_field%NUMBER_OF_VARIABLES
321  variable_type=dependent_field%VARIABLES(variable_idx)%VARIABLE_TYPE
322  field_variable=>dependent_field%VARIABLE_TYPE_MAP(variable_type)%PTR
323  IF(variable_idx==1) CALL write_string_value(general_output_type," Global number of dofs : ", &
324  & field_variable%NUMBER_OF_GLOBAL_DOFS,err,error,*999)
325  IF(ASSOCIATED(field_variable)) THEN
326  CALL field_parameter_set_create(dependent_field,variable_type,field_analytic_values_set_type,err,error,*999)
327  component_idx=1 !Assuming components 1..3 use a common mesh component and 4 uses a different one
328  IF(field_variable%COMPONENTS(component_idx)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN
329  domain=>field_variable%COMPONENTS(component_idx)%DOMAIN
330  IF(ASSOCIATED(domain)) THEN
331  IF(ASSOCIATED(domain%TOPOLOGY)) THEN
332  domain_nodes=>domain%TOPOLOGY%NODES
333  IF(ASSOCIATED(domain_nodes)) THEN
334  !Also grab the equivalent pointer for pressure component
335  IF(field_variable%COMPONENTS(4)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN
336  domain_pressure=>field_variable%COMPONENTS(4)%DOMAIN
337  IF(ASSOCIATED(domain_pressure)) THEN
338  IF(ASSOCIATED(domain_pressure%TOPOLOGY)) THEN
339  domain_pressure_nodes=>domain_pressure%TOPOLOGY%NODES
340  IF(ASSOCIATED(domain_pressure_nodes)) THEN
341 
342  !Loop over the local nodes excluding the ghosts.
343  DO node_idx=1,domain_nodes%NUMBER_OF_NODES
344  !!TODO \todo We should interpolate the geometric field here and the node position.
345  DO dim_idx=1,number_of_dimensions
346  !Default to version 1 of each node derivative
347  local_ny=geometric_variable%COMPONENTS(dim_idx)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP% &
348  & nodes(node_idx)%DERIVATIVES(1)%VERSIONS(1)
349  x(dim_idx)=geometric_parameters(local_ny)
350  ENDDO !dim_idx
351  !Loop over the derivatives
352  DO deriv_idx=1,domain_nodes%NODES(node_idx)%NUMBER_OF_DERIVATIVES
353  SELECT CASE(equations_set%ANALYTIC%ANALYTIC_FUNCTION_TYPE)
354  CASE(equations_set_finite_elasticity_cylinder)
355  !Cylinder inflation, extension, torsion
356  SELECT CASE(variable_type)
357  CASE(field_u_variable_type)
358  SELECT CASE(domain_nodes%NODES(node_idx)%DERIVATIVES(deriv_idx)%GLOBAL_DERIVATIVE_INDEX)
359  CASE(no_global_deriv)
360  !Do all components at the same time (r,theta,z)->(x,y,z) & p
361  CALL finiteelasticity_cylinderanalyticcalculate(x, &
362  & equations_set%ANALYTIC%ANALYTIC_USER_PARAMS,deformed_x,p,err,error,*999)
363  CASE(global_deriv_s1)
364  CALL flagerror("Not implemented.",err,error,*999)
365  CASE(global_deriv_s2)
366  CALL flagerror("Not implemented.",err,error,*999)
367  CASE(global_deriv_s1_s2)
368  CALL flagerror("Not implemented.",err,error,*999)
369  CASE DEFAULT
370  local_error="The global derivative index of "//trim(number_to_vstring( &
371  domain_nodes%NODES(node_idx)%DERIVATIVES(deriv_idx)%GLOBAL_DERIVATIVE_INDEX,"*", &
372  & err,error))//" is invalid."
373  CALL flagerror(local_error,err,error,*999)
374  END SELECT
375  CASE(field_deludeln_variable_type)
376  SELECT CASE(domain_nodes%NODES(node_idx)%DERIVATIVES(deriv_idx)%GLOBAL_DERIVATIVE_INDEX)
377  CASE(no_global_deriv)
378  !Not implemented, but don't want to cause an error so do nothing
379  CASE(global_deriv_s1)
380  CALL flagerror("Not implemented.",err,error,*999)
381  CASE(global_deriv_s2)
382  CALL flagerror("Not implemented.",err,error,*999)
383  CASE(global_deriv_s1_s2)
384  CALL flagerror("Not implemented.",err,error,*999)
385  CASE DEFAULT
386  local_error="The global derivative index of "//trim(number_to_vstring( &
387  domain_nodes%NODES(node_idx)%DERIVATIVES(deriv_idx)%GLOBAL_DERIVATIVE_INDEX,"*", &
388  & err,error))//" is invalid."
389  CALL flagerror(local_error,err,error,*999)
390  END SELECT
391  CASE DEFAULT
392  local_error="The variable type "//trim(number_to_vstring(variable_type,"*",err,error)) &
393  & //" is invalid."
394  CALL flagerror(local_error,err,error,*999)
395  END SELECT
396  CASE DEFAULT
397  local_error="The analytic function type of "// &
398  & trim(number_to_vstring(equations_set%ANALYTIC%ANALYTIC_FUNCTION_TYPE,"*",err,error))// &
399  & " is invalid."
400  CALL flagerror(local_error,err,error,*999)
401  END SELECT
402  !Set the analytic solution to parameter set
403  DO component_idx=1,number_of_dimensions
404  !Default to version 1 of each node derivative
405  local_ny=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP% &
406  & node_param2dof_map%NODES(node_idx)%DERIVATIVES(deriv_idx)%VERSIONS(1)
407  CALL field_parameter_set_update_local_dof(dependent_field,variable_type, &
408  & field_analytic_values_set_type,local_ny,deformed_x(component_idx),err,error,*999)
409  ENDDO
410  !Don't forget the pressure component
411  user_node=domain_nodes%NODES(node_idx)%USER_NUMBER
412  CALL meshtopologynodecheckexists(mesh,domain_pressure%MESH_COMPONENT_NUMBER,user_node, &
413  & node_exists,global_node,err,error,*999)
414  IF(node_exists) THEN
415  CALL decomposition_node_domain_get(decomposition,user_node, &
416  & domain_pressure%MESH_COMPONENT_NUMBER,domain_number,err,error,*999)
417  IF(domain_number==my_computational_node_number) THEN
418  !\todo: test the domain node mappings pointer properly
419  local_node=domain_pressure%mappings%nodes%global_to_local_map(global_node)%local_number(1)
420  !Default to version 1 of each node derivative
421  local_ny=field_variable%COMPONENTS(4)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP% &
422  & nodes(local_node)%DERIVATIVES(deriv_idx)%VERSIONS(1)
423  !Because p=2.lambda in this particular constitutive law, we'll assign half the
424  !hydrostatic pressure to the analytic array
425  CALL field_parameter_set_update_local_dof(dependent_field,variable_type, &
426  & field_analytic_values_set_type,local_ny,p/2.0_dp,err,error,*999)
427  ENDIF
428  ENDIF
429  ENDDO !deriv_idx
430  ENDDO !node_idx
431 
432  ELSE
433  CALL flagerror("Domain for pressure topology node is not associated",err,error,*999)
434  ENDIF
435  ELSE
436  CALL flagerror("Domain for pressure topology is not associated",err,error,*999)
437  ENDIF
438  ELSE
439  CALL flagerror("Domain for pressure component is not associated",err,error,*999)
440  ENDIF
441  ELSE
442  CALL flagerror("Non-nodal based interpolation of pressure cannot be used with analytic solutions", &
443  & err,error,*999)
444  ENDIF
445  ELSE
446  CALL flagerror("Domain topology nodes is not associated.",err,error,*999)
447  ENDIF
448  ELSE
449  CALL flagerror("Domain topology is not associated.",err,error,*999)
450  ENDIF
451  ELSE
452  CALL flagerror("Domain is not associated.",err,error,*999)
453  ENDIF
454  ELSE
455  CALL flagerror("Only node based interpolation is implemented.",err,error,*999)
456  ENDIF
457  CALL field_parameter_set_update_start(dependent_field,variable_type,field_analytic_values_set_type, &
458  & err,error,*999)
459  CALL field_parameter_set_update_finish(dependent_field,variable_type,field_analytic_values_set_type, &
460  & err,error,*999)
461  ELSE
462  CALL flagerror("Field variable is not associated.",err,error,*999)
463  ENDIF
464 
465  ENDDO !variable_idx
466  CALL field_parameter_set_data_restore(geometric_field,field_u_variable_type,field_values_set_type, &
467  & geometric_parameters,err,error,*999)
468  ELSE
469  CALL flagerror("Boundary conditions is not associated.",err,error,*999)
470  ENDIF
471  ELSE
472  CALL flagerror("Equations set geometric field is not associated.",err,error,*999)
473  ENDIF
474  ELSE
475  CALL flagerror("Equations set dependent field is not associated.",err,error,*999)
476  ENDIF
477  ELSE
478  CALL flagerror("Equations set analytic is not associated.",err,error,*999)
479  ENDIF
480  ELSE
481  CALL flagerror("Equations set is not associated.",err,error,*999)
482  ENDIF
483 
484 
485  exits("FiniteElasticity_BoundaryConditionsAnalyticCalculate")
486  RETURN
487 999 errors("FiniteElasticity_BoundaryConditionsAnalyticCalculate",err,error)
488  exits("FiniteElasticity_BoundaryConditionsAnalyticCalculate")
489  RETURN 1
490 
491  END SUBROUTINE finiteelasticity_boundaryconditionsanalyticcalculate
492 
493  !
494  !================================================================================================================================
495  !
496 
498  SUBROUTINE finiteelasticity_cylinderanalyticcalculate(X,ANALYTIC_USER_PARAMS,DEFORMED_X,P,ERR,ERROR,*)
499  !Argument variables
500  REAL(DP), INTENT(IN) :: X(:)
501  REAL(DP), INTENT(IN) :: ANALYTIC_USER_PARAMS(:)
502  REAL(DP), INTENT(OUT) :: DEFORMED_X(3)
503  REAL(DP), INTENT(OUT) :: P
504  INTEGER(INTG), INTENT(OUT) :: ERR
505  TYPE(varying_string), INTENT(OUT) :: ERROR
506  !Local variables
507  REAL(DP) :: PIN,POUT,LAMBDA,TSI,A1,A2,C1,C2 !A1=external radius, A2=internal radius
508  REAL(DP) :: MU1,MU2,MU,K
509  REAL(DP) :: F,F2,DF
510  REAL(DP) :: R,THETA ! Undeformed coordinates in radial coordinates
511  REAL(DP) :: DEFORMED_R,DEFORMED_THETA
512  REAL(DP) :: DELTA,RES
513  REAL(DP), PARAMETER :: STEP=1e-5_dp, reltol=1e-12_dp
514 
515 
516  enters("FiniteElasticity_CylinderAnalyticCalculate",err,error,*999)
517 
518  !Grab problem parameters
519  pin=analytic_user_params(finite_elasticity_analytic_cylinder_param_pin_idx)
520  pout=analytic_user_params(finite_elasticity_analytic_cylinder_param_pout_idx)
521  lambda=analytic_user_params(finite_elasticity_analytic_cylinder_param_lambda_idx)
522  tsi=analytic_user_params(finite_elasticity_analytic_cylinder_param_tsi_idx)
523  a1=analytic_user_params(finite_elasticity_analytic_cylinder_param_rout_idx) ! external radius
524  a2=analytic_user_params(finite_elasticity_analytic_cylinder_param_rin_idx) ! internal radius
525  c1=analytic_user_params(finite_elasticity_analytic_cylinder_param_c1_idx)
526  c2=analytic_user_params(finite_elasticity_analytic_cylinder_param_c2_idx)
527 
528  !Solve for MU1 - Newton's method (\todo: Implement here, or separate out for general use?)
529  mu1=1.0_dp !Initial guess - need a better way!
530  DO
531  !Calculate f(MU1)
532  f=finite_elasticity_cylinder_analytic_func_evaluate(mu1,pin,pout,lambda,tsi,a1,a2,c1,c2)
533 
534  !Calculate f'(MU1) by finite differencing
535  f2=finite_elasticity_cylinder_analytic_func_evaluate(mu1+step,pin,pout,lambda,tsi,a1,a2,c1,c2)
536  df=(f2-f)/step
537 
538  !Next increment for MU1
539  delta=-f/df
540 
541  !Ensure that the step actually reduces residual
542  f2=finite_elasticity_cylinder_analytic_func_evaluate(mu1+delta,pin,pout,lambda,tsi,a1,a2,c1,c2)
543  DO
544  IF (abs(f2)<abs(f).OR.abs(f2)<zero_tolerance) THEN ! PASS
545  mu1=mu1+delta
546  EXIT
547  ELSEIF (delta<1e-3_dp) THEN ! FAIL: It's likely that the initial guess is too far away
548  CALL flagerror("FiniteElasticity_CylinderAnalyticCalculate failed to converge.",err,error,*999)
549  ELSE ! KEEP GOING
550  delta=delta/2.0_dp
551  f2=finite_elasticity_cylinder_analytic_func_evaluate(mu1+delta,pin,pout,lambda,tsi,a1,a2,c1,c2)
552  ENDIF
553  ENDDO
554 
555  !Test for convergence: relative residual
556  res=delta/(1.0_dp+mu1)
557  IF (res<reltol) EXIT
558  ENDDO
559 
560  !Calculate MU2
561  mu2=sqrt(((a1/a2)**2*(lambda*mu1**2-1.0_dp)+1.0_dp)/lambda)
562 
563  !Calculate radius and angle from undeformed coordinates
564  r=sqrt(x(1)**2+x(2)**2)
565  theta=atan2(x(2),x(1)) ! in radians
566 
567  !Calculate deformed coordinates
568  k=a1**2*(lambda*mu1**2-1.0_dp)
569  mu=sqrt(1.0_dp/lambda*(1.0_dp+k/r**2))
570  deformed_r=mu*r
571  deformed_theta=theta+tsi*lambda*x(3)
572  deformed_x(1)=deformed_r*cos(deformed_theta)
573  deformed_x(2)=deformed_r*sin(deformed_theta)
574  deformed_x(3)=lambda*x(3)
575 
576  !Calculate pressure
577  p=pout-(c1/lambda+c2*lambda)*(1.0_dp/lambda/mu1**2-r**2/(r**2+k)+log(mu**2/mu1**2))+c1*tsi**2*lambda*(r**2-a1**2) &
578  & -2.0_dp*(c1/lambda**2/mu**2+c2*(1.0_dp/lambda**2+1.0_dp/mu**2+tsi**2*r**2))
579 
580  exits("FiniteElasticity_CylinderAnalyticCalculate")
581  RETURN
582 999 errorsexits("FiniteElasticity_CylinderAnalyticCalculate",err,error)
583  RETURN 1
584 
585  END SUBROUTINE finiteelasticity_cylinderanalyticcalculate
586 
587  !
588  !================================================================================================================================
589  !
590 
592  FUNCTION finite_elasticity_cylinder_analytic_func_evaluate(MU1,PIN,POUT,LAMBDA,TSI,A1,A2,C1,C2)
593  !Argument variables
594  REAL(DP) :: FINITE_ELASTICITY_CYLINDER_ANALYTIC_FUNC_EVALUATE
595  REAL(DP) :: MU1,PIN,POUT,LAMBDA,TSI,A1,A2,C1,C2
596  !Local variables
597  REAL(DP) :: MU,K
598 
599  k=a1**2*(lambda*mu1**2-1.0_dp)
600  mu=sqrt(1.0_dp/lambda*(1.0_dp+k/a2**2))
601 
602  finite_elasticity_cylinder_analytic_func_evaluate= &
603  & 2.0_dp*(c1/lambda**2/mu**2 + c2*(1.0_dp/lambda**2+1.0_dp/mu**2+tsi**2*a2**2))+ &
604  & pout-(c1/lambda+c2*lambda)*(1.0_dp/lambda/mu1**2-a2**2/(a2**2+k)+2*log(mu/mu1))+ &
605  & c1*tsi**2*lambda*(a2**2-a1**2)-2.0_dp*(c1/lambda**2/mu**2+c2*(1.0_dp/lambda**2+ &
606  & 1.0_dp/mu**2+tsi**2*a2**2))+pin
607 
608  RETURN
609  END FUNCTION finite_elasticity_cylinder_analytic_func_evaluate
610 
611  !
612  !================================================================================================================================
613  !
614 
616  SUBROUTINE finite_elasticity_gauss_elasticity_tensor(EQUATIONS_SET,DEPENDENT_INTERPOLATED_POINT, &
617  & materials_interpolated_point,elasticity_tensor,hydro_elasticity_voigt,stress_tensor,dzdnu, &
618  & jznu,element_number,gauss_point_number,err,error,*)
619  !Argument variables
620  TYPE(equations_set_type), POINTER, INTENT(IN) :: EQUATIONS_SET
621  TYPE(field_interpolated_point_type), POINTER :: DEPENDENT_INTERPOLATED_POINT,MATERIALS_INTERPOLATED_POINT
622  REAL(DP), INTENT(OUT) :: ELASTICITY_TENSOR(:,:)
623  REAL(DP), INTENT(OUT) :: HYDRO_ELASTICITY_VOIGT(:)
624  REAL(DP), INTENT(OUT) :: STRESS_TENSOR(:)
625  REAL(DP), INTENT(IN) :: DZDNU(:,:)
626  REAL(DP), INTENT(IN) :: Jznu
627  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER,GAUSS_POINT_NUMBER
628  INTEGER(INTG), INTENT(OUT) :: ERR
629  TYPE(varying_string), INTENT(OUT) :: ERROR
630  !Local Variables
631  INTEGER(INTG) :: PRESSURE_COMPONENT,i,j,dof_idx
632  REAL(DP) :: P, I1, I3
633  REAL(DP) :: DZDNUT(3,3),AZL(3,3),AZU(3,3),TEMP(3,3)
634  REAL(DP) :: AZLv(6), AZUv(6)
635  REAL(DP) :: TEMPTERM1,TEMPTERM2,VALUE
636  REAL(DP), POINTER :: C(:) !Parameters for constitutive laws
637  REAL(DP) :: B(6),E(6),DQ_DE(6),Q
638  REAL(DP) :: I3EE(6,6)
639  REAL(DP) :: ADJCC(6,6)
640  REAL(DP) :: AZUE(6,6)
641  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
642  TYPE(varying_string) :: LOCAL_ERROR
643 
644  enters("FINITE_ELASTICITY_GAUSS_ELASTICITY_TENSOR",err,error,*999)
645 
646  NULLIFY(field_variable,c)
647 
648  !AZL = F'*F (deformed covariant or right cauchy deformation tensor, C)
649  !AZU - deformed contravariant tensor; I3 = det(C)
650  !E = Green-Lagrange strain tensor = 0.5*(C-I)
651  !P is the hydrostatic pressure
652 
653  ! Evaluate the Cauchy strain tensor C.
654  CALL matrix_transpose(dzdnu,dzdnut,err,error,*999)
655  CALL matrix_product(dzdnut,dzdnu,azl,err,error,*999)
656  CALL invert(azl,azu,i3,err,error,*999)
657 
658  ! Evaluate the derivative of AZU wrt to E (AZUE) for the hydrostatic term. Formulation from Nam-Ho Kim book, pg.198.
659  azlv(1) = azl(1,1)
660  azlv(2) = azl(2,2)
661  azlv(3) = azl(3,3)
662  azlv(4) = azl(1,2)
663  azlv(5) = azl(1,3)
664  azlv(6) = azl(2,3)
665  azuv(1) = azu(1,1)
666  azuv(2) = azu(2,2)
667  azuv(3) = azu(3,3)
668  azuv(4) = azu(1,2)
669  azuv(5) = azu(1,3)
670  azuv(6) = azu(2,3)
671  i3ee = reshape([0.0_dp, 4.0_dp*azlv(3), 4.0_dp*azlv(2), 0.0_dp, 0.0_dp,-4.0_dp*azlv(6), &
672  & 4.0_dp*azlv(3), 0.0_dp, 4.0_dp*azlv(1), 0.0_dp,-4.0_dp*azlv(5), 0.0_dp, &
673  & 4.0_dp*azlv(2), 4.0_dp*azlv(1), 0.0_dp, -2.0_dp*azlv(4), 0.0_dp, 0.0_dp, &
674  & 0.0_dp, 0.0_dp, -4.0_dp*azlv(4), -2.0_dp*azlv(3), 2.0_dp*azlv(6), 2.0_dp*azlv(5), &
675  & 0.0_dp, -4.0_dp*azlv(5), 0.0_dp, 2.0_dp*azlv(6), -2.0_dp*azlv(2), 2.0_dp*azlv(4), &
676  & -4.0_dp*azlv(6), 0.0_dp, 0.0_dp, 2.0_dp*azlv(5), 2.0_dp*azlv(4), -2.0_dp*azlv(1)], [6,6])
677  adjcc = reshape([0.0_dp, azlv(3), azlv(2), 0.0_dp, 0.0_dp,-azlv(6), &
678  & azlv(3), 0.0_dp, azlv(1), 0.0_dp,-azlv(5), 0.0_dp, &
679  & azlv(2), azlv(1), 0.0_dp, -azlv(4), 0.0_dp, 0.0_dp, &
680  & 0.0_dp, 0.0_dp, -azlv(4), -0.5_dp*azlv(3), 0.5_dp*azlv(6), 0.5_dp*azlv(5), &
681  & 0.0_dp, -azlv(5), 0.0_dp,0.5_dp*azlv(6), -0.5_dp*azlv(2), 0.5_dp*azlv(4), &
682  & -azlv(6), 0.0_dp, 0.0_dp, 0.5_dp*azlv(5), 0.5_dp*azlv(4), -0.5_dp*azlv(1)], [6,6])
683  !DO i=1,6
684  ! DO j=1,6
685  ! AZUE(i,j) = -2.0_DP*AZUv(i)*AZUv(j) + 2.0_DP*ADJCC(i,j)/I3
686  ! ENDDO
687  !ENDDO
688 
689  DO i=1,6
690  DO j=1,6
691  azue(i,j) = -2.0_dp*azuv(i)*azuv(j) + 0.5_dp*i3ee(i,j)/i3
692  ENDDO
693  ENDDO
694 
695  c=>materials_interpolated_point%VALUES(:,no_part_deriv)
696 
697  elasticity_tensor=0.0_dp
698 
699  SELECT CASE(equations_set%specification(3))
700  CASE(equations_set_mooney_rivlin_activecontraction_subtype,equations_set_mooney_rivlin_subtype)
701  local_error="Analytic Jacobian has not been validated for the Mooney-Rivlin equations, please use finite differences instead."
702  CALL flagerror(local_error,err,error,*999)
703  pressure_component=dependent_interpolated_point%INTERPOLATION_PARAMETERS%FIELD_VARIABLE%NUMBER_OF_COMPONENTS
704  p=dependent_interpolated_point%VALUES(pressure_component,no_part_deriv)
705  !Form of constitutive model is:
706  ! W=c1*(I1-3)+c2*(I2-3)+p/2*(I3-1)
707 
708  ! Calculate isochoric fictitious 2nd Piola tensor (in Voigt form)
709  i1=azl(1,1)+azl(2,2)+azl(3,3)
710  tempterm1=-2.0_dp*c(2)
711  tempterm2=2.0_dp*(c(1)+i1*c(2))
712  stress_tensor(1)=tempterm1*azl(1,1)+tempterm2
713  stress_tensor(2)=tempterm1*azl(2,2)+tempterm2
714  stress_tensor(3)=tempterm1*azl(3,3)+tempterm2
715  stress_tensor(4)=tempterm1*azl(2,1)
716  stress_tensor(5)=tempterm1*azl(3,1)
717  stress_tensor(6)=tempterm1*azl(3,2)
718  IF(equations_set%specification(3)==equations_set_mooney_rivlin_activecontraction_subtype) THEN
719 
720  !add active contraction stress values
721  !Be aware for modified DZDNU, should active contraction be added here? Normally should be okay as modified DZDNU and DZDNU
722  !converge during the Newton iteration.
723  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
724  DO i=1,field_variable%NUMBER_OF_COMPONENTS
725  dof_idx=field_variable%COMPONENTS(i)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
726  & gauss_points(gauss_point_number,element_number)
727  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
728  & field_values_set_type,dof_idx,VALUE,err,error,*999)
729  stress_tensor(i)=stress_tensor(i)+VALUE
730  ENDDO
731  ENDIF
732 
733  ! Calculate material elasticity tensor (in Voigt form) as
734  ! this will be compensated for in the push-forward with the modified deformation gradient.
735  tempterm1=4.0_dp*c(2)
736  tempterm2=-2.0_dp*c(2)
737  elasticity_tensor(2,1)=tempterm1
738  elasticity_tensor(3,1)=tempterm1
739  elasticity_tensor(1,2)=tempterm1
740  elasticity_tensor(3,2)=tempterm1
741  elasticity_tensor(1,3)=tempterm1
742  elasticity_tensor(2,3)=tempterm1
743  elasticity_tensor(4,4)=tempterm2
744  elasticity_tensor(5,5)=tempterm2
745  elasticity_tensor(6,6)=tempterm2
746  !Add volumetric part of elasticity tensor - p*d(C^-1)/dE.
747  elasticity_tensor=elasticity_tensor + p*azue
748 
749  !Hydrostatic portion of the elasticity tensor (dS/dp)
750  hydro_elasticity_voigt = azuv
751 
752  ! Do push-forward of 2nd Piola tensor and the material elasticity tensor.
753  CALL finite_elasticity_push_stress_tensor(stress_tensor,dzdnu,jznu,err,error,*999)
754  CALL finite_elasticity_push_stress_tensor(hydro_elasticity_voigt,dzdnu,jznu,err,error,*999)
755  CALL finite_elasticity_push_elasticity_tensor(elasticity_tensor,dzdnu,jznu,err,error,*999)
756 
757  ! Add volumetric parts.
758  stress_tensor(1:3)=stress_tensor(1:3)+p
759 
760  CASE(equations_set_transverse_isotropic_guccione_subtype,equations_set_guccione_activecontraction_subtype)
761  pressure_component=dependent_interpolated_point%INTERPOLATION_PARAMETERS%FIELD_VARIABLE%NUMBER_OF_COMPONENTS
762  p=dependent_interpolated_point%VALUES(pressure_component,no_part_deriv)
763  b=[2.0_dp*c(2),2.0_dp*c(3),2.0_dp*c(3),c(4),c(4),c(3)] ![2*b_f,2*b_t,2*b_t,b_ft,b_ft,b_t]
764  e=[0.5_dp*(azl(1,1)-1.0_dp),0.5_dp*(azl(2,2)-1.0_dp),0.5_dp*(azl(3,3)-1.0_dp),azl(2,1),azl(3,1),azl(3,2)] !(Modified) strain tensor in Voigt form.
765  dq_de=b*e
766  tempterm1=0.5_dp*c(1)*exp(0.5_dp*dot_product(e,dq_de))
767  !Calculate 2nd Piola tensor (in Voigt form)
768  stress_tensor=tempterm1*dq_de + p*azuv
769  IF(equations_set%specification(3)==equations_set_guccione_activecontraction_subtype) THEN
770  !add active contraction stress values
771  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
772  DO i=1,field_variable%NUMBER_OF_COMPONENTS
773  dof_idx=field_variable%COMPONENTS(i)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
774  & gauss_points(gauss_point_number,element_number)
775  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
776  & field_values_set_type,dof_idx,VALUE,err,error,*999)
777  stress_tensor(i)=stress_tensor(i)+VALUE
778  ENDDO
779  ENDIF
780 
781  !\todo blas has routines specifically for symmetric matrices, so it would be worth to check if these could give some speedup.
782 
783  ! Calculate material elasticity tensor c (in Voigt form).
784  ! First calculate lower part of 6X6 matrix
785  DO j=1,6
786  DO i=j,6
787  elasticity_tensor(i,j)=tempterm1*dq_de(i)*dq_de(j)
788  ENDDO
789  ENDDO
790  b=[2.0_dp*c(2),2.0_dp*c(3),2.0_dp*c(3),c(4),c(4),c(3)]
791  DO i=1,6
792  elasticity_tensor(i,i)=elasticity_tensor(i,i)+tempterm1*b(i)
793  ENDDO
794  ! Then calculate upper part.
795  DO j=2,6
796  DO i=1,j-1
797  elasticity_tensor(i,j)=elasticity_tensor(j,i)
798  ENDDO
799  ENDDO
800 
801  !Add volumetric part of elasticity tensor - p*d(C^-1)/dE.
802  elasticity_tensor=elasticity_tensor + p*azue
803 
804  !Hydrostatic portion of the elasticity tensor (dS/dp)
805  hydro_elasticity_voigt = azuv
806 
807  !Do push-forward of 2nd Piola tensor and the material elasticity tensor.
808  CALL finite_elasticity_push_stress_tensor(stress_tensor,dzdnu,jznu,err,error,*999)
809  CALL finite_elasticity_push_stress_tensor(hydro_elasticity_voigt,dzdnu,jznu,err,error,*999)
810  CALL finite_elasticity_push_elasticity_tensor(elasticity_tensor,dzdnu,jznu,err,error,*999)
811  CASE DEFAULT
812  local_error="Analytic Jacobian has not been implemented for the third equations set specification of "// &
813  & trim(number_to_vstring(equations_set%specification(3),"*",err,error))
814  CALL flagerror(local_error,err,error,*999)
815  END SELECT
816 
817  exits("FINITE_ELASTICITY_GAUSS_ELASTICITY_TENSOR")
818  RETURN
819 999 errorsexits("FINITE_ELASTICITY_GAUSS_ELASTICITY_TENSOR",err,error)
820  RETURN 1
821 
822  END SUBROUTINE finite_elasticity_gauss_elasticity_tensor
823 
824 
825 
826  !
827  !================================================================================================================================
828  !
829 
831  SUBROUTINE finiteelasticity_finiteelementjacobianevaluate(EQUATIONS_SET,ELEMENT_NUMBER,ERR,ERROR,*)
832  !Argument variables
833  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
834  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
835  INTEGER(INTG), INTENT(OUT) :: ERR
836  TYPE(varying_string), INTENT(OUT) :: ERROR
837  !Local Variables
838  INTEGER(INTG) :: FIELD_VAR_TYPE,ng,nh,ns,nhs,ni,mh,ms,mhs,oh
839  INTEGER(INTG) :: PRESSURE_COMPONENT
840  INTEGER(INTG) :: SUM_ELEMENT_PARAMETERS,TOTAL_NUMBER_OF_SURFACE_PRESSURE_CONDITIONS
841  INTEGER(INTG) :: NUMBER_OF_DIMENSIONS,NUMBER_OF_XI
842  INTEGER(INTG) :: ELEMENT_BASE_DOF_INDEX(4),component_idx,component_idx2
843  INTEGER(INTG), PARAMETER :: OFF_DIAG_COMP(3)=[0,1,3],off_diag_dep_var1(3)=[1,1,2],off_diag_dep_var2(3)=[2,3,3]
844  INTEGER(INTG) :: MESH_COMPONENT_NUMBER,NUMBER_OF_ELEMENT_PARAMETERS(4)
845  REAL(DP) :: DZDNU(3,3),CAUCHY_TENSOR(3,3),HYDRO_ELASTICITY_TENSOR(3,3)
846  REAL(DP) :: JGW_SUB_MAT(3,3)
847  REAL(DP) :: TEMPVEC(3)
848  REAL(DP) :: STRESS_TENSOR(6),ELASTICITY_TENSOR(6,6),HYDRO_ELASTICITY_VOIGT(6)
849  REAL(DP) :: DPHIDZ(3,64,3),DJDZ(64,3)
850  REAL(DP) :: JGW_DPHINS_DZ,JGW_DPHIMS_DZ,PHIMS,PHINS,TEMPTERM
851  REAL(DP) :: Jznu,JGW,SUM1,SUM2
852  TYPE(quadrature_scheme_ptr_type) :: QUADRATURE_SCHEMES(4)
853  TYPE(basis_type), POINTER :: DEPENDENT_BASIS
854  TYPE(boundary_conditions_variable_type), POINTER :: BOUNDARY_CONDITIONS_VARIABLE
855  TYPE(boundary_conditions_type), POINTER :: BOUNDARY_CONDITIONS
856  TYPE(field_interpolated_point_type), POINTER :: GEOMETRIC_INTERP_POINT,FIBRE_INTERP_POINT, &
857  & MATERIALS_INTERP_POINT,DEPENDENT_INTERP_POINT
858  TYPE(field_interpolated_point_metrics_type), POINTER :: GEOMETRIC_INTERP_POINT_METRICS, &
859  & DEPENDENT_INTERP_POINT_METRICS
860  TYPE(equations_type), POINTER :: EQUATIONS
861  TYPE(equations_mapping_type), POINTER :: EQUATIONS_MAPPING
862  TYPE(equations_mapping_nonlinear_type), POINTER :: NONLINEAR_MAPPING
863  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
864  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
865  TYPE(equations_jacobian_type), POINTER :: JACOBIAN_MATRIX
866  TYPE(field_type), POINTER :: DEPENDENT_FIELD,GEOMETRIC_FIELD,MATERIALS_FIELD,FIBRE_FIELD
867  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
868  TYPE(quadrature_scheme_type), POINTER :: DEPENDENT_QUADRATURE_SCHEME
869 
870  enters("FiniteElasticity_FiniteElementJacobianEvaluate",err,error,*999)
871 
872  IF(ASSOCIATED(equations_set)) THEN
873  equations=>equations_set%EQUATIONS
874  IF(ASSOCIATED(equations)) THEN
875  equations_matrices=>equations%EQUATIONS_MATRICES
876  nonlinear_matrices=>equations_matrices%NONLINEAR_MATRICES
877  jacobian_matrix=>nonlinear_matrices%JACOBIANS(1)%PTR
878  IF(jacobian_matrix%UPDATE_JACOBIAN) THEN
879  dependent_field=>equations%INTERPOLATION%DEPENDENT_FIELD
880  geometric_field=>equations%INTERPOLATION%GEOMETRIC_FIELD
881  materials_field=>equations%INTERPOLATION%MATERIALS_FIELD
882  fibre_field=>equations%INTERPOLATION%FIBRE_FIELD
883 
884  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(dependent_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
885  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
886  dependent_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
887 
888  number_of_dimensions=equations_set%REGION%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
889  number_of_xi=dependent_basis%NUMBER_OF_XI
890 
891  equations_mapping=>equations%EQUATIONS_MAPPING
892  nonlinear_mapping=>equations_mapping%NONLINEAR_MAPPING
893 
894  field_variable=>nonlinear_mapping%RESIDUAL_VARIABLES(1)%PTR
895  field_var_type=field_variable%VARIABLE_TYPE
896 
897  pressure_component=field_variable%NUMBER_OF_COMPONENTS
898 
899  boundary_conditions=>equations_set%BOUNDARY_CONDITIONS
900  CALL boundary_conditions_variable_get(boundary_conditions,equations_set%EQUATIONS%EQUATIONS_MAPPING%RHS_MAPPING% &
901  & rhs_variable,boundary_conditions_variable,err,error,*999)
902  total_number_of_surface_pressure_conditions=boundary_conditions_variable%DOF_COUNTS(boundary_condition_pressure)+ &
903  & boundary_conditions_variable%DOF_COUNTS(boundary_condition_pressure_incremented)
904 
905  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number,equations%INTERPOLATION% &
906  & dependent_interp_parameters(field_var_type)%PTR,err,error,*999)
907  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number,equations%INTERPOLATION% &
908  & geometric_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
909  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number,equations%INTERPOLATION% &
910  & materials_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
911  IF(ASSOCIATED(fibre_field)) THEN
912  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number,equations%INTERPOLATION% &
913  & fibre_interp_parameters(field_u_variable_type)%PTR,err,error,*999)
914  END IF
915 
916  !Point interpolation pointer
917  geometric_interp_point=>equations%INTERPOLATION%GEOMETRIC_INTERP_POINT(field_u_variable_type)%PTR
918  geometric_interp_point_metrics=>equations%INTERPOLATION%GEOMETRIC_INTERP_POINT_METRICS(field_u_variable_type)%PTR
919  IF(ASSOCIATED(fibre_field)) THEN
920  fibre_interp_point=>equations%INTERPOLATION%FIBRE_INTERP_POINT(field_u_variable_type)%PTR
921  END IF
922  materials_interp_point=>equations%INTERPOLATION%MATERIALS_INTERP_POINT(field_u_variable_type)%PTR
923  dependent_interp_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(field_var_type)%PTR
924  dependent_interp_point_metrics=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT_METRICS(field_var_type)%PTR
925 
926  sum_element_parameters=0
927  !Loop over geometric dependent basis functions.
928  DO nh=1,field_variable%NUMBER_OF_COMPONENTS
929  mesh_component_number=field_variable%COMPONENTS(nh)%MESH_COMPONENT_NUMBER
930  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
931  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
932  quadrature_schemes(nh)%PTR=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
933  IF(field_variable%COMPONENTS(nh)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN
934  number_of_element_parameters(nh)=dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
935  ELSEIF(field_variable%COMPONENTS(nh)%INTERPOLATION_TYPE==field_element_based_interpolation) THEN
936  number_of_element_parameters(nh)=1
937  ENDIF
938  element_base_dof_index(nh)=sum_element_parameters
939  sum_element_parameters=sum_element_parameters+number_of_element_parameters(nh)
940  ENDDO !nh
941 
942  !Loop over all Gauss points
943  DO ng=1,dependent_quadrature_scheme%NUMBER_OF_GAUSS
944  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,ng, &
945  & dependent_interp_point,err,error,*999)
946  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,ng, &
947  & geometric_interp_point,err,error,*999)
948  CALL field_interpolated_point_metrics_calculate(coordinate_jacobian_volume_type, &
949  & geometric_interp_point_metrics,err,error,*999)
950  CALL field_interpolated_point_metrics_calculate(coordinate_jacobian_volume_type, &
951  & dependent_interp_point_metrics,err,error,*999)
952  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,ng, &
953  & materials_interp_point,err,error,*999)
954  IF(ASSOCIATED(fibre_field)) THEN
955  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,ng, &
956  & fibre_interp_point,err,error,*999)
957  ENDIF
958 
959  jznu=dependent_interp_point_metrics%JACOBIAN/geometric_interp_point_metrics%JACOBIAN
960  jgw=dependent_interp_point_metrics%JACOBIAN*dependent_quadrature_scheme%GAUSS_WEIGHTS(ng)
961 
962  !Loop over geometric dependent basis functions.
963  DO nh=1,number_of_dimensions
964  DO ns=1,number_of_element_parameters(nh)
965  !Loop over derivative directions.
966  sum2=0.0_dp
967  DO mh=1,number_of_dimensions
968  sum1=0.0_dp
969  DO ni=1,number_of_xi
970  sum1=sum1+quadrature_schemes(nh)%PTR%GAUSS_BASIS_FNS(ns,partial_derivative_first_derivative_map(ni),ng)* &
971  & dependent_interp_point_metrics%DXI_DX(ni,mh)
972  sum2=sum2+quadrature_schemes(mh)%PTR%GAUSS_BASIS_FNS(ns,partial_derivative_first_derivative_map(ni),ng)* &
973  & dependent_interp_point_metrics%DXI_DX(ni,mh)*dependent_interp_point_metrics%GU(ni,mh)
974  ENDDO !mi
975  dphidz(mh,ns,nh)=sum1
976  ENDDO !mh
977  djdz(ns,nh)=sum2*dependent_interp_point_metrics%JACOBIAN
978  ENDDO !ns
979  ENDDO !nh
980 
981  CALL finiteelasticity_gaussdeformationgradienttensor(dependent_interp_point_metrics, &
982  & geometric_interp_point_metrics,fibre_interp_point,dzdnu,err,error,*999)
983 
984  CALL finite_elasticity_gauss_elasticity_tensor(equations_set,dependent_interp_point, &
985  & materials_interp_point,elasticity_tensor,hydro_elasticity_voigt,stress_tensor, &
986  & dzdnu,jznu,element_number,ng,err,error,*999)
987 
988  !Convert from Voigt form to tensor form.
989  DO nh=1,number_of_dimensions
990  DO mh=1,number_of_dimensions
991  cauchy_tensor(mh,nh)=stress_tensor(tensor_to_voigt3(mh,nh))
992  hydro_elasticity_tensor(mh,nh)=hydro_elasticity_voigt(tensor_to_voigt3(mh,nh))
993  ENDDO
994  ENDDO
995 
996  !1) loop over mh=nh
997  !Loop over element columns belonging to geometric dependent variables
998  nhs=0
999  DO nh=1,number_of_dimensions
1000  jgw_sub_mat=jgw*(elasticity_tensor(tensor_to_voigt3(:,nh),tensor_to_voigt3(:,nh))+cauchy_tensor)
1001  DO ns=1,number_of_element_parameters(nh)
1002  tempvec=matmul(jgw_sub_mat,dphidz(:,ns,nh))
1003  nhs=nhs+1
1004  mhs=nhs-1
1005  !Loop over element rows belonging to geometric dependent variables
1006  DO ms=ns,number_of_element_parameters(nh)
1007  mhs=mhs+1
1008  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1009  & dot_product(dphidz(:,ms,nh),tempvec)
1010  DO component_idx=1,number_of_dimensions
1011  DO component_idx2=1,number_of_dimensions
1012  tempterm=cauchy_tensor(component_idx,component_idx2)* &
1013  & dphidz(component_idx2,ms,component_idx)
1014  ENDDO
1015  ENDDO
1016  !JACOBIAN_MATRIX%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=JACOBIAN_MATRIX%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1017  ! & TEMPTERM*DJDZ(ms,nh)*DEPENDENT_QUADRATURE_SCHEME%GAUSS_WEIGHTS(ng)
1018  ENDDO !ms
1019  ENDDO !ns
1020  ENDDO !nh
1021 
1022  !2) loop over mh>nh
1023  !Loop over element columns belonging to geometric dependent variables
1024  DO oh=1,off_diag_comp(number_of_dimensions)
1025  nh=off_diag_dep_var1(oh)
1026  mh=off_diag_dep_var2(oh)
1027  nhs=element_base_dof_index(nh)
1028  jgw_sub_mat=jgw*(elasticity_tensor(tensor_to_voigt3(:,mh),tensor_to_voigt3(:,nh)))
1029  DO ns=1,number_of_element_parameters(nh)
1030  !Loop over element rows belonging to geometric dependent variables
1031  tempvec=matmul(jgw_sub_mat,dphidz(:,ns,nh))
1032  nhs=nhs+1
1033  mhs=element_base_dof_index(mh)
1034  DO ms=1,number_of_element_parameters(mh)
1035  mhs=mhs+1
1036  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1037  & dot_product(dphidz(:,ms,mh),tempvec)
1038  DO component_idx=1,number_of_dimensions
1039  DO component_idx2=1,number_of_dimensions
1040  tempterm=cauchy_tensor(component_idx,component_idx2)* &
1041  & dphidz(component_idx2,ms,component_idx)
1042  ENDDO
1043  ENDDO
1044  !JACOBIAN_MATRIX%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=JACOBIAN_MATRIX%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1045  ! & TEMPTERM*DJDZ(ms,nh)*DEPENDENT_QUADRATURE_SCHEME%GAUSS_WEIGHTS(ng)
1046  ENDDO !ms
1047  ENDDO !ns
1048  ENDDO
1049 
1050  !3) loop over all nh and pressure component
1051  nhs=0
1052  IF(field_variable%COMPONENTS(pressure_component)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN !node based
1053  !Loop over element rows belonging to geometric dependent variables
1054  DO nh=1,number_of_dimensions
1055  DO ns=1,number_of_element_parameters(nh)
1056  jgw_dphins_dz=jgw*dphidz(nh,ns,nh)
1057  nhs=nhs+1
1058  !Loop over element rows belonging to hydrostatic pressure
1059  mhs=element_base_dof_index(pressure_component)
1060  DO ms=1,number_of_element_parameters(pressure_component)
1061  mhs=mhs+1
1062  phims=quadrature_schemes(pressure_component)%PTR%GAUSS_BASIS_FNS(ms,no_part_deriv,ng)
1063  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1064  & jgw_dphins_dz*phims
1065  ENDDO !ms
1066  ENDDO !ns
1067  ENDDO !nh
1068  ELSEIF(field_variable%COMPONENTS(pressure_component)%INTERPOLATION_TYPE==field_element_based_interpolation) THEN !element based
1069  !Loop over element rows belonging to geometric dependent variables
1070  DO nh=1,number_of_dimensions
1071  DO ns=1,number_of_element_parameters(nh)
1072  jgw_dphins_dz=jgw*dphidz(nh,ns,nh)
1073  nhs=nhs+1
1074  !Loop over element rows belonging to hydrostatic pressure
1075  mhs=element_base_dof_index(pressure_component)+1
1076  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1077  & jgw_dphins_dz
1078  ENDDO !ns
1079  ENDDO !nh
1080  ENDIF
1081 
1082  !4) Loop over all mh pressure component
1083  mhs=0
1084  IF(field_variable%COMPONENTS(pressure_component)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN !node based
1085  !Loop over element columns belonging to geometric dependent variables.
1086  DO mh=1,number_of_dimensions
1087  DO ms=1,number_of_element_parameters(mh)
1088  tempvec=matmul(hydro_elasticity_tensor,dphidz(:,ms,mh))
1089  jgw_dphims_dz=jgw*tempvec(mh)
1090  mhs=mhs+1
1091  !Loop over element columns belonging to hydrostatic pressure
1092  nhs=element_base_dof_index(pressure_component)
1093  DO ns=1,number_of_element_parameters(pressure_component)
1094  nhs=nhs+1
1095  phins=quadrature_schemes(pressure_component)%PTR%GAUSS_BASIS_FNS(ns,no_part_deriv,ng)
1096  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
1097  & jgw_dphims_dz*phins
1098  ENDDO !ns
1099  ENDDO !ms
1100  ENDDO !mh
1101  ELSEIF(field_variable%COMPONENTS(pressure_component)%INTERPOLATION_TYPE==field_element_based_interpolation) THEN !element based
1102  !Loop over element columns belonging to geometric dependent variables.
1103  DO mh=1,number_of_dimensions
1104  DO ms=1,number_of_element_parameters(mh)
1105  tempvec=matmul(hydro_elasticity_tensor,dphidz(:,ms,mh))
1106  jgw_dphims_dz=jgw*tempvec(mh)
1107  mhs=mhs+1
1108  !Loop over element columns belonging to hydrostatic pressure.
1109  nhs=element_base_dof_index(pressure_component)+1
1110  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs) + &
1111  & jgw_dphims_dz
1112  ENDDO !ms
1113  ENDDO !mh
1114  ENDIF
1115  ! No loop over element columns and rows belonging both to hydrostatic pressure because it is zero.
1116  ENDDO !ng
1117 
1118  !Scale factor adjustment
1119  IF(dependent_field%SCALINGS%SCALING_TYPE/=field_no_scaling) THEN
1120  !Following call is necessary, otherwise wrong face scale factors from function call to surface pressure jacobian are
1121  !used.
1122  CALL field_interpolationparametersscalefactorselementget(element_number, &
1123  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR,err,error,*999)
1124  nhs=0
1125  ! Loop over element columns
1126  DO nh=1,number_of_dimensions
1127  DO ns=1,number_of_element_parameters(nh)
1128  nhs=nhs+1
1129  mhs=nhs-1
1130  ! Loop over element rows
1131  DO ms=ns,number_of_element_parameters(nh)
1132  mhs=mhs+1
1133  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)* &
1134  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ms,nh)* &
1135  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ns,nh)
1136  ENDDO !ms
1137  ENDDO !ns
1138  ENDDO !nh
1139  DO oh=1,off_diag_comp(number_of_dimensions)
1140  nh=off_diag_dep_var1(oh)
1141  mh=off_diag_dep_var2(oh)
1142  nhs=element_base_dof_index(nh)
1143  DO ns=1,number_of_element_parameters(nh)
1144  nhs=nhs+1
1145  mhs=element_base_dof_index(mh)
1146  !Loop over element rows belonging to geometric dependent variables
1147  DO ms=1,number_of_element_parameters(mh)
1148  mhs=mhs+1
1149  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)* &
1150  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ms,mh)* &
1151  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ns,nh)
1152  ENDDO !ms
1153  ENDDO !ns
1154  ENDDO
1155 
1156  nhs=0
1157  IF(field_variable%COMPONENTS(pressure_component)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN !node based
1158  !Loop over element rows belonging to geometric dependent variables
1159  DO nh=1,number_of_dimensions
1160  DO ns=1,number_of_element_parameters(nh)
1161  nhs=nhs+1
1162  !Loop over element rows belonging to hydrostatic pressure
1163  mhs=element_base_dof_index(pressure_component)
1164  DO ms=1,number_of_element_parameters(pressure_component)
1165  mhs=mhs+1
1166  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(nhs,mhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(nhs,mhs)* &
1167  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR% &
1168  & scale_factors(ms,pressure_component)* &
1169  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ns,nh)
1170  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)* &
1171  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR% &
1172  & scale_factors(ms,pressure_component)* &
1173  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ns,nh)
1174  ENDDO !ms
1175  ENDDO !ns
1176  ENDDO !nh
1177  ELSEIF(field_variable%COMPONENTS(pressure_component)%INTERPOLATION_TYPE==field_element_based_interpolation) THEN !element based
1178  !Loop over element rows belonging to geometric dependent variables
1179  DO nh=1,number_of_dimensions
1180  DO ns=1,number_of_element_parameters(nh)
1181  nhs=nhs+1
1182  !Loop over element rows belonging to hydrostatic pressure
1183  mhs=element_base_dof_index(pressure_component)+1
1184  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)* &
1185  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ns,nh)
1186  ENDDO !ns
1187  ENDDO !nh
1188  ENDIF
1189  ENDIF
1190 
1191  !Mirror the Jacobian matrix except for the hydrostatic rows and columns, which are not necessarily symmetric.
1192  DO nhs=2,element_base_dof_index(pressure_component)
1193  DO mhs=1,nhs-1
1194  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(nhs,mhs)
1195  ENDDO !mhs
1196  ENDDO !nhs
1197 
1198  !If unsymmetric pressure Jacobian uncomment this.
1199  !Call surface pressure term here: should only be executed if THIS element has surface pressure on it (direct or incremented)
1200  IF(dependent_field%DECOMPOSITION%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BOUNDARY_ELEMENT.AND. &
1201  & total_number_of_surface_pressure_conditions>0) THEN !
1202  CALL finiteelasticity_surfacepressurejacobianevaluate(equations_set,element_number,err,error,*999)
1203  ENDIF
1204  ENDIF
1205  ELSE
1206  CALL flagerror("Equations set equations is not associated.",err,error,*999)
1207  ENDIF
1208  ELSE
1209  CALL flagerror("Equations set is not associated.",err,error,*999)
1210  ENDIF
1211 
1212  exits("FiniteElasticity_FiniteElementJacobianEvaluate")
1213  RETURN
1214 999 errors("FiniteElasticity_FiniteElementJacobianEvaluate",err,error)
1215  exits("FiniteElasticity_FiniteElementJacobianEvaluate")
1216  RETURN 1
1217 
1218  END SUBROUTINE finiteelasticity_finiteelementjacobianevaluate
1219 
1220  !
1221  !================================================================================================================================
1222  !
1223 
1225  SUBROUTINE finite_elasticity_push_elasticity_tensor(ELASTICITY_TENSOR,DZDNU,Jznu,ERR,ERROR,*)
1226 
1227  !Argument variables
1228  REAL(DP), INTENT(INOUT) :: ELASTICITY_TENSOR(6,6)
1229  REAL(DP), INTENT(IN) :: DZDNU(3,3)
1230  REAL(DP), INTENT(IN) :: Jznu
1231  INTEGER(INTG), INTENT(OUT) :: ERR
1232  TYPE(varying_string), INTENT(OUT) :: ERROR
1233  !Local Variables
1234  INTEGER(INTG) :: i,j
1235  REAL(DP) :: t(6,6)
1236 
1237  enters("FINITE_ELASTICITY_PUSH_ELASTICITY_TENSOR",err,error,*999)
1238 
1239  DO j=1,3
1240  DO i=1,6
1241  t(i,j)=dzdnu(voigt_to_tensor3(1,i),voigt_to_tensor3(1,j))*dzdnu(voigt_to_tensor3(2,i),voigt_to_tensor3(2,j))
1242  ENDDO
1243  END DO
1244  DO j=4,6
1245  DO i=1,6
1246  t(i,j)=dzdnu(voigt_to_tensor3(1,i),voigt_to_tensor3(1,j))*dzdnu(voigt_to_tensor3(2,i),voigt_to_tensor3(2,j))+ &
1247  & dzdnu(voigt_to_tensor3(1,i),voigt_to_tensor3(2,j))*dzdnu(voigt_to_tensor3(2,i),voigt_to_tensor3(1,j))
1248  ENDDO
1249  END DO
1250 
1251  elasticity_tensor=matmul(matmul(t,elasticity_tensor),transpose(t))/jznu
1252 
1253  exits("FINITE_ELASTICITY_PUSH_ELASTICITY_TENSOR")
1254  RETURN
1255 999 errorsexits("FINITE_ELASTICITY_PUSH_ELASTICITY_TENSOR",err,error)
1256  RETURN 1
1257  END SUBROUTINE finite_elasticity_push_elasticity_tensor
1258 
1259  !
1260  !================================================================================================================================
1261  !
1262 
1264  SUBROUTINE finite_elasticity_push_stress_tensor(STRESS_TENSOR,DZDNU,Jznu,ERR,ERROR,*)
1265 
1266  !Argument variables
1267  REAL(DP), INTENT(INOUT) :: STRESS_TENSOR(6)
1268  REAL(DP), INTENT(IN) :: DZDNU(3,3)
1269  REAL(DP), INTENT(IN) :: Jznu
1270  INTEGER(INTG), INTENT(OUT) :: ERR
1271  TYPE(varying_string), INTENT(OUT) :: ERROR
1272  !Local Variables
1273  INTEGER(INTG) :: i,j
1274  REAL(DP) :: t(6,6)
1275 
1276  enters("FINITE_ELASTICITY_PUSH_STRESS_TENSOR",err,error,*999)
1277 
1278  DO j=1,3
1279  DO i=1,6
1280  t(i,j)=dzdnu(voigt_to_tensor3(1,i),voigt_to_tensor3(1,j))*dzdnu(voigt_to_tensor3(2,i),voigt_to_tensor3(2,j))
1281  ENDDO
1282  END DO
1283  DO j=4,6
1284  DO i=1,6
1285  t(i,j)=dzdnu(voigt_to_tensor3(1,i),voigt_to_tensor3(1,j))*dzdnu(voigt_to_tensor3(2,i),voigt_to_tensor3(2,j))+ &
1286  & dzdnu(voigt_to_tensor3(1,i),voigt_to_tensor3(2,j))*dzdnu(voigt_to_tensor3(2,i),voigt_to_tensor3(1,j))
1287  ENDDO
1288  END DO
1289 
1290  stress_tensor=matmul(t,stress_tensor)/jznu
1291 
1292  exits("FINITE_ELASTICITY_PUSH_STRESS_TENSOR")
1293  RETURN
1294 999 errorsexits("FINITE_ELASTICITY_PUSH_STRESS_TENSOR",err,error)
1295  RETURN 1
1296  END SUBROUTINE finite_elasticity_push_stress_tensor
1297 
1298  !
1299  !================================================================================================================================
1300  !
1301 
1303  SUBROUTINE finiteelasticity_gaussgrowthtensor(equationsSet,numberOfDimensions,gaussPointNumber,elementNumber,dependentField, &
1304  & deformationgradienttensor,growthtensor,elasticdeformationgradienttensor,jg,je,err,error,*)
1305 
1306  !Argument variables
1307  TYPE(equations_set_type), POINTER, INTENT(IN) :: equationsSet
1308  INTEGER(INTG), INTENT(IN) :: numberOfDimensions
1309  INTEGER(INTG), INTENT(IN) :: gaussPointNumber
1310  INTEGER(INTG), INTENT(IN) :: elementNumber
1311  TYPE(field_type), POINTER :: dependentField
1312  REAL(DP), INTENT(IN) :: deformationGradientTensor(3,3)
1313  REAL(DP), INTENT(OUT) :: growthTensor(3,3)
1314  REAL(DP), INTENT(OUT) :: elasticDeformationGradientTensor(3,3)
1315  REAL(DP), INTENT(OUT) :: Jg
1316  REAL(DP), INTENT(OUT) :: Je
1317  INTEGER(INTG), INTENT(OUT) :: err
1318  TYPE(varying_string), INTENT(OUT) :: error
1319  !Local Variables
1320  REAL(DP) :: growthTensorInverse(3,3),J
1321 
1322  enters("FiniteElasticity_GaussGrowthTensor",err,error,*999)
1323 
1324  IF(ASSOCIATED(equationsset)) THEN
1325  CALL identitymatrix(growthtensor,err,error,*999)
1326  jg=1.0_dp
1327  elasticdeformationgradienttensor=deformationgradienttensor
1328  je=determinant(elasticdeformationgradienttensor,err,error)
1329  ELSE
1330  CALL flagerror("Equations set is not associated.",err,error,*999)
1331  ENDIF
1332 
1333  IF(diagnostics1) THEN
1334  CALL writestring(diagnostic_output_type,"",err,error,*999)
1335  CALL writestring(diagnostic_output_type,"Growth information:",err,error,*999)
1336  CALL writestring(diagnostic_output_type," Total deformation gradient tensor:",err,error,*999)
1337  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3,3,3,deformationgradienttensor, &
1338  & write_string_matrix_name_and_indices,'(" F','(",I1,",:)',' :",3(X,E13.6))','(13X,3(X,E13.6))',err,error,*999)
1339  j=determinant(deformationgradienttensor,err,error)
1340  CALL writestringvalue(diagnostic_output_type," Determinant F, J = ",j,err,error,*999)
1341  CALL writestring(diagnostic_output_type," Elastic component of the deformation gradient tensor:",err,error,*999)
1342  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3,3,3,elasticdeformationgradienttensor, &
1343  & write_string_matrix_name_and_indices,'(" Fe','(",I1,",:)',' :",3(X,E13.6))','(13X,3(X,E13.6))',err,error,*999)
1344  CALL writestringvalue(diagnostic_output_type," Determinant Fe, Je = ",je,err,error,*999)
1345  CALL writestring(diagnostic_output_type," Growth component of the deformation gradient tensor:",err,error,*999)
1346  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3,3,3,growthtensor, &
1347  & write_string_matrix_name_and_indices,'(" Fg','(",I1,",:)',' :",3(X,E13.6))','(13X,3(X,E13.6))',err,error,*999)
1348  CALL writestringvalue(diagnostic_output_type," Determinant Fg, Jg = ",jg,err,error,*999)
1349  ENDIF
1350 
1351  exits("FiniteElasticity_GaussGrowthTensor")
1352  RETURN
1353  999 errorsexits("FiniteElasticity_GaussGrowthTensor",err,error)
1354  RETURN 1
1355 
1356  END SUBROUTINE finiteelasticity_gaussgrowthtensor
1357 
1358  !
1359  !================================================================================================================================
1360  !
1361 
1363  SUBROUTINE finiteelasticity_straintensor(deformationGradientTensor,rightCauchyDeformationTensor,fingerDeformationTensor, &
1364  jacobian,greenstraintensor,err,error,*)
1365 
1366  !Argument variables
1367  REAL(DP), INTENT(IN) :: deformationGradientTensor(3,3)
1368  REAL(DP) :: deformationGradientTensorT(3,3)
1369  REAL(DP), INTENT(OUT) :: rightCauchyDeformationTensor(3,3)
1370  REAL(DP), INTENT(OUT) :: fingerDeformationTensor(3,3)
1371  REAL(DP), INTENT(OUT) :: Jacobian
1372  REAL(DP), INTENT(OUT) :: greenStrainTensor(3,3)
1373  INTEGER(INTG), INTENT(OUT) :: err
1374  TYPE(varying_string), INTENT(OUT) :: error
1375  !Local Variables
1376  INTEGER(INTG) :: i
1377  REAL(DP) :: I3
1378 
1379  enters("FiniteElasticity_StrainTensor",err,error,*999)
1380 
1381  CALL matrixtranspose(deformationgradienttensor, deformationgradienttensort,err,error,*999)
1382  CALL matrixproduct(deformationgradienttensort, deformationgradienttensor, rightcauchydeformationtensor,err,error,*999)
1383  !CALL MatrixTransposeProduct(deformationGradientTensor,deformationGradientTensor,rightCauchyDeformationTensor,err,error,*999)
1384  CALL invert(rightcauchydeformationtensor,fingerdeformationtensor,i3,err,error,*999)
1385  jacobian=determinant(deformationgradienttensor,err,error)
1386 
1387  greenstraintensor=0.5_dp*rightcauchydeformationtensor
1388  DO i=1,3
1389  greenstraintensor(i,i)=greenstraintensor(i,i)-0.5_dp
1390  ENDDO !i
1391 
1392  IF(diagnostics1) THEN
1393  CALL writestring(diagnostic_output_type,"",err,error,*999)
1394  CALL writestring(diagnostic_output_type,"Strain information:",err,error,*999)
1395  CALL writestring(diagnostic_output_type," Right Cauchy-Green deformation tensor:",err,error,*999)
1396  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
1397  & 3,3,rightcauchydeformationtensor,write_string_matrix_name_and_indices, '(" C','(",I1,",:)', &
1398  & ' :",3(X,E13.6))','(12X,3(X,E13.6))',err,error,*999)
1399  CALL writestring(diagnostic_output_type," Finger deformation tensor:",err,error,*999)
1400  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
1401  & 3,3,fingerdeformationtensor,write_string_matrix_name_and_indices, '(" f','(",I1,",:)', &
1402  & ' :",3(X,E13.6))','(12X,3(X,E13.6))',err,error,*999)
1403  CALL writestringvalue(diagnostic_output_type," Jacobian = ",jacobian,err,error,*999)
1404  CALL writestring(diagnostic_output_type," Green-Lagrange strain tensor:",err,error,*999)
1405  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
1406  & 3,3,greenstraintensor,write_string_matrix_name_and_indices, '(" E','(",I1,",:)', &
1407  & ' :",3(X,E13.6))','(12X,3(X,E13.6))',err,error,*999)
1408  ENDIF
1409 
1410  exits("FiniteElasticity_StrainTensor")
1411  RETURN
1412  999 errorsexits("FiniteElasticity_StrainTensor",err,error)
1413  RETURN 1
1414 
1415  END SUBROUTINE finiteelasticity_straintensor
1416 
1417  !
1418  !================================================================================================================================
1419  !
1420 
1422  SUBROUTINE finiteelasticity_finiteelementresidualevaluate(EQUATIONS_SET,ELEMENT_NUMBER,ERR,ERROR,*)
1423 
1424  !Argument variables
1425  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
1426  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
1427  INTEGER(INTG), INTENT(OUT) :: ERR
1428  TYPE(varying_string), INTENT(OUT) :: ERROR
1429  !Local Variables
1430  TYPE(basis_type), POINTER :: DEPENDENT_BASIS,COMPONENT_BASIS
1431  TYPE(boundary_conditions_variable_type), POINTER :: BOUNDARY_CONDITIONS_VARIABLE
1432  TYPE(boundary_conditions_type), POINTER :: BOUNDARY_CONDITIONS
1433  TYPE(equations_type), POINTER :: EQUATIONS
1434  TYPE(equations_mapping_type), POINTER :: EQUATIONS_MAPPING
1435  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
1436  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
1437  TYPE(equations_matrices_rhs_type), POINTER :: RHS_VECTOR
1438  TYPE(field_type), POINTER :: DEPENDENT_FIELD,FIBRE_FIELD,GEOMETRIC_FIELD,MATERIALS_FIELD,EQUATIONS_SET_FIELD,SOURCE_FIELD
1439  TYPE(field_type), POINTER :: INDEPENDENT_FIELD
1440  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
1441  TYPE(quadrature_scheme_type), POINTER :: DEPENDENT_QUADRATURE_SCHEME,COMPONENT_QUADRATURE_SCHEME
1442  TYPE(field_interpolation_parameters_type), POINTER :: GEOMETRIC_INTERPOLATION_PARAMETERS, &
1443  & FIBRE_INTERPOLATION_PARAMETERS,MATERIALS_INTERPOLATION_PARAMETERS,DEPENDENT_INTERPOLATION_PARAMETERS, &
1444  & DARCY_DEPENDENT_INTERPOLATION_PARAMETERS,SOURCE_INTERPOLATION_PARAMETERS,DARCY_MATERIALS_INTERPOLATION_PARAMETERS, &
1445  & DENSITY_INTERPOLATION_PARAMETERS,INDEPENDENT_INTERPOLATION_PARAMETERS
1446  TYPE(field_interpolated_point_type), POINTER :: GEOMETRIC_INTERPOLATED_POINT,FIBRE_INTERPOLATED_POINT, &
1447  & MATERIALS_INTERPOLATED_POINT,DEPENDENT_INTERPOLATED_POINT,DARCY_DEPENDENT_INTERPOLATED_POINT,SOURCE_INTERPOLATED_POINT, &
1448  & DENSITY_INTERPOLATED_POINT,INDEPENDENT_INTERPOLATED_POINT,DARCY_MATERIALS_INTERPOLATED_POINT
1449  TYPE(field_interpolated_point_metrics_type), POINTER :: GEOMETRIC_INTERPOLATED_POINT_METRICS, &
1450  & DEPENDENT_INTERPOLATED_POINT_METRICS
1451  TYPE(basis_type), POINTER :: DEPENDENT_BASIS_1,GEOMETRIC_BASIS
1452  TYPE(decomposition_type), POINTER :: DECOMPOSITION
1453  TYPE(domain_mapping_type), POINTER :: DOMAIN_ELEMENT_MAPPING
1454  TYPE(varying_string) :: LOCAL_ERROR
1455  LOGICAL :: DARCY_DENSITY,DARCY_DEPENDENT
1456  INTEGER(INTG) :: component_idx,component_idx2,parameter_idx,gauss_idx,element_dof_idx,FIELD_VAR_TYPE,DARCY_FIELD_VAR_TYPE
1457  INTEGER(INTG) :: imatrix,Ncompartments
1458  INTEGER(INTG) :: i,j,numberOfXDimensions,numberOfXiDimensions
1459  INTEGER(INTG) :: NDOFS,mh,ms,mhs,mi,nh,ns
1460  INTEGER(INTG) :: DEPENDENT_NUMBER_OF_COMPONENTS
1461  INTEGER(INTG) :: NUMBER_OF_DIMENSIONS,NUMBER_OF_XI,HYDROSTATIC_PRESSURE_COMPONENT
1462  INTEGER(INTG) :: NUMBER_OF_FIELD_COMPONENT_INTERPOLATION_PARAMETERS
1463  INTEGER(INTG) :: DEPENDENT_COMPONENT_INTERPOLATION_TYPE
1464  INTEGER(INTG) :: DEPENDENT_NUMBER_OF_GAUSS_POINTS
1465  INTEGER(INTG) :: MESH_COMPONENT_1,MESH_COMPONENT_NUMBER
1466  INTEGER(INTG) :: TOTAL_NUMBER_OF_SURFACE_PRESSURE_CONDITIONS
1467  INTEGER(INTG) :: var1 ! Variable number corresponding to 'U' in single physics case
1468  INTEGER(INTG) :: var2 ! Variable number corresponding to 'DELUDLEN' in single physics case
1469  INTEGER(INTG), POINTER :: EQUATIONS_SET_FIELD_DATA(:)
1470  REAL(DP) :: DZDNU(3,3),DZDNUT(3,3),AZL(3,3),AZU(3,3),Fe(3,3),FeT(3,3),Fg(3,3),C(3,3),f(3,3),E(3,3),I3,P, &
1471  & piolaTensor(3,3),TEMP(3,3)
1472  REAL(DP) :: cauchyTensor(3,3),JGW_CAUCHY_TENSOR(3,3),kirchoffTensor(3,3),STRESS_TENSOR(6)
1473  REAL(DP) :: deformationGradientTensor(3,3),growthTensor(3,3),growthTensorInverse(3,3),growthTensorInverseTranspose(3,3), &
1474  & fibreGrowth,sheetGrowth,normalGrowth,fibreVector(3),sheetVector(3),normalVector(3)
1475  REAL(DP) :: dNudXi(3,3),dXidNu(3,3)
1476  REAL(DP) :: DFDZ(64,3,3) !temporary until a proper alternative is found
1477  REAL(DP) :: DPHIDZ(3,64,3) !temporary until a proper alternative is found
1478  REAL(DP) :: GAUSS_WEIGHT,Jznu,Jxxi,Jzxi,Je,Jg,JGW
1479  REAL(DP) :: SUM1,TEMPTERM1
1480  REAL(DP) :: THICKNESS ! for elastic membrane
1481  REAL(DP) :: DARCY_MASS_INCREASE,DARCY_VOL_INCREASE,DARCY_RHO_0_F,DENSITY !coupling with Darcy model
1482  REAL(DP) :: Mfact, bfact, p0fact
1483  INTEGER(INTG) :: EQUATIONS_SET_SUBTYPE
1484 
1485  enters("FiniteElasticity_FiniteElementResidualEvaluate",err,error,*999)
1486 
1487  NULLIFY(boundary_conditions,boundary_conditions_variable)
1488  NULLIFY(dependent_basis,component_basis)
1489  NULLIFY(equations,equations_mapping,equations_matrices,nonlinear_matrices,rhs_vector)
1490  NULLIFY(dependent_field,fibre_field,geometric_field,materials_field,source_field,independent_field)
1491  NULLIFY(field_variable)
1492  NULLIFY(dependent_quadrature_scheme,component_quadrature_scheme)
1493  NULLIFY(geometric_interpolation_parameters,fibre_interpolation_parameters,source_interpolation_parameters)
1494  NULLIFY(materials_interpolation_parameters,dependent_interpolation_parameters)
1495  NULLIFY(independent_interpolation_parameters,darcy_materials_interpolation_parameters)
1496  NULLIFY(darcy_dependent_interpolation_parameters,density_interpolation_parameters)
1497  NULLIFY(geometric_interpolated_point,fibre_interpolated_point,source_interpolated_point)
1498  NULLIFY(geometric_interpolated_point_metrics,dependent_interpolated_point_metrics)
1499  NULLIFY(materials_interpolated_point,dependent_interpolated_point,darcy_dependent_interpolated_point)
1500  NULLIFY(density_interpolated_point,independent_interpolated_point)
1501  NULLIFY(dependent_basis_1)
1502  NULLIFY(decomposition)
1503  NULLIFY(equations_set_field_data)
1504 
1505  IF(ASSOCIATED(equations_set)) THEN
1506  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
1507  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
1508  ELSE IF(SIZE(equations_set%SPECIFICATION,1)/=3) THEN
1509  CALL flagerror("Equations set specification must have three entries for a finite elasticity type equations set.", &
1510  & err,error,*999)
1511  END IF
1512  equations_set_subtype = equations_set%SPECIFICATION(3)
1513  equations=>equations_set%EQUATIONS
1514  IF(ASSOCIATED(equations)) THEN
1515  !Which variables are we working with - find the variable pair used for this equations set
1516  !\todo: put in checks for all the objects/mappings below (do we want to do this for every element?)
1517  var1=equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR%VARIABLE_NUMBER ! number for 'U'
1518  var2=equations%EQUATIONS_MAPPING%RHS_MAPPING%RHS_VARIABLE%VARIABLE_NUMBER ! number for 'DELUDELN'
1519 
1520  !Grab pointers: matrices, fields, decomposition, basis
1521  !\todo: see if we can separate this residual evaluation from the pressure boundary conditions somehow
1522  !so that the equations set doesn't need to maintain a pointer to the boundary conditions
1523  boundary_conditions=>equations_set%BOUNDARY_CONDITIONS
1524  CALL boundary_conditions_variable_get(boundary_conditions,equations_set%EQUATIONS%EQUATIONS_MAPPING%RHS_MAPPING% &
1525  & rhs_variable,boundary_conditions_variable,err,error,*999)
1526  total_number_of_surface_pressure_conditions=boundary_conditions_variable%DOF_COUNTS(boundary_condition_pressure)+ &
1527  & boundary_conditions_variable%DOF_COUNTS(boundary_condition_pressure_incremented)
1528 
1529  equations_matrices=>equations%EQUATIONS_MATRICES
1530  nonlinear_matrices=>equations_matrices%NONLINEAR_MATRICES
1531  rhs_vector=>equations_matrices%RHS_VECTOR
1532  equations_mapping =>equations%EQUATIONS_MAPPING
1533 
1534  fibre_field =>equations%INTERPOLATION%FIBRE_FIELD
1535  geometric_field =>equations%INTERPOLATION%GEOMETRIC_FIELD
1536  materials_field =>equations%INTERPOLATION%MATERIALS_FIELD
1537  dependent_field =>equations%INTERPOLATION%DEPENDENT_FIELD
1538  source_field =>equations%INTERPOLATION%SOURCE_FIELD
1539  independent_field=>equations%INTERPOLATION%INDEPENDENT_FIELD
1540 
1541  decomposition =>dependent_field%DECOMPOSITION
1542  mesh_component_number = decomposition%MESH_COMPONENT_NUMBER
1543 
1544  domain_element_mapping=>decomposition%DOMAIN(1)%PTR%MAPPINGS%ELEMENTS
1545 
1546  dependent_basis=>decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BASIS
1547  dependent_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
1548  dependent_number_of_gauss_points=dependent_quadrature_scheme%NUMBER_OF_GAUSS
1549  dependent_number_of_components=dependent_field%VARIABLES(var1)%NUMBER_OF_COMPONENTS
1550  geometric_basis=>geometric_field%DECOMPOSITION%DOMAIN(geometric_field%DECOMPOSITION%MESH_COMPONENT_NUMBER)%PTR% &
1551  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1552 
1553  number_of_dimensions=equations_set%REGION%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
1554  number_of_xi=decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BASIS%NUMBER_OF_XI
1555 
1556  !Initialise tensors and matrices
1557  CALL identitymatrix(dzdnu,err,error,*999)
1558  CALL identitymatrix(piolatensor,err,error,*999)
1559  CALL identitymatrix(cauchytensor,err,error,*999)
1560  dfdz=0.0_dp ! (parameter_idx,component_idx)
1561 
1562  !Set flags for coupled finite elasticity and Darcy problems
1563  !Check if we need Darcy materials field for Density
1564  IF(equations_set_subtype==equations_set_elasticity_fluid_pressure_static_inria_subtype .OR. &
1565  & equations_set_subtype==equations_set_elasticity_fluid_pressure_holmes_mow_subtype .OR. &
1566  & equations_set_subtype==equations_set_elasticity_fluid_pres_holmes_mow_active_subtype) THEN
1567  darcy_density=.true.
1568  ELSE
1569  darcy_density=.false.
1570  ENDIF
1571  !Check if we need Darcy dependent field
1572  IF(equations_set_subtype==equations_set_incompressible_finite_elasticity_darcy_subtype .OR. &
1573  & equations_set_subtype==equations_set_elasticity_darcy_inria_model_subtype .OR. &
1574  & equations_set_subtype==equations_set_incompressible_elasticity_driven_darcy_subtype .OR. &
1575  & equations_set_subtype==equations_set_elasticity_fluid_pressure_static_inria_subtype .OR. &
1576  & equations_set_subtype==equations_set_elasticity_fluid_pressure_holmes_mow_subtype .OR. &
1577  & equations_set_subtype==equations_set_elasticity_fluid_pres_holmes_mow_active_subtype) THEN
1578  darcy_dependent=.true.
1579  ELSE
1580  darcy_dependent=.false.
1581  ENDIF
1582 
1583  !Grab interpolation parameters
1584  field_variable=>equations_set%EQUATIONS%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR
1585  field_var_type=field_variable%VARIABLE_TYPE
1586  dependent_interpolation_parameters=>equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR
1587  geometric_interpolation_parameters=>equations%INTERPOLATION%GEOMETRIC_INTERP_PARAMETERS(field_u_variable_type)%PTR
1588  IF(ASSOCIATED(fibre_field)) THEN
1589  fibre_interpolation_parameters=>equations%INTERPOLATION%FIBRE_INTERP_PARAMETERS(field_u_variable_type)%PTR
1590  ENDIF
1591  IF(ASSOCIATED(materials_field)) THEN
1592  materials_interpolation_parameters=>equations%INTERPOLATION%MATERIALS_INTERP_PARAMETERS(field_u_variable_type)%PTR
1593 ! DENSITY_INTERPOLATION_PARAMETERS=>EQUATIONS%INTERPOLATION%MATERIALS_INTERP_PARAMETERS(FIELD_V_VARIABLE_TYPE)%PTR
1594  ENDIF
1595  IF(darcy_dependent) THEN
1596  darcy_dependent_interpolation_parameters=>equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_v_variable_type)%PTR
1597  ELSE IF(equations_set_subtype==equations_set_standard_monodomain_elasticity_subtype) THEN
1598  independent_interpolation_parameters=>equations%INTERPOLATION%INDEPENDENT_INTERP_PARAMETERS(field_u_variable_type)%PTR
1599  ENDIF
1600 ! IF(ASSOCIATED(SOURCE_FIELD)) THEN
1601 ! SOURCE_INTERPOLATION_PARAMETERS=>EQUATIONS%INTERPOLATION%SOURCE_INTERP_PARAMETERS(FIELD_U_VARIABLE_TYPE)%PTR
1602 ! ENDIF
1603 
1604  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
1605  & geometric_interpolation_parameters,err,error,*999)
1606  IF(ASSOCIATED(fibre_field)) THEN
1607  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
1608  & fibre_interpolation_parameters,err,error,*999)
1609  END IF
1610  IF(ASSOCIATED(materials_field)) THEN
1611  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
1612  & materials_interpolation_parameters,err,error,*999)
1613 ! IF(ASSOCIATED(DENSITY_INTERPOLATION_PARAMETERS)) THEN
1614 ! CALL FIELD_INTERPOLATION_PARAMETERS_ELEMENT_GET(FIELD_VALUES_SET_TYPE,ELEMENT_NUMBER, &
1615 ! & DENSITY_INTERPOLATION_PARAMETERS,ERR,ERROR,*999)
1616 ! ENDIF
1617  ENDIF
1618  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
1619  & dependent_interpolation_parameters,err,error,*999)
1620  IF(darcy_dependent) THEN
1621  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
1622  & darcy_dependent_interpolation_parameters,err,error,*999)
1623  ELSE IF(equations_set_subtype==equations_set_standard_monodomain_elasticity_subtype) THEN
1624  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
1625  & independent_interpolation_parameters,err,error,*999)
1626  ENDIF
1627 ! IF(ASSOCIATED(SOURCE_FIELD)) THEN
1628 ! CALL FIELD_INTERPOLATION_PARAMETERS_ELEMENT_GET(FIELD_VALUES_SET_TYPE,ELEMENT_NUMBER, &
1629 ! & SOURCE_INTERPOLATION_PARAMETERS,ERR,ERROR,*999)
1630 ! END IF
1631 
1632  !Point interpolation pointer
1633  geometric_interpolated_point=>equations%INTERPOLATION%GEOMETRIC_INTERP_POINT(field_u_variable_type)%PTR
1634  geometric_interpolated_point_metrics=>equations%INTERPOLATION%GEOMETRIC_INTERP_POINT_METRICS(field_u_variable_type)%PTR
1635  IF(ASSOCIATED(fibre_field)) THEN
1636  fibre_interpolated_point=>equations%INTERPOLATION%FIBRE_INTERP_POINT(field_u_variable_type)%PTR
1637  END IF
1638  IF(ASSOCIATED(materials_field)) THEN
1639  materials_interpolated_point=>equations%INTERPOLATION%MATERIALS_INTERP_POINT(field_u_variable_type)%PTR
1640  density_interpolated_point=>equations%INTERPOLATION%MATERIALS_INTERP_POINT(field_v_variable_type)%PTR
1641  ENDIF
1642  dependent_interpolated_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(field_var_type)%PTR
1643  dependent_interpolated_point_metrics=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT_METRICS(field_var_type)%PTR
1644  IF(darcy_dependent) THEN
1645  darcy_dependent_interpolated_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(field_v_variable_type)%PTR
1646  ELSE IF(equations_set_subtype==equations_set_standard_monodomain_elasticity_subtype) THEN
1647  independent_interpolated_point=>equations%INTERPOLATION%INDEPENDENT_INTERP_POINT(field_u_variable_type)%PTR
1648  ENDIF
1649  IF(ASSOCIATED(source_field)) THEN
1650  source_interpolated_point=>equations%INTERPOLATION%SOURCE_INTERP_POINT(field_u_variable_type)%PTR
1651  ENDIF
1652 
1653  !SELECT: Compressible or incompressible cases, or poro multicompartment
1654  SELECT CASE(equations_set_subtype)
1655  ! ---------------------------------------------------------------
1656  CASE(equations_set_mooney_rivlin_activecontraction_subtype,equations_set_mooney_rivlin_subtype)
1657 ! CASE(EQUATIONS_SET_MOONEY_RIVLIN_ACTIVECONTRACTION_SUBTYPE,EQUATIONS_SET_MOONEY_RIVLIN_SUBTYPE, &
1658 ! & EQUATIONS_SET_TRANSVERSE_ISOTROPIC_GUCCIONE_SUBTYPE,EQUATIONS_SET_GUCCIONE_ACTIVECONTRACTION_SUBTYPE) ! 4 dependent components
1659  !Loop over gauss points and add residuals
1660  DO gauss_idx=1,dependent_number_of_gauss_points
1661  !Interpolate dependent, geometric, fibre and materials fields
1662  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1663  & dependent_interpolated_point,err,error,*999)
1664  CALL field_interpolated_point_metrics_calculate(dependent_basis%NUMBER_OF_XI,dependent_interpolated_point_metrics, &
1665  & err,error,*999)
1666  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1667  & geometric_interpolated_point,err,error,*999)
1668  CALL field_interpolated_point_metrics_calculate(geometric_basis%NUMBER_OF_XI,geometric_interpolated_point_metrics, &
1669  & err,error,*999)
1670  IF(ASSOCIATED(fibre_field)) THEN
1671  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1672  & fibre_interpolated_point,err,error,*999)
1673  END IF
1674  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1675  & materials_interpolated_point,err,error,*999)
1676 
1677  !Loop over geometric dependent basis functions.
1678  DO nh=1,number_of_dimensions
1679  mesh_component_number=field_variable%COMPONENTS(nh)%MESH_COMPONENT_NUMBER
1680  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
1681  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1682  component_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
1683  DO ns=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1684  !Loop over derivative directions.
1685  DO mh=1,number_of_dimensions
1686  sum1=0.0_dp
1687  DO mi=1,number_of_xi
1688  sum1=sum1+dependent_interpolated_point_metrics%DXI_DX(mi,mh)* &
1689  & component_quadrature_scheme%GAUSS_BASIS_FNS(ns,partial_derivative_first_derivative_map(mi),gauss_idx)
1690  ENDDO !mi
1691  dphidz(mh,ns,nh)=sum1
1692  ENDDO !mh
1693  ENDDO !ns
1694  ENDDO !nh
1695 
1696  CALL finiteelasticity_gaussdeformationgradienttensor(dependent_interpolated_point_metrics, &
1697  & geometric_interpolated_point_metrics,fibre_interpolated_point,dzdnu,err,error,*999)
1698 
1699  jznu=dependent_interpolated_point_metrics%JACOBIAN/geometric_interpolated_point_metrics%JACOBIAN
1700  jgw=dependent_interpolated_point_metrics%JACOBIAN*dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
1701 
1702  !Calculate the Cauchy stress tensor (in Voigt form) at the gauss point.
1703  CALL finite_elasticity_gauss_stress_tensor(equations_set,dependent_interpolated_point, &
1704  & materials_interpolated_point,stress_tensor,dzdnu,jznu,element_number,gauss_idx,err,error,*999)
1705 
1706  ! Convert from Voigt form to tensor form and multiply with Jacobian and Gauss weight.
1707  DO nh=1,number_of_dimensions
1708  DO mh=1,number_of_dimensions
1709  jgw_cauchy_tensor(mh,nh)=jgw*stress_tensor(tensor_to_voigt3(mh,nh))
1710  ENDDO
1711  ENDDO
1712 
1713  !Now add up the residual terms
1714  mhs=0
1715  DO mh=1,number_of_dimensions
1716  mesh_component_number=field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
1717  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
1718  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1719  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1720  mhs=mhs+1
1721  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+ &
1722  & dot_product(dphidz(:,ms,mh),jgw_cauchy_tensor(:,mh))
1723  ENDDO !ms
1724  ENDDO !mh
1725 
1726  jgw=geometric_interpolated_point_metrics%JACOBIAN*dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
1727 
1728  !Hydrostatic pressure component
1729  mesh_component_number=field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
1730  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
1731  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1732  component_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
1733  tempterm1=jgw*(jznu-1.0_dp)
1734  IF(field_variable%COMPONENTS(mh)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN !node based
1735  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1736  mhs=mhs+1
1737  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+ &
1738  & tempterm1*component_quadrature_scheme%GAUSS_BASIS_FNS(ms,no_part_deriv,gauss_idx)
1739  ENDDO
1740  ELSEIF(field_variable%COMPONENTS(mh)%INTERPOLATION_TYPE==field_element_based_interpolation) THEN !element based
1741  mhs=mhs+1
1742  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+tempterm1
1743  ENDIF
1744 
1745 ! !Gravity loading term
1746 ! IF(RHS_VECTOR%UPDATE_VECTOR) THEN
1747 ! IF(ASSOCIATED(SOURCE_FIELD)) THEN
1748 ! CALL FIELD_INTERPOLATE_GAUSS(NO_PART_DERIV,BASIS_DEFAULT_QUADRATURE_SCHEME,gauss_idx, &
1749 ! & SOURCE_INTERPOLATED_POINT,ERR,ERROR,*999)
1750 ! IF(ASSOCIATED(DENSITY_INTERPOLATED_POINT)) THEN
1751 ! CALL FIELD_INTERPOLATE_GAUSS(NO_PART_DERIV,BASIS_DEFAULT_QUADRATURE_SCHEME,gauss_idx, &
1752 ! & DENSITY_INTERPOLATED_POINT,ERR,ERROR,*999)
1753 ! DENSITY=DENSITY_INTERPOLATED_POINT%VALUES(1,NO_PART_DERIV)
1754 ! mhs=0
1755 ! DO mh=1,NUMBER_OF_DIMENSIONS
1756 ! MESH_COMPONENT_NUMBER=FIELD_VARIABLE%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
1757 ! DEPENDENT_BASIS=>DEPENDENT_FIELD%DECOMPOSITION%DOMAIN(MESH_COMPONENT_NUMBER)%PTR% &
1758 ! & TOPOLOGY%ELEMENTS%ELEMENTS(ELEMENT_NUMBER)%BASIS
1759 ! COMPONENT_QUADRATURE_SCHEME=>DEPENDENT_BASIS%QUADRATURE%QUADRATURE_SCHEME_MAP( &
1760 ! & BASIS_DEFAULT_QUADRATURE_SCHEME)%PTR
1761 ! G_DENSITY_JGW=SOURCE_INTERPOLATED_POINT%VALUES(mh,NO_PART_DERIV)*DENSITY*JGW
1762 ! DO ms=1,DEPENDENT_BASIS%NUMBER_OF_ELEMENT_PARAMETERS
1763 ! mhs=mhs+1
1764 ! RHS_VECTOR%ELEMENT_VECTOR%VECTOR(mhs)=RHS_VECTOR%ELEMENT_VECTOR%VECTOR(mhs)+ &
1765 ! & G_DENSITY_JGW*COMPONENT_QUADRATURE_SCHEME%GAUSS_BASIS_FNS(ms,NO_PART_DERIV,gauss_idx)
1766 ! ENDDO
1767 ! ENDDO
1768 ! ENDIF
1769 ! ENDIF
1770 ! ENDIF
1771  ENDDO !gauss_idx
1772 
1773 
1774  !Call surface pressure term here: should only be executed if THIS element has surface pressure on it (direct or incremented)
1775  IF(decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BOUNDARY_ELEMENT.AND. &
1776  & total_number_of_surface_pressure_conditions>0) THEN !
1777  CALL finiteelasticity_surfacepressureresidualevaluate(equations_set,element_number,var1,var2,err,error,*999)
1778  ENDIF
1779 
1780  !Scale factor adjustment
1781  IF(dependent_field%SCALINGS%SCALING_TYPE/=field_no_scaling) THEN
1782  ! Following function is necessary, otherwise wrong face scale factors from function call to surface pressure residual are
1783  ! used.
1784  CALL field_interpolationparametersscalefactorselementget(element_number, &
1785  & dependent_interpolation_parameters,err,error,*999)
1786  mhs=0
1787  DO mh=1,number_of_dimensions
1788  mesh_component_number=field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
1789  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
1790  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1791  !Loop over residual vector
1792  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1793  mhs=mhs+1
1794  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)* &
1795  & dependent_interpolation_parameters%SCALE_FACTORS(ms,mh)
1796  ENDDO !ms
1797  ENDDO !mh
1798  IF(field_variable%COMPONENTS(mh)%INTERPOLATION_TYPE==field_node_based_interpolation) THEN !node based
1799  mesh_component_number=field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
1800  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
1801  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1802  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1803  mhs=mhs+1
1804  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)* &
1805  & dependent_interpolation_parameters%SCALE_FACTORS(ms,mh)
1806  ENDDO
1807  ENDIF
1808  ENDIF
1809 
1810  ! ---------------------------------------------------------------
1811  CASE(equations_set_no_subtype,equations_set_membrane_subtype, &
1812  & equations_set_stvenant_kirchoff_activecontraction_subtype, &
1813  & equations_set_isotropic_exponential_subtype, &
1814  & equations_set_transverse_isotropic_exponential_subtype, &
1815  & equations_set_transverse_isotropic_guccione_subtype,equations_set_guccione_activecontraction_subtype, &
1816  & equations_set_orthotropic_material_costa_subtype, equations_set_activecontraction_subtype, &
1817  & equations_set_incompressible_finite_elasticity_darcy_subtype,equations_set_standard_monodomain_elasticity_subtype, &
1818  & equations_set_orthotropic_material_holzapfel_ogden_subtype,equations_set_1d3d_monodomain_elasticity_subtype, &
1819  & equations_set_monodomain_elasticity_w_titin_subtype,equations_set_monodomain_elasticity_velocity_subtype, &
1820  & equations_set_active_strain_subtype,equations_set_multiscale_active_strain_subtype, &
1821  & equations_set_1d3d_monodomain_active_strain_subtype, &
1822  & equations_set_incompressible_elasticity_driven_darcy_subtype,equations_set_transverse_isotropic_polynomial_subtype, &
1823  & equations_set_transverse_isotropic_humphrey_yin_subtype, &
1824  & equations_set_transverse_isotropic_active_subtype,equations_set_trans_isotropic_active_transition_subtype, &
1825  & equations_set_anisotropic_polynomial_subtype,equations_set_anisotropic_polynomial_active_subtype, &
1826  & equations_set_incompressible_mooney_rivlin_subtype, equations_set_holzapfel_ogden_activecontraction_subtype) ! 4 dependent components
1827 
1828  !Loop over gauss points and add residuals
1829  DO gauss_idx=1,dependent_number_of_gauss_points
1830  gauss_weight=dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
1831  !Interpolate dependent, geometric, fibre and materials fields
1832  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1833  & dependent_interpolated_point,err,error,*999)
1834  CALL field_interpolated_point_metrics_calculate(dependent_basis%NUMBER_OF_XI,dependent_interpolated_point_metrics, &
1835  & err,error,*999)
1836  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1837  & geometric_interpolated_point,err,error,*999)
1838  CALL field_interpolated_point_metrics_calculate(geometric_basis%NUMBER_OF_XI,geometric_interpolated_point_metrics, &
1839  & err,error,*999)
1840  IF(ASSOCIATED(fibre_field)) THEN
1841  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1842  & fibre_interpolated_point,err,error,*999)
1843  END IF
1844  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1845  & materials_interpolated_point,err,error,*999)
1846  IF(darcy_dependent) THEN
1847  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1848  & darcy_dependent_interpolated_point,err,error,*999)
1849  ELSE IF(equations_set_subtype==equations_set_standard_monodomain_elasticity_subtype) THEN
1850  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1851  & independent_interpolated_point,err,error,*999)
1852  ENDIF
1853 
1854  !Calculate F=dZ/dNU, the deformation gradient tensor at the gauss point
1855  CALL finiteelasticity_gaussdeformationgradienttensor(dependent_interpolated_point_metrics, &
1856  & geometric_interpolated_point_metrics,fibre_interpolated_point,dzdnu,err,error,*999)
1857  jznu=determinant(dzdnu,err,error)
1858  IF(jznu<0.0_dp) THEN
1859  local_error = "Warning: Volume is negative for gauss point "//trim(number_to_vstring(gauss_idx,"*",err,error))//&
1860  & " element "//trim(number_to_vstring(element_number,"*",err,error))
1861  CALL flagwarning(local_error,err,error,*999)
1862  local_error = "DET(F) = "//trim(number_to_vstring(jznu,"*",err,error))
1863  CALL flagwarning(local_error,err,error,*999)
1864  ENDIF
1865 
1866  jzxi=dependent_interpolated_point_metrics%JACOBIAN
1867  jxxi=geometric_interpolated_point_metrics%JACOBIAN
1868 
1869  IF(diagnostics1) THEN
1870  CALL write_string_value(diagnostic_output_type," ELEMENT_NUMBER = ",element_number,err,error,*999)
1871  CALL write_string_value(diagnostic_output_type," gauss_idx = ",gauss_idx,err,error,*999)
1872  ENDIF
1873 
1874  !Calculate Jacobian of deformation.
1875  CALL finiteelasticity_gaussgrowthtensor(equations_set,number_of_dimensions,gauss_idx,element_number,dependent_field, &
1876  & dzdnu,fg,fe,jg,je,err,error,*999)
1877 
1878  !Calculate strain tensors
1879  CALL finiteelasticity_straintensor(fe,c,f,jznu,e,err,error,*999)
1880 
1881  !Calculate Sigma=1/Jznu.FTF', the Cauchy stress tensor at the gauss point
1882  CALL finite_elasticity_gauss_cauchy_tensor(equations_set,dependent_interpolated_point, &
1883  & materials_interpolated_point,darcy_dependent_interpolated_point, &
1884  & independent_interpolated_point,cauchytensor,jznu,dzdnu,element_number,gauss_idx,err,error,*999)
1885 
1886  IF(diagnostics1) THEN
1887  CALL writestring(diagnostic_output_type,"",err,error,*999)
1888  CALL writestring(diagnostic_output_type,"Stress tensors:",err,error,*999)
1889  CALL writestringvalue(diagnostic_output_type," Hydrostatic pressure = ",p,err,error,*999)
1890  CALL writestring(diagnostic_output_type," Second Piola-Kirchoff stress tensor:",err,error,*999)
1891  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
1892  & 3,3,piolatensor,write_string_matrix_name_and_indices, '(" T','(",I1,",:)',' :",3(X,E13.6))', &
1893  & '(12X,3(X,E13.6))',err,error,*999)
1894  CALL writestring(diagnostic_output_type," Cauchy stress tensor:",err,error,*999)
1895  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
1896  & 3,3,cauchytensor,write_string_matrix_name_and_indices,'(" sigma','(",I1,",:)',' :",3(X,E13.6))', &
1897  & '(12X,3(X,E13.6))',err,error,*999)
1898  ENDIF
1899 
1900  IF(equations_set_subtype==equations_set_incompressible_elasticity_driven_darcy_subtype) THEN
1901  !Parameters settings for coupled elasticity Darcy INRIA model:
1902  CALL get_darcy_finite_elasticity_parameters(darcy_rho_0_f,mfact,bfact,p0fact,err,error,*999)
1903  darcy_mass_increase = darcy_dependent_interpolated_point%VALUES(4,no_part_deriv)
1904  darcy_vol_increase = darcy_mass_increase / darcy_rho_0_f
1905  ENDIF
1906 
1907  !For membrane theory in 3D space, the final equation is multiplied by thickness. Default to unit thickness if equation set subtype is not membrane
1908  thickness = 1.0_dp
1909  IF(equations_set_subtype == equations_set_membrane_subtype) THEN
1910  IF(number_of_dimensions == 3) THEN
1911  thickness = materials_interpolated_point%VALUES(materials_interpolated_point%INTERPOLATION_PARAMETERS% &
1912  & field_variable%NUMBER_OF_COMPONENTS,1)
1913  ENDIF
1914  ENDIF
1915 
1916  !Calculate the combined Jacobian
1917  jgw=jzxi*dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
1918 
1919  !Loop over geometric dependent basis functions and evaluate dPhidZ.
1920  DO nh=1,number_of_dimensions
1921  mesh_component_number=field_variable%COMPONENTS(nh)%MESH_COMPONENT_NUMBER
1922  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%ptr% &
1923  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1924  component_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%ptr
1925  DO ns=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1926  !Loop over derivative directions.
1927  DO mh=1,number_of_dimensions
1928  sum1=0.0_dp
1929  DO mi=1,number_of_xi
1930  sum1=sum1+dependent_interpolated_point_metrics%DXI_DX(mi,mh)* &
1931  & component_quadrature_scheme%GAUSS_BASIS_FNS(ns,partial_derivative_first_derivative_map(mi),gauss_idx)
1932  ENDDO !mi
1933  dphidz(mh,ns,nh)=sum1
1934  ENDDO !mh
1935  ENDDO !ns
1936  ENDDO !nh
1937 
1938  !Now add up the residual terms
1939  mhs=0
1940  DO mh=1,number_of_dimensions
1941  mesh_component_number=field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
1942  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%ptr% &
1943  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1944  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
1945  mhs=mhs+1
1946  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+ &
1947  & jgw*dot_product(dphidz(1:number_of_dimensions,ms,mh),cauchytensor(1:number_of_dimensions,mh))
1948  ENDDO !ms
1949  ENDDO !mh
1950 
1951  !Hydrostatic pressure component (skip for membrane problems)
1952  IF (equations_set_subtype /= equations_set_membrane_subtype) THEN
1953  hydrostatic_pressure_component=dependent_field%VARIABLES(var1)%NUMBER_OF_COMPONENTS
1954  dependent_component_interpolation_type=dependent_field%VARIABLES(var1)%COMPONENTS(hydrostatic_pressure_component)% &
1955  & interpolation_type
1956  IF(equations_set_subtype==equations_set_incompressible_elasticity_driven_darcy_subtype) THEN
1957  tempterm1=gauss_weight*(jzxi-(jg-darcy_vol_increase)*jxxi)
1958  ELSE
1959  tempterm1=gauss_weight*(jzxi/jxxi - 1.0_dp)*jxxi
1960  ENDIF
1961  IF(dependent_component_interpolation_type==field_node_based_interpolation) THEN !node based
1962  component_basis=>dependent_field%VARIABLES(var1)%COMPONENTS(hydrostatic_pressure_component)%DOMAIN% &
1963  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
1964  component_quadrature_scheme=>component_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%ptr
1965  number_of_field_component_interpolation_parameters=component_basis%NUMBER_OF_ELEMENT_PARAMETERS
1966  DO parameter_idx=1,number_of_field_component_interpolation_parameters
1967  mhs=mhs+1
1968  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+ &
1969  & component_quadrature_scheme%GAUSS_BASIS_FNS(parameter_idx,1,gauss_idx)*tempterm1
1970  ENDDO
1971  ELSEIF(dependent_component_interpolation_type==field_element_based_interpolation) THEN !element based
1972  mhs=mhs+1
1973  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+ tempterm1
1974  ENDIF
1975  ENDIF
1976  ENDDO !gauss_idx
1977 
1978  !Call surface pressure term here: should only be executed if THIS element has surface pressure on it (direct or incremented)
1979  IF(decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BOUNDARY_ELEMENT.AND. &
1980  & total_number_of_surface_pressure_conditions>0) THEN !
1981  CALL finiteelasticity_surfacepressureresidualevaluate(equations_set,element_number,var1,var2,err,error,*999)
1982  ENDIF
1983 
1984  ! ---------------------------------------------------------------
1985  CASE(equations_set_constitutive_law_in_cellml_evaluate_subtype, &
1986  & equations_set_constitutive_and_growth_law_in_cellml_subtype)
1987 
1988  !Loop over gauss points and add residuals
1989  DO gauss_idx=1,dependent_number_of_gauss_points
1990 
1991  IF(diagnostics1) THEN
1992  CALL writestringvalue(diagnostic_output_type," Element number = ",element_number,err,error,*999)
1993  CALL writestringvalue(diagnostic_output_type," Gauss index = ",gauss_idx,err,error,*999)
1994  ENDIF
1995 
1996  gauss_weight=dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
1997  !Interpolate dependent, geometric, fibre and materials fields
1998  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
1999  & dependent_interpolated_point,err,error,*999)
2000  CALL field_interpolatedpointmetricscalculate(dependent_basis%NUMBER_OF_XI,dependent_interpolated_point_metrics, &
2001  & err,error,*999)
2002  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2003  & geometric_interpolated_point,err,error,*999)
2004  CALL field_interpolatedpointmetricscalculate(geometric_basis%NUMBER_OF_XI,geometric_interpolated_point_metrics, &
2005  & err,error,*999)
2006  IF(ASSOCIATED(fibre_field)) THEN
2007  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2008  & fibre_interpolated_point,err,error,*999)
2009  ENDIF
2010 
2011  !Calculate F=dZ/dNU, the deformation gradient tensor at the gauss point
2012  CALL finiteelasticity_gaussdeformationgradienttensor(dependent_interpolated_point_metrics, &
2013  & geometric_interpolated_point_metrics,fibre_interpolated_point,dzdnu,err,error,*999)
2014 
2015  jxxi=geometric_interpolated_point_metrics%JACOBIAN
2016 
2017  jzxi=dependent_interpolated_point_metrics%JACOBIAN
2018 
2019  hydrostatic_pressure_component=dependent_interpolated_point%INTERPOLATION_PARAMETERS%FIELD_VARIABLE% &
2020  & number_of_components
2021  p=dependent_interpolated_point%VALUES(hydrostatic_pressure_component,1)
2022 
2023  CALL finiteelasticity_gaussgrowthtensor(equations_set,number_of_dimensions,gauss_idx,element_number,dependent_field, &
2024  & dzdnu,fg,fe,jg,je,err,error,*999)
2025 
2026  CALL finiteelasticity_straintensor(fe,c,f,jznu,e,err,error,*999)
2027 
2028  !Get the stress field!!!
2029  IF(number_of_dimensions==3) THEN
2030  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2031  & gauss_idx,element_number,1,piolatensor(1,1),err,error,*999)
2032  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2033  & gauss_idx,element_number,2,piolatensor(1,2),err,error,*999)
2034  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2035  & gauss_idx,element_number,3,piolatensor(1,3),err,error,*999)
2036  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2037  & gauss_idx,element_number,4,piolatensor(2,2),err,error,*999)
2038  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2039  & gauss_idx,element_number,5,piolatensor(2,3),err,error,*999)
2040  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2041  & gauss_idx,element_number,6,piolatensor(3,3),err,error,*999)
2042  !CellML computes the deviatoric stress. Add the volumetric component!
2043  piolatensor(1,1)=piolatensor(1,1)+p*f(1,1)
2044  piolatensor(2,2)=piolatensor(2,2)+p*f(2,2)
2045  piolatensor(3,3)=piolatensor(3,3)+p*f(3,3)
2046  piolatensor(1,2)=piolatensor(1,2)+p*f(1,2)
2047  piolatensor(1,3)=piolatensor(1,3)+p*f(1,3)
2048  piolatensor(2,3)=piolatensor(2,3)+p*f(2,3)
2049  piolatensor(2,1)=piolatensor(1,2)
2050  piolatensor(3,1)=piolatensor(1,3)
2051  piolatensor(3,2)=piolatensor(2,3)
2052  ELSE IF(number_of_dimensions==2) THEN
2053  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2054  & gauss_idx,element_number,1,piolatensor(1,1),err,error,*999)
2055  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2056  & gauss_idx,element_number,2,piolatensor(1,2),err,error,*999)
2057  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2058  & gauss_idx,element_number,3,piolatensor(2,2),err,error,*999)
2059  !CellML computes the deviatoric stress. Add the volumetric component!
2060  piolatensor(1,1)=piolatensor(1,1)+p*f(1,1)
2061  piolatensor(2,2)=piolatensor(2,2)+p*f(2,2)
2062  piolatensor(1,2)=piolatensor(1,2)+p*f(1,2)
2063  piolatensor(2,1)=piolatensor(1,2)
2064  ELSE
2065  CALL field_parametersetgetlocalgausspoint(dependent_field,field_u2_variable_type,field_values_set_type, &
2066  & gauss_idx,element_number,1,piolatensor(1,1),err,error,*999)
2067  piolatensor(1,1)=piolatensor(1,1)+p*f(1,1)
2068  ENDIF
2069 
2070  !Compute the Kirchoff stress tensor by pushing the 2nd Piola Kirchoff stress tensor forward \tau = F.S.F^T
2071  CALL matrixproduct(fe,piolatensor,temp,err,error,*999)
2072  CALL matrixproducttranspose(temp,fe,kirchofftensor,err,error,*999)
2073 
2074  !Calculate the Cauchy stress tensor
2075  cauchytensor=kirchofftensor/je
2076 
2077  IF(diagnostics1) THEN
2078  CALL writestring(diagnostic_output_type,"",err,error,*999)
2079  CALL writestring(diagnostic_output_type,"Stress tensors:",err,error,*999)
2080  CALL writestringvalue(diagnostic_output_type," Hydrostatic pressure = ",p,err,error,*999)
2081  CALL writestring(diagnostic_output_type," Second Piola-Kirchoff stress tensor:",err,error,*999)
2082  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
2083  & 3,3,piolatensor,write_string_matrix_name_and_indices, '(" T','(",I1,",:)',' :",3(X,E13.6))', &
2084  & '(12X,3(X,E13.6))',err,error,*999)
2085  CALL writestring(diagnostic_output_type," Cauchy stress tensor:",err,error,*999)
2086  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
2087  & 3,3,cauchytensor,write_string_matrix_name_and_indices,'(" sigma','(",I1,",:)',' :",3(X,E13.6))', &
2088  & '(12X,3(X,E13.6))',err,error,*999)
2089  ENDIF
2090 
2091  !Calculate dPhi/dZ at the gauss point, Phi is the basis function
2092  !CALL FINITE_ELASTICITY_GAUSS_DFDZ(DEPENDENT_INTERPOLATED_POINT,ELEMENT_NUMBER,gauss_idx,NUMBER_OF_DIMENSIONS, &
2093  ! & NUMBER_OF_XI,DFDZ,ERR,ERROR,*999)
2094 
2095  !For membrane theory in 3D space, the final equation is multiplied by thickness. Default to unit thickness if equation set subtype is not membrane
2096  !!TODO Maybe have the thickness as a component in the equations set field. Yes, as we don't need a materials field for CellML constituative laws.
2097  thickness = 1.0_dp
2098  IF(equations_set_subtype == equations_set_membrane_subtype) THEN
2099  IF(number_of_dimensions == 3) THEN
2100  IF(ASSOCIATED(materials_field)) THEN
2101  CALL field_interpolategauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2102  & materials_interpolated_point,err,error,*999)
2103  thickness = materials_interpolated_point%VALUES(materials_interpolated_point%INTERPOLATION_PARAMETERS% &
2104  & field_variable%NUMBER_OF_COMPONENTS,1)
2105  ENDIF
2106  ENDIF
2107  ENDIF
2108 
2109  !!Now add up the residual terms
2110  !element_dof_idx=0
2111  !DO component_idx=1,NUMBER_OF_DIMENSIONS
2112  ! DEPENDENT_COMPONENT_INTERPOLATION_TYPE=DEPENDENT_FIELD%VARIABLES(var1)%COMPONENTS(component_idx)%INTERPOLATION_TYPE
2113  ! IF(DEPENDENT_COMPONENT_INTERPOLATION_TYPE==FIELD_NODE_BASED_INTERPOLATION) THEN !node based
2114  ! DEPENDENT_BASIS=>DEPENDENT_FIELD%VARIABLES(var1)%COMPONENTS(component_idx)%DOMAIN%TOPOLOGY% &
2115  ! & ELEMENTS%ELEMENTS(ELEMENT_NUMBER)%BASIS
2116  ! NUMBER_OF_FIELD_COMPONENT_INTERPOLATION_PARAMETERS=DEPENDENT_BASIS%NUMBER_OF_ELEMENT_PARAMETERS
2117  ! DO parameter_idx=1,NUMBER_OF_FIELD_COMPONENT_INTERPOLATION_PARAMETERS
2118  ! element_dof_idx=element_dof_idx+1
2119  ! DO component_idx2=1,NUMBER_OF_DIMENSIONS
2120  ! NONLINEAR_MATRICES%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2121  ! & NONLINEAR_MATRICES%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ &
2122  ! & GAUSS_WEIGHT*Jzxi*THICKNESS*cauchyTensor(component_idx,component_idx2)* &
2123  ! & DFDZ(parameter_idx,component_idx2,component_idx)
2124  ! ENDDO ! component_idx2 (inner component index)
2125  ! ENDDO ! parameter_idx (residual vector loop)
2126  ! ELSEIF(DEPENDENT_COMPONENT_INTERPOLATION_TYPE==FIELD_ELEMENT_BASED_INTERPOLATION) THEN
2127  ! !Will probably never be used
2128  ! CALL FlagError("Finite elasticity with element based interpolation is not implemented.",ERR,ERROR,*999)
2129  ! ENDIF
2130  !ENDDO ! component_idx
2131 
2132  !Loop over geometric dependent basis functions.
2133  DO nh=1,number_of_dimensions
2134  mesh_component_number=field_variable%COMPONENTS(nh)%MESH_COMPONENT_NUMBER
2135  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
2136  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
2137  component_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
2138  DO ns=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
2139  !Loop over derivative directions.
2140  DO mh=1,number_of_dimensions
2141  sum1=0.0_dp
2142  DO mi=1,number_of_xi
2143  sum1=sum1+dependent_interpolated_point_metrics%DXI_DX(mi,mh)* &
2144  & component_quadrature_scheme%GAUSS_BASIS_FNS(ns,partial_derivative_first_derivative_map(mi),gauss_idx)
2145  ENDDO !mi
2146  dphidz(mh,ns,nh)=sum1
2147  ENDDO !mh
2148  ENDDO !ns
2149  ENDDO !nh
2150  jgw=jzxi*dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
2151  !Now add up the residual terms
2152  mhs=0
2153  DO mh=1,number_of_dimensions
2154  mesh_component_number=field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
2155  dependent_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
2156  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
2157  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
2158  mhs=mhs+1
2159  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+ &
2160  & jgw*dot_product(dphidz(:,ms,mh),cauchytensor(:,mh))
2161  ENDDO !ms
2162  ENDDO !mh
2163 
2164  !Hydrostatic pressure component (skip for membrane problems)
2165  IF (equations_set_subtype /= equations_set_membrane_subtype) THEN
2166  hydrostatic_pressure_component=dependent_field%VARIABLES(var1)%NUMBER_OF_COMPONENTS
2167  dependent_component_interpolation_type=dependent_field%VARIABLES(var1)%COMPONENTS(hydrostatic_pressure_component)% &
2168  & interpolation_type
2169  IF(equations_set_subtype==equations_set_incompressible_elasticity_driven_darcy_subtype) THEN
2170  tempterm1=gauss_weight*(jzxi-(jg-darcy_vol_increase)*jxxi)
2171  ELSE
2172  tempterm1=gauss_weight*(jzxi-jg*jxxi)
2173  ENDIF
2174  IF(dependent_component_interpolation_type==field_node_based_interpolation) THEN !node based
2175  component_basis=>dependent_field%VARIABLES(var1)%COMPONENTS(hydrostatic_pressure_component)%DOMAIN% &
2176  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
2177  component_quadrature_scheme=>component_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
2178  number_of_field_component_interpolation_parameters=component_basis%NUMBER_OF_ELEMENT_PARAMETERS
2179  DO parameter_idx=1,number_of_field_component_interpolation_parameters
2180  element_dof_idx=element_dof_idx+1
2181  IF(equations_set_subtype==equations_set_incompressible_elasticity_driven_darcy_subtype) THEN
2182  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2183  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ &
2184  & gauss_weight*jzxi*component_quadrature_scheme%GAUSS_BASIS_FNS(parameter_idx,1,gauss_idx)* &
2185  & (je-1.0_dp-darcy_vol_increase)
2186  ELSE
2187  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2188  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ &
2189  & gauss_weight*jzxi*component_quadrature_scheme%GAUSS_BASIS_FNS(parameter_idx,1,gauss_idx)* &
2190  & (je-1.0_dp)
2191  ENDIF
2192  ENDDO
2193  ELSEIF(dependent_component_interpolation_type==field_element_based_interpolation) THEN !element based
2194  mhs=mhs+1
2195  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)= &
2196  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)+tempterm1
2197  ENDIF
2198  ENDIF
2199  ENDDO !gauss_idx
2200 
2201  !Call surface pressure term here: should only be executed if THIS element has surface pressure on it (direct or incremented)
2202  IF(decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BOUNDARY_ELEMENT.AND. &
2203  & total_number_of_surface_pressure_conditions>0) THEN !
2204  CALL finiteelasticity_surfacepressureresidualevaluate(equations_set,element_number,var1,var2,err,error,*999)
2205  ENDIF
2206 
2207  ! ---------------------------------------------------------------
2208  CASE(equations_set_incompressible_elast_multi_comp_darcy_subtype)
2209  !keep the multi-compartment case separate for the time being until the formulation has been finalised, then perhaps
2210  !integrate within the single compartment case
2211  !Loop over gauss points and add residuals
2212  equations_set_field=>equations_set%EQUATIONS_SET_FIELD%EQUATIONS_SET_FIELD_FIELD
2213  CALL field_parameter_set_data_get(equations_set_field,field_u_variable_type, &
2214  & field_values_set_type,equations_set_field_data,err,error,*999)
2215 
2216  ncompartments = equations_set_field_data(2)
2217 
2218  DO gauss_idx=1,dependent_number_of_gauss_points
2219  gauss_weight=dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
2220  !Interpolate dependent, geometric, fibre and materials fields
2221  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2222  & dependent_interpolated_point,err,error,*999)
2223  CALL field_interpolated_point_metrics_calculate(dependent_basis%NUMBER_OF_XI,dependent_interpolated_point_metrics, &
2224  & err,error,*999)
2225  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2226  & geometric_interpolated_point,err,error,*999)
2227  CALL field_interpolated_point_metrics_calculate(geometric_basis%NUMBER_OF_XI,geometric_interpolated_point_metrics, &
2228  & err,error,*999)
2229  IF(ASSOCIATED(fibre_field)) THEN
2230  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2231  & fibre_interpolated_point,err,error,*999)
2232  END IF
2233  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2234  & materials_interpolated_point,err,error,*999)
2235 
2236  IF(diagnostics1) THEN
2237  CALL write_string_value(diagnostic_output_type," ELEMENT_NUMBER = ",element_number,err,error,*999)
2238  CALL write_string_value(diagnostic_output_type," gauss_idx = ",gauss_idx,err,error,*999)
2239  ENDIF
2240  IF(diagnostics1) THEN
2241  CALL write_string_matrix(diagnostic_output_type,1,1,3,1,1,3, &
2242  & 3,3,piolatensor,write_string_matrix_name_and_indices,'(" Piola Tensor','(",I1,",:)',' :",3(X,E13.6))', &
2243  & '(17X,3(X,E13.6))',err,error,*999)
2244 
2245  CALL write_string_matrix(diagnostic_output_type,1,1,3,1,1,3, &
2246  & 3,3,cauchytensor,write_string_matrix_name_and_indices,'(" Cauchy Tensor','(",I1,",:)',' :",3(X,E13.6))', &
2247  & '(17X,3(X,E13.6))',err,error,*999)
2248  ENDIF
2249 
2250  !Parameters settings for coupled elasticity Darcy INRIA model:
2251  CALL get_darcy_finite_elasticity_parameters(darcy_rho_0_f,mfact,bfact,p0fact,err,error,*999)
2252 
2253  darcy_mass_increase = 0.0_dp
2254  DO imatrix=1,ncompartments
2255  darcy_field_var_type=field_v_variable_type+field_number_of_variable_subtypes*(imatrix-1)
2256  darcy_dependent_interpolation_parameters=>&
2257  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(darcy_field_var_type)%PTR
2258 
2259  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
2260  & darcy_dependent_interpolation_parameters,err,error,*999)
2261 
2262  darcy_dependent_interpolated_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(darcy_field_var_type)%PTR
2263  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2264  & darcy_dependent_interpolated_point,err,error,*999)
2265 
2266  darcy_mass_increase = darcy_mass_increase + darcy_dependent_interpolated_point%VALUES(4,no_part_deriv)
2267  ENDDO
2268 
2269  darcy_vol_increase = darcy_mass_increase / darcy_rho_0_f
2270 
2271  !Calculate F=dZ/dNU, the deformation gradient tensor at the gauss point
2272  CALL finiteelasticity_gaussdeformationgradienttensor(dependent_interpolated_point_metrics, &
2273  & geometric_interpolated_point_metrics,fibre_interpolated_point,dzdnu,err,error,*999)
2274 
2275  jxxi=geometric_interpolated_point_metrics%JACOBIAN
2276 
2277  !Calculate Sigma=1/Jznu.FTF', the Cauchy stress tensor at the gauss point
2278  CALL finite_elasticity_gauss_cauchy_tensor(equations_set,dependent_interpolated_point, &
2279  & materials_interpolated_point,darcy_dependent_interpolated_point, &
2280  & independent_interpolated_point,cauchytensor,jznu,dzdnu,element_number,gauss_idx,err,error,*999)
2281 
2282  !Calculate dPhi/dZ at the gauss point, Phi is the basis function
2283  CALL finite_elasticity_gauss_dfdz(dependent_interpolated_point,element_number,gauss_idx,number_of_dimensions, &
2284  & number_of_xi,dfdz,err,error,*999)
2285 
2286  !For membrane theory in 3D space, the final equation is multiplied by thickness. Default to unit thickness if equation set subtype is not membrane
2287  thickness = 1.0_dp
2288  IF(equations_set_subtype == equations_set_membrane_subtype) THEN
2289  IF(number_of_dimensions == 3) THEN
2290  thickness = materials_interpolated_point%VALUES(materials_interpolated_point%INTERPOLATION_PARAMETERS% &
2291  & field_variable%NUMBER_OF_COMPONENTS,1)
2292  ENDIF
2293  ENDIF
2294 
2295  !Now add up the residual terms
2296  element_dof_idx=0
2297  DO component_idx=1,number_of_dimensions
2298  dependent_component_interpolation_type=dependent_field%VARIABLES(var1)%COMPONENTS(component_idx)%INTERPOLATION_TYPE
2299  IF(dependent_component_interpolation_type==field_node_based_interpolation) THEN !node based
2300  dependent_basis=>dependent_field%VARIABLES(var1)%COMPONENTS(component_idx)%DOMAIN%TOPOLOGY% &
2301  & elements%ELEMENTS(element_number)%BASIS
2302  number_of_field_component_interpolation_parameters=dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
2303  DO parameter_idx=1,number_of_field_component_interpolation_parameters
2304  element_dof_idx=element_dof_idx+1
2305  DO component_idx2=1,number_of_dimensions
2306  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2307  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ &
2308  & gauss_weight*jxxi*jznu*thickness*cauchytensor(component_idx,component_idx2)* &
2309  & dfdz(parameter_idx,component_idx2,component_idx)
2310  ENDDO ! component_idx2 (inner component index)
2311  ENDDO ! parameter_idx (residual vector loop)
2312  ELSEIF(dependent_component_interpolation_type==field_element_based_interpolation) THEN
2313  !Will probably never be used
2314  CALL flagerror("Finite elasticity with element based interpolation is not implemented.",err,error,*999)
2315  ENDIF
2316  ENDDO ! component_idx
2317 
2318  !Hydrostatic pressure component (skip for membrane problems)
2319  IF (equations_set_subtype /= equations_set_membrane_subtype) THEN
2320  hydrostatic_pressure_component=dependent_field%VARIABLES(var1)%NUMBER_OF_COMPONENTS
2321  dependent_component_interpolation_type=dependent_field%VARIABLES(var1)%COMPONENTS(component_idx)%INTERPOLATION_TYPE
2322  IF(dependent_component_interpolation_type==field_node_based_interpolation) THEN !node based
2323  component_basis=>dependent_field%VARIABLES(var1)%COMPONENTS(hydrostatic_pressure_component)%DOMAIN% &
2324  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
2325  component_quadrature_scheme=>component_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
2326  number_of_field_component_interpolation_parameters=component_basis%NUMBER_OF_ELEMENT_PARAMETERS
2327  DO parameter_idx=1,number_of_field_component_interpolation_parameters
2328  element_dof_idx=element_dof_idx+1
2329  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2330  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ &
2331  & gauss_weight*jxxi*component_quadrature_scheme%GAUSS_BASIS_FNS(parameter_idx,1,gauss_idx)* &
2332  & (jznu-1.0_dp-darcy_vol_increase)
2333  ENDDO
2334  ELSEIF(dependent_component_interpolation_type==field_element_based_interpolation) THEN !element based
2335  element_dof_idx=element_dof_idx+1
2336  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2337  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+gauss_weight*jxxi* &
2338  & (jznu-1.0_dp-darcy_vol_increase)
2339  ENDIF
2340  ENDIF
2341  ENDDO !gauss_idx
2342 
2343  !Call surface pressure term here: should only be executed if THIS element has surface pressure on it (direct or incremented)
2344  IF(decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BOUNDARY_ELEMENT.AND. &
2345  & total_number_of_surface_pressure_conditions>0) THEN !
2346  CALL finiteelasticity_surfacepressureresidualevaluate(equations_set,element_number,var1,var2,err,error,*999)
2347  ENDIF
2348 
2349  CASE (equations_set_compressible_finite_elasticity_subtype, &
2350  & equations_set_compressible_activecontraction_subtype, &
2351  & equations_set_elasticity_darcy_inria_model_subtype, &
2352  & equations_set_elasticity_fluid_pressure_static_inria_subtype, &
2353  & equations_set_elasticity_fluid_pressure_holmes_mow_subtype, &
2354  & equations_set_elasticity_fluid_pres_holmes_mow_active_subtype, &
2355  & equations_set_nearly_incompressible_mooney_rivlin_subtype)
2356  !compressible problem (no pressure component)
2357 
2358  !Loop over gauss points and add up residuals
2359  DO gauss_idx=1,dependent_number_of_gauss_points
2360  gauss_weight=dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
2361 
2362  !Interpolate fields at the gauss points
2363  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2364  & dependent_interpolated_point,err,error,*999)
2365  CALL field_interpolated_point_metrics_calculate(dependent_basis%NUMBER_OF_XI,dependent_interpolated_point_metrics, &
2366  & err,error,*999)
2367  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2368  & geometric_interpolated_point,err,error,*999)
2369  CALL field_interpolated_point_metrics_calculate(geometric_basis%NUMBER_OF_XI,geometric_interpolated_point_metrics, &
2370  & err,error,*999)
2371  IF(ASSOCIATED(fibre_field)) THEN
2372  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2373  & fibre_interpolated_point,err,error,*999)
2374  END IF
2375  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2376  & materials_interpolated_point,err,error,*999)
2377  IF(darcy_dependent) THEN
2378  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2379  & darcy_dependent_interpolated_point,err,error,*999) ! 'FIRST_PART_DERIV' required ???
2380  ENDIF
2381 
2382  !Calculate F=dZ/dNU at the gauss point
2383  CALL finiteelasticity_gaussdeformationgradienttensor(dependent_interpolated_point_metrics, &
2384  & geometric_interpolated_point_metrics,fibre_interpolated_point,dzdnu,err,error,*999)
2385 
2386  jxxi=geometric_interpolated_point_metrics%JACOBIAN
2387 
2388  !Calculate Cauchy stress tensor at the gauss point
2389  CALL finite_elasticity_gauss_cauchy_tensor(equations_set,dependent_interpolated_point, &
2390  & materials_interpolated_point,darcy_dependent_interpolated_point, &
2391  & independent_interpolated_point,cauchytensor,jznu,dzdnu,element_number,gauss_idx,err,error,*999)
2392 
2393  !Calculate dF/DZ at the gauss point
2394  CALL finite_elasticity_gauss_dfdz(dependent_interpolated_point,element_number,gauss_idx,number_of_dimensions, &
2395  & number_of_xi,dfdz,err,error,*999)
2396 
2397  !Add up the residual terms
2398  element_dof_idx=0
2399  DO component_idx=1,dependent_number_of_components
2400  dependent_component_interpolation_type=dependent_field%VARIABLES(var1)%COMPONENTS(component_idx)%INTERPOLATION_TYPE
2401  IF(dependent_component_interpolation_type==field_node_based_interpolation) THEN !node based
2402  dependent_basis=>dependent_field%VARIABLES(var1)%COMPONENTS(component_idx)%DOMAIN%TOPOLOGY% &
2403  & elements%ELEMENTS(element_number)%BASIS
2404  number_of_field_component_interpolation_parameters=dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
2405  DO parameter_idx=1,number_of_field_component_interpolation_parameters
2406  element_dof_idx=element_dof_idx+1
2407  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
2408  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ &
2409  & gauss_weight*jxxi*jznu*(cauchytensor(component_idx,1)*dfdz(parameter_idx,1,component_idx)+ &
2410  & cauchytensor(component_idx,2)*dfdz(parameter_idx,2,component_idx)+ &
2411  & cauchytensor(component_idx,3)*dfdz(parameter_idx,3,component_idx))
2412  ENDDO
2413  ELSEIF(dependent_component_interpolation_type==field_element_based_interpolation) THEN
2414  !Will probably never be used
2415  CALL flagerror("Finite elasticity with element based interpolation is not implemented.",err,error,*999)
2416  ENDIF
2417  ENDDO !component_idx
2418  ENDDO !gauss_idx
2419 
2420  !Call surface pressure term here: should only be executed if THIS element has surface pressure on it (direct or incremented)
2421  IF(decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)%BOUNDARY_ELEMENT.AND. &
2422  & total_number_of_surface_pressure_conditions>0) THEN !
2423  CALL finiteelasticity_surfacepressureresidualevaluate(equations_set,element_number,var1,var2,err,error,*999)
2424  ENDIF
2425  END SELECT
2426  IF(ASSOCIATED(rhs_vector)) THEN
2427  IF(ASSOCIATED(source_field)) THEN
2428  IF(ASSOCIATED(materials_field%VARIABLE_TYPE_MAP(field_v_variable_type)%PTR)) THEN
2429  density_interpolation_parameters=>equations%INTERPOLATION%MATERIALS_INTERP_PARAMETERS(field_v_variable_type)%PTR
2430  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
2431  & density_interpolation_parameters,err,error,*999)
2432  density_interpolated_point=>equations%INTERPOLATION%MATERIALS_INTERP_POINT(field_v_variable_type)%PTR
2433  IF(darcy_density) THEN
2434  darcy_materials_interpolation_parameters=>equations%INTERPOLATION%MATERIALS_INTERP_PARAMETERS( &
2435  & field_u1_variable_type)%PTR
2436  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
2437  & darcy_materials_interpolation_parameters,err,error,*999)
2438  darcy_materials_interpolated_point=>equations%INTERPOLATION%MATERIALS_INTERP_POINT(field_u1_variable_type)%PTR
2439  ENDIF
2440  IF(rhs_vector%UPDATE_VECTOR) THEN
2441  source_interpolation_parameters=>equations%INTERPOLATION%SOURCE_INTERP_PARAMETERS(field_u_variable_type)%PTR
2442  CALL field_interpolation_parameters_element_get(field_values_set_type,element_number, &
2443  & source_interpolation_parameters,err,error,*999)
2444  source_interpolated_point=>equations%INTERPOLATION%SOURCE_INTERP_POINT(field_u_variable_type)%PTR
2445 
2446  DO gauss_idx=1,dependent_number_of_gauss_points
2447  gauss_weight=dependent_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)
2448  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2449  & source_interpolated_point,err,error,*999)
2450  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx,equations%INTERPOLATION% &
2451  & geometric_interp_point(field_u_variable_type)%PTR,err,error,*999)
2452  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2453  & density_interpolated_point,err,error,*999)
2454  IF(darcy_density) THEN
2455  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
2456  & darcy_materials_interpolated_point,err,error,*999)
2457  !Account for separate fluid and solid proportions and densities
2458  !Total lagrangian density = m_s + m_f = rho^0_s * (1 - phi^0) + rho_f * phi
2459  !By assuming solid incompressibility, phi = (J - 1 + phi^0)
2460  !\todo: Think about how this fits in with the constitutive relation, and what happens when the solid
2461  !isn't incompressible. Can we assume the solid is incompressible if we aren't enforcing that in the
2462  !constitutive relation?
2463  density=density_interpolated_point%VALUES(1,1)*(1.0_dp-darcy_materials_interpolated_point%VALUES(8,1)) + &
2464  & darcy_materials_interpolated_point%VALUES(7,1)*(jznu-1.0_dp+darcy_materials_interpolated_point%VALUES(8,1))
2465  ELSE
2466  density=density_interpolated_point%VALUES(1,1)
2467  ENDIF
2468  CALL field_interpolated_point_metrics_calculate(dependent_basis%NUMBER_OF_XI,equations%INTERPOLATION% &
2469  & dependent_interp_point_metrics(field_u_variable_type)%PTR,err,error,*999)
2470  element_dof_idx=0
2471  DO component_idx=1,number_of_dimensions
2472  dependent_basis=>dependent_field%VARIABLES(var1)%COMPONENTS(component_idx)%DOMAIN%TOPOLOGY% &
2473  & elements%ELEMENTS(element_number)%BASIS
2474  DO parameter_idx=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
2475  element_dof_idx=element_dof_idx+1
2476  rhs_vector%ELEMENT_VECTOR%VECTOR(element_dof_idx)=rhs_vector%ELEMENT_VECTOR%VECTOR(element_dof_idx) + &
2477  & density*source_interpolated_point%VALUES(component_idx,1) * &
2478  & dependent_quadrature_scheme%GAUSS_BASIS_FNS(parameter_idx,no_part_deriv,gauss_idx)*gauss_weight * &
2479  & equations%INTERPOLATION%DEPENDENT_INTERP_POINT_METRICS(field_u_variable_type)%PTR%JACOBIAN
2480  ENDDO
2481  ENDDO
2482  ENDDO !gauss_idx
2483  ENDIF
2484  ENDIF
2485  ENDIF
2486  ELSE
2487  CALL flagerror("RHS vector is not associated.",err,error,*999)
2488  ENDIF
2489 
2490  !Scale factor adjustment
2491  IF(dependent_field%SCALINGS%SCALING_TYPE/=field_no_scaling) THEN
2492  CALL field_interpolationparametersscalefactorselementget(element_number,equations%INTERPOLATION% &
2493  & dependent_interp_parameters(field_var_type)%PTR,err,error,*999)
2494  mhs=0
2495  DO mh=1,field_variable%NUMBER_OF_COMPONENTS
2496  !Loop over element rows
2497  dependent_component_interpolation_type=dependent_field%VARIABLES(field_var_type)%COMPONENTS(mh)%INTERPOLATION_TYPE
2498  IF(dependent_component_interpolation_type==field_node_based_interpolation) THEN !node based
2499  dependent_basis=>dependent_field%VARIABLES(field_var_type)%COMPONENTS(mh)%DOMAIN%TOPOLOGY% &
2500  & elements%ELEMENTS(element_number)%BASIS
2501  DO ms=1,dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
2502  mhs=mhs+1
2503  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)=nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(mhs)* &
2504  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ms,mh)
2505  IF(ASSOCIATED(rhs_vector)) THEN
2506  IF(ASSOCIATED(source_field)) THEN
2507  IF(rhs_vector%UPDATE_VECTOR) rhs_vector%ELEMENT_VECTOR%VECTOR(mhs)=rhs_vector%ELEMENT_VECTOR%VECTOR(mhs)* &
2508  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_type)%PTR%SCALE_FACTORS(ms,mh)
2509  ENDIF
2510  ENDIF
2511  ENDDO !ms
2512  ENDIF
2513  ENDDO !mh
2514  ENDIF
2515 
2516  ELSE
2517  CALL flagerror("Equations set equations is not associated.",err,error,*999)
2518  ENDIF
2519  ELSE
2520  CALL flagerror("Equations set is not associated.",err,error,*999)
2521  ENDIF
2522 
2523  IF(diagnostics5) THEN
2524  !Output element residual vector for first element
2525  IF(element_number == 1) THEN
2526  ndofs = 0
2527  field_variable=>dependent_field%VARIABLES(var1) ! 'U' variable
2528  DO mh=1,field_variable%NUMBER_OF_COMPONENTS
2529  SELECT CASE(field_variable%COMPONENTS(mh)%INTERPOLATION_TYPE)
2530  CASE(field_node_based_interpolation)
2531  mesh_component_1 = field_variable%COMPONENTS(mh)%MESH_COMPONENT_NUMBER
2532  dependent_basis_1 => dependent_field%DECOMPOSITION%DOMAIN(mesh_component_1)%ptr% &
2533  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
2534  ndofs = ndofs + dependent_basis_1%NUMBER_OF_ELEMENT_PARAMETERS
2535  CALL write_string_value(diagnostic_output_type,"EP: ",dependent_basis_1%NUMBER_OF_ELEMENT_PARAMETERS,err,error,*999)
2536  CASE(field_element_based_interpolation)
2537  ndofs = ndofs + 1
2538  CALL write_string_value(diagnostic_output_type,"EP: ",1,err,error,*999)
2539  CASE DEFAULT
2540  CALL flagerror("Interpolation type " &
2541  & //trim(number_to_vstring(field_variable%COMPONENTS(mh)%INTERPOLATION_TYPE,"*",err,error))// &
2542  & " is not valid for a finite elasticity equation.",err,error,*999)
2543  END SELECT
2544  END DO
2545  CALL write_string_value(diagnostic_output_type,"NDOFS: ",ndofs,err,error,*999)
2546  CALL write_string(diagnostic_output_type,"Element Vector for element number * (Fin.Elast.):",err,error,*999)
2547  CALL write_string_value(diagnostic_output_type,"Element Vector for element number (Fin.Elast.): ", &
2548  & element_number,err,error,*999)
2549  CALL writestringvector(diagnostic_output_type,1,1,ndofs,ndofs,ndofs,&
2550  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(:), &
2551  & '(4(X,E13.6))','4(4(X,E13.6))',err,error,*999)
2552  ENDIF
2553  ENDIF
2554 
2555  exits("FiniteElasticity_FiniteElementResidualEvaluate")
2556  RETURN
2557 999 errors("FiniteElasticity_FiniteElementResidualEvaluate",err,error)
2558  exits("FiniteElasticity_FiniteElementResidualEvaluate")
2559  RETURN 1
2560 
2561  END SUBROUTINE finiteelasticity_finiteelementresidualevaluate
2562 
2563  !
2564  !================================================================================================================================
2565  !
2566 
2568  SUBROUTINE finiteelasticity_finiteelementpreresidualevaluate(EQUATIONS_SET,ERR,ERROR,*)
2569 
2570  !Argument variables
2571  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2572  INTEGER(INTG), INTENT(OUT) :: ERR
2573  TYPE(varying_string), INTENT(OUT) :: ERROR
2574  !Local Variables
2575  TYPE(varying_string) :: LOCAL_ERROR
2576  TYPE(field_type), POINTER :: DEPENDENT_FIELD
2577 
2578  enters("FiniteElasticity_FiniteElementPreResidualEvaluate",err,error,*999)
2579 
2580  IF(ASSOCIATED(equations_set)) THEN
2581  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
2582  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
2583  ELSE IF(SIZE(equations_set%SPECIFICATION,1)/=3) THEN
2584  CALL flagerror("Equations set specification must have three entries for a finite elasticity type equations set.", &
2585  & err,error,*999)
2586  END IF
2587  SELECT CASE(equations_set%SPECIFICATION(3))
2588  CASE(equations_set_constitutive_law_in_cellml_evaluate_subtype, &
2589  & equations_set_constitutive_and_growth_law_in_cellml_subtype)
2590  dependent_field=>equations_set%EQUATIONS%INTERPOLATION%DEPENDENT_FIELD
2591  CALL finiteelasticity_straincalculate(equations_set,dependent_field, &
2592  & field_u1_variable_type,err,error,*999)
2593  CASE(equations_set_membrane_subtype,equations_set_mooney_rivlin_subtype, &
2594  & equations_set_mooney_rivlin_activecontraction_subtype, &
2595  & equations_set_stvenant_kirchoff_activecontraction_subtype, &
2596  & equations_set_isotropic_exponential_subtype, &
2597  & equations_set_transverse_isotropic_exponential_subtype,equations_set_transverse_isotropic_polynomial_subtype, &
2598  & equations_set_anisotropic_polynomial_subtype,equations_set_anisotropic_polynomial_active_subtype, &
2599  & equations_set_trans_isotropic_active_transition_subtype,equations_set_transverse_isotropic_active_subtype, &
2600  & equations_set_orthotropic_material_costa_subtype,equations_set_compressible_finite_elasticity_subtype,&
2601  & equations_set_compressible_activecontraction_subtype, &
2602  & equations_set_activecontraction_subtype, equations_set_no_subtype, &
2603  & equations_set_incompressible_finite_elasticity_darcy_subtype,equations_set_elasticity_darcy_inria_model_subtype, &
2604  & equations_set_incompressible_elasticity_driven_darcy_subtype, &
2605  & equations_set_orthotropic_material_holzapfel_ogden_subtype, &
2606  & equations_set_incompressible_mooney_rivlin_subtype,equations_set_nearly_incompressible_mooney_rivlin_subtype, &
2607  & equations_set_incompressible_elast_multi_comp_darcy_subtype,equations_set_transverse_isotropic_guccione_subtype, &
2608  & equations_set_guccione_activecontraction_subtype, &
2609  & equations_set_elasticity_fluid_pressure_static_inria_subtype, &
2610  & equations_set_elasticity_fluid_pressure_holmes_mow_subtype, &
2611  & equations_set_elasticity_fluid_pres_holmes_mow_active_subtype, &
2612  & equations_set_transverse_isotropic_humphrey_yin_subtype, &
2613  & equations_set_standard_monodomain_elasticity_subtype,equations_set_1d3d_monodomain_elasticity_subtype, &
2614  & equations_set_monodomain_elasticity_w_titin_subtype,equations_set_active_strain_subtype, &
2615  & equations_set_multiscale_active_strain_subtype,equations_set_1d3d_monodomain_active_strain_subtype, &
2616  & equations_set_monodomain_elasticity_velocity_subtype, &
2617  & equations_set_holzapfel_ogden_activecontraction_subtype)
2618  !Do nothing ???
2619  CASE DEFAULT
2620  local_error="The third equations set specification of "// &
2621  & trim(number_to_vstring(equations_set%SPECIFICATION(3),"*",err,error))// &
2622  & " is not valid for a finite elasticity type of an elasticity equation set."
2623  CALL flagerror(local_error,err,error,*999)
2624  END SELECT
2625  ELSE
2626  CALL flagerror("Equations set is not associated.",err,error,*999)
2627  ENDIF
2628 
2629  exits("FiniteElasticity_FiniteElementPreResidualEvaluate")
2630  RETURN
2631 999 errors("FiniteElasticity_FiniteElementPreResidualEvaluate",err,error)
2632  exits("FiniteElasticity_FiniteElementPreResidualEvaluate")
2633  RETURN 1
2634 
2635  END SUBROUTINE finiteelasticity_finiteelementpreresidualevaluate
2636 
2637  !
2638  !================================================================================================================================
2639  !
2640 
2642  SUBROUTINE finiteelasticity_finiteelementpostresidualevaluate(EQUATIONS_SET,ERR,ERROR,*)
2643 
2644  !Argument variables
2645  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
2646  INTEGER(INTG), INTENT(OUT) :: ERR
2647  TYPE(varying_string), INTENT(OUT) :: ERROR
2648  !Local Variables
2649  TYPE(varying_string) :: LOCAL_ERROR
2650 
2651  enters("FiniteElasticity_FiniteElementPostResidualEvaluate",err,error,*999)
2652 
2653  IF(ASSOCIATED(equations_set)) THEN
2654  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
2655  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
2656  ELSE IF(SIZE(equations_set%SPECIFICATION,1)/=3) THEN
2657  CALL flagerror("Equations set specification must have three entries for a finite elasticity type equations set.", &
2658  & err,error,*999)
2659  END IF
2660  SELECT CASE(equations_set%SPECIFICATION(3))
2661  CASE(equations_set_membrane_subtype,equations_set_mooney_rivlin_subtype, &
2662  & equations_set_mooney_rivlin_activecontraction_subtype, &
2663  & equations_set_stvenant_kirchoff_activecontraction_subtype, &
2664  & equations_set_isotropic_exponential_subtype, &
2665  & equations_set_transverse_isotropic_exponential_subtype,equations_set_standard_monodomain_elasticity_subtype, &
2666  & equations_set_orthotropic_material_costa_subtype,equations_set_compressible_finite_elasticity_subtype,&
2667  & equations_set_compressible_activecontraction_subtype,equations_set_transverse_isotropic_active_subtype, &
2668  & equations_set_trans_isotropic_active_transition_subtype,equations_set_transverse_isotropic_polynomial_subtype, &
2669  & equations_set_anisotropic_polynomial_subtype,equations_set_anisotropic_polynomial_active_subtype, &
2670  & equations_set_activecontraction_subtype,equations_set_no_subtype,equations_set_1d3d_monodomain_elasticity_subtype, &
2671  & equations_set_monodomain_elasticity_w_titin_subtype,equations_set_active_strain_subtype, &
2672  & equations_set_multiscale_active_strain_subtype,equations_set_monodomain_elasticity_velocity_subtype, &
2673  & equations_set_1d3d_monodomain_active_strain_subtype, &
2674  & equations_set_incompressible_finite_elasticity_darcy_subtype,equations_set_elasticity_darcy_inria_model_subtype, &
2675  & equations_set_incompressible_elasticity_driven_darcy_subtype, &
2676  & equations_set_orthotropic_material_holzapfel_ogden_subtype, &
2677  & equations_set_incompressible_mooney_rivlin_subtype,equations_set_nearly_incompressible_mooney_rivlin_subtype, &
2678  & equations_set_incompressible_elast_multi_comp_darcy_subtype,equations_set_transverse_isotropic_guccione_subtype, &
2679  & equations_set_guccione_activecontraction_subtype, &
2680  & equations_set_elasticity_fluid_pressure_static_inria_subtype, &
2681  & equations_set_transverse_isotropic_humphrey_yin_subtype,&
2682  & equations_set_elasticity_fluid_pressure_holmes_mow_subtype, &
2683  & equations_set_elasticity_fluid_pres_holmes_mow_active_subtype, &
2684  & equations_set_constitutive_law_in_cellml_evaluate_subtype, &
2685  & equations_set_holzapfel_ogden_activecontraction_subtype, &
2686  & equations_set_constitutive_and_growth_law_in_cellml_subtype)
2687  !Do nothing ???
2688  CASE DEFAULT
2689  local_error="The third equations set specification of "// &
2690  & trim(numbertovstring(equations_set%SPECIFICATION(3),"*",err,error))// &
2691  & " is not valid for a finite elasticity type of an elasticity equation set."
2692  CALL flagerror(local_error,err,error,*999)
2693  END SELECT
2694  ELSE
2695  CALL flagerror("Equations set is not associated.",err,error,*999)
2696  ENDIF
2697 
2698  exits("FiniteElasticity_FiniteElementPostResidualEvaluate")
2699  RETURN
2700 999 errors("FiniteElasticity_FiniteElementPostResidualEvaluate",err,error)
2701  exits("FiniteElasticity_FiniteElementPostResidualEvaluate")
2702  RETURN 1
2703 
2704  END SUBROUTINE finiteelasticity_finiteelementpostresidualevaluate
2705 
2706  !
2707  !================================================================================================================================
2708  !
2709 
2711  SUBROUTINE finiteelasticityequationsset_derivedvariablecalculate(equationsSet,derivedType,err,error,*)
2712 
2713  !Argument variables
2714  TYPE(equations_set_type), POINTER, INTENT(IN) :: equationsSet
2715  INTEGER(INTG), INTENT(IN) :: derivedType
2716  INTEGER(INTG), INTENT(OUT) :: err
2717  TYPE(varying_string), INTENT(OUT) :: error
2718 
2719  !Local variables
2720  TYPE(field_variable_type), POINTER :: derivedVariable
2721 
2722  enters("FiniteElasticityEquationsSet_DerivedVariableCalculate",err,error,*999)
2723 
2724  NULLIFY(derivedvariable)
2725 
2726  IF(ASSOCIATED(equationsset)) THEN
2727  IF(.NOT.equationsset%EQUATIONS_SET_FINISHED) THEN
2728  CALL flagerror("Equations set has not been finished.",err,error,*999)
2729  ELSE
2730  IF(ASSOCIATED(equationsset%equations)) THEN
2731  CALL equations_derivedvariableget(equationsset%equations,derivedtype,derivedvariable,err,error,*999)
2732  SELECT CASE(derivedtype)
2733  CASE(equations_set_derived_strain)
2734  CALL finiteelasticity_straincalculate(equationsset, &
2735  & derivedvariable%field,derivedvariable%variable_type,err,error,*999)
2736  CASE(equations_set_derived_stress)
2737  CALL flagerror("Not implemented.",err,error,*999)
2738  CASE DEFAULT
2739  CALL flagerror("Equations set derived field type of "//trim(number_to_vstring(derivedtype,"*",err,error))// &
2740  & " is not valid for a finite elasticity equations set type.",err,error,*999)
2741  END SELECT
2742  ELSE
2743  CALL flagerror("Equations set equations are not associated.",err,error,*999)
2744  END IF
2745  END IF
2746  ELSE
2747  CALL flagerror("Equations set is not associated.",err,error,*999)
2748  END IF
2749 
2750  exits("FiniteElasticityEquationsSet_DerivedVariableCalculate")
2751  RETURN
2752 999 errors("FiniteElasticityEquationsSet_DerivedVariableCalculate",err,error)
2753  exits("FiniteElasticityEquationsSet_DerivedVariableCalculate")
2754  RETURN 1
2755  END SUBROUTINE finiteelasticityequationsset_derivedvariablecalculate
2756 
2757  !
2758  !================================================================================================================================
2759  !
2760 
2762  SUBROUTINE finiteelasticity_straincalculate(equationsSet,strainField,strainFieldVariableType,err,error,*)
2763 
2764  TYPE(equations_set_type), POINTER, INTENT(IN) :: equationsSet
2765  TYPE(field_type), POINTER, INTENT(INOUT) :: strainField
2766  INTEGER(INTG), INTENT(IN) :: strainFieldVariableType
2767  INTEGER(INTG), INTENT(OUT) :: err
2768  TYPE(varying_string), INTENT(OUT) :: error
2769  !Local Variables
2770  TYPE(basis_type), POINTER :: dependentBasis
2771  TYPE(equations_type), POINTER :: equations
2772  TYPE(field_type), POINTER :: dependentField,geometricField,fibreField
2773  TYPE(quadrature_scheme_type), POINTER :: dependentQuadratureScheme
2774  TYPE(field_interpolation_parameters_type), POINTER :: geometricInterpolationParameters,dependentInterpolationParameters, &
2775  & fibreInterpolationParameters
2776  TYPE(field_interpolated_point_type), POINTER :: geometricInterpolatedPoint,dependentInterpolatedPoint,fibreInterpolatedPoint
2777  TYPE(field_interpolated_point_metrics_type), POINTER ::geometricInterpolatedPointMetrics,dependentInterpolatedPointMetrics
2778  TYPE(decomposition_type), POINTER :: decomposition
2779  TYPE(domain_mapping_type), POINTER :: elementsMapping
2780  TYPE(varying_string) :: localError
2781  INTEGER(INTG) :: componentIdx,dependentNumberOfComponents,elementIdx,elementNumber,fieldVariableType,gaussIdx, &
2782  & meshComponentNumber,numberOfComponents,numberOfDimensions,numberOfGauss,numberOfTimes,numberOfXi,partIdx, &
2783  & startIdx,finishIdx
2784  INTEGER(INTG) :: var1 ! Variable number corresponding to 'U' in single physics case
2785  INTEGER(INTG) :: var2 ! Variable number corresponding to 'DELUDLEN' in single physics case
2786  REAL(DP) :: dZdNu(3,3),Fg(3,3),Fe(3,3),J,Jg,Je,C(3,3),f(3,3),E(3,3)
2787  REAL(SP) :: elementUserElapsed,elementSystemElapsed,systemElapsed,systemTime1(1),systemTime2(1),systemTime3(1),systemTime4(1), &
2788  & userElapsed,userTime1(1),userTime2(1),userTime3(1),userTime4(1)
2789 
2790  enters("FiniteElasticity_StrainCalculate",err,error,*999)
2791 
2792  IF(ASSOCIATED(equationsset)) THEN
2793  equations=>equationsset%equations
2794  IF(ASSOCIATED(equations)) THEN
2795  numberofdimensions=equationsset%region%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
2796 
2797  !Check the provided strain field has appropriate components and interpolation
2798  IF(ASSOCIATED(strainfield)) THEN
2799  CALL field_variabletypecheck(strainfield,strainfieldvariabletype,err,error,*999)
2800  SELECT CASE(numberofdimensions)
2801  CASE(3)
2802  numberofcomponents=6
2803  CASE(2)
2804  numberofcomponents=3
2805  CASE(1)
2806  numberofcomponents=1
2807  CASE DEFAULT
2808  CALL flagerror("The number of dimensions of "//trim(number_to_vstring(numberofdimensions,"*",err,error))// &
2809  & " is invalid.",err,error,*999)
2810  END SELECT
2811  CALL field_numberofcomponentscheck(strainfield,strainfieldvariabletype,6,err,error,*999)
2812  DO componentidx=1,numberofcomponents
2813  CALL field_componentinterpolationcheck(strainfield,strainfieldvariabletype,componentidx, &
2814  & field_gauss_point_based_interpolation,err,error,*999)
2815  ENDDO !componentIdx
2816  ELSE
2817  CALL flagerror("Strain field is not associated.",err,error,*999)
2818  END IF
2819 
2820  !Which variables are we working with - find the variable pair used for this equations set
2821  !\todo: put in checks for all the objects/mappings below TODO
2822 
2823  var1=equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR%VARIABLE_NUMBER ! number for 'U'
2824  var2=equations%EQUATIONS_MAPPING%RHS_MAPPING%RHS_VARIABLE%VARIABLE_NUMBER ! number for 'DELUDELN'
2825 
2826  geometricfield=>equations%interpolation%GEOMETRIC_FIELD
2827  dependentfield=>equations%interpolation%DEPENDENT_FIELD
2828  fibrefield=>equations%interpolation%FIBRE_FIELD
2829  dependentnumberofcomponents=dependentfield%variables(var1)%NUMBER_OF_COMPONENTS
2830 
2831  decomposition=>dependentfield%decomposition
2832  meshcomponentnumber=decomposition%MESH_COMPONENT_NUMBER
2833 
2834  !Grab interpolation points
2835  fieldvariabletype=equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR%VARIABLE_TYPE
2836  geometricinterpolationparameters=>equations%interpolation%GEOMETRIC_INTERP_PARAMETERS(field_u_variable_type)%ptr
2837  geometricinterpolatedpoint=>equations%interpolation%GEOMETRIC_INTERP_POINT(field_u_variable_type)%ptr
2838  geometricinterpolatedpointmetrics=>equations%interpolation%GEOMETRIC_INTERP_POINT_METRICS(field_u_variable_type)%ptr
2839  dependentinterpolationparameters=>equations%interpolation%DEPENDENT_INTERP_PARAMETERS(fieldvariabletype)%ptr
2840  dependentinterpolatedpoint=>equations%interpolation%DEPENDENT_INTERP_POINT(fieldvariabletype)%ptr
2841  dependentinterpolatedpointmetrics=>equations%interpolation%DEPENDENT_INTERP_POINT_METRICS(fieldvariabletype)%ptr
2842  IF(ASSOCIATED(fibrefield)) THEN
2843  fibreinterpolationparameters=>equations%interpolation%FIBRE_INTERP_PARAMETERS(field_u_variable_type)%ptr
2844  fibreinterpolatedpoint=>equations%interpolation%FIBRE_INTERP_POINT(field_u_variable_type)%ptr
2845  ELSE
2846  NULLIFY(fibreinterpolationparameters)
2847  NULLIFY(fibreinterpolatedpoint)
2848  ENDIF
2849 
2850  elementsmapping=>dependentfield%decomposition%domain(meshcomponentnumber)%ptr%mappings%elements
2851 
2852  numberoftimes=0
2853 
2854  !Loop over the two parts: 1 - boundary and ghost elements, 2 - internal
2855  DO partidx=1,2
2856 
2857  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
2858  CALL cpu_timer(user_cpu,usertime1,err,error,*999)
2859  CALL cpu_timer(system_cpu,systemtime1,err,error,*999)
2860  ENDIF
2861 
2862  IF(partidx==1) THEN
2863  startidx=elementsmapping%BOUNDARY_START
2864  finishidx=elementsmapping%GHOST_FINISH
2865  ELSE
2866  startidx=elementsmapping%INTERNAL_START
2867  finishidx=elementsmapping%INTERNAL_FINISH
2868  ENDIF
2869 
2870  !Loop over (1) the boundary and ghost elements, (2) the internal elements
2871  DO elementidx=startidx,finishidx
2872 
2873  numberoftimes=numberoftimes+1
2874  elementnumber=elementsmapping%DOMAIN_LIST(elementidx)
2875 
2876  IF(diagnostics1) THEN
2877  CALL writestringvalue(diagnostic_output_type," Element number = ",elementnumber,err,error,*999)
2878  ENDIF
2879 
2880  dependentbasis=>decomposition%domain(meshcomponentnumber)%ptr%topology%elements%elements(elementnumber)%basis
2881  dependentquadraturescheme=>dependentbasis%quadrature%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
2882  numberofgauss=dependentquadraturescheme%NUMBER_OF_GAUSS
2883 
2884  numberofxi=dependentbasis%NUMBER_OF_XI
2885 
2886  CALL field_interpolationparameterselementget(field_values_set_type,elementnumber,geometricinterpolationparameters, &
2887  & err,error,*999)
2888  CALL field_interpolationparameterselementget(field_values_set_type,elementnumber,dependentinterpolationparameters, &
2889  & err,error,*999)
2890  IF(ASSOCIATED(fibrefield)) THEN
2891  CALL field_interpolationparameterselementget(field_values_set_type,elementnumber,fibreinterpolationparameters, &
2892  & err,error,*999)
2893  ENDIF
2894 
2895  !Loop over gauss points
2896  DO gaussidx=1,numberofgauss
2897 
2898  IF(diagnostics1) THEN
2899  CALL writestringvalue(diagnostic_output_type," Gauss point number = ",gaussidx,err,error,*999)
2900  ENDIF
2901 
2902  !Interpolate dependent, geometric, fibre fields
2903  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gaussidx,dependentinterpolatedpoint, &
2904  & err,error,*999)
2905  CALL field_interpolatedpointmetricscalculate(numberofxi,dependentinterpolatedpointmetrics,err,error,*999)
2906  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gaussidx,geometricinterpolatedpoint, &
2907  & err,error,*999)
2908  CALL field_interpolatedpointmetricscalculate(numberofxi,geometricinterpolatedpointmetrics,err,error,*999)
2909  IF(ASSOCIATED(fibrefield)) THEN
2910  CALL field_interpolategauss(first_part_deriv,basis_default_quadrature_scheme,gaussidx,fibreinterpolatedpoint, &
2911  & err,error,*999)
2912  ENDIF
2913 
2914  !Calculate F=dZ/dNU, the deformation gradient tensor at the gauss point
2915  CALL finiteelasticity_gaussdeformationgradienttensor(dependentinterpolatedpointmetrics, &
2916  & geometricinterpolatedpointmetrics,fibreinterpolatedpoint,dzdnu,err,error,*999)
2917 
2918  CALL finiteelasticity_gaussgrowthtensor(equationsset,numberofdimensions,gaussidx,elementnumber,dependentfield, &
2919  & dzdnu,fg,fe,jg,je,err,error,*999)
2920 
2921  CALL finiteelasticity_straintensor(fe,c,f,j,e,err,error,*999)
2922 
2923  !We only want to store the indepent components of the STRAIN FIELD
2924  SELECT CASE(numberofdimensions)
2925  CASE(3)
2926  ! 3 dimensional problem
2927  ! ORDER OF THE COMPONENTS: U_11, U_12, U_13, U_22, U_23, U_33 (upper triangular matrix)
2928  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2929  & gaussidx,elementnumber,1,c(1,1),err,error,*999)
2930  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2931  & gaussidx,elementnumber,2,c(1,2),err,error,*999)
2932  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2933  & gaussidx,elementnumber,3,c(1,3),err,error,*999)
2934  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2935  & gaussidx,elementnumber,4,c(2,2),err,error,*999)
2936  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2937  & gaussidx,elementnumber,5,c(2,3),err,error,*999)
2938  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2939  & gaussidx,elementnumber,6,c(3,3),err,error,*999)
2940  CASE(2)
2941  ! 2 dimensional problem
2942  ! ORDER OF THE COMPONENTS: U_11, U_12, U_22 (upper triangular matrix)
2943  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2944  & gaussidx,elementnumber,1,c(1,1),err,error,*999)
2945  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2946  & gaussidx,elementnumber,2,c(1,2),err,error,*999)
2947  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2948  & gaussidx,elementnumber,3,c(2,2),err,error,*999)
2949  CASE(1)
2950  ! 1 dimensional problem
2951  CALL field_parametersetupdatelocalgausspoint(strainfield,strainfieldvariabletype,field_values_set_type, &
2952  & gaussidx,elementnumber,1,c(1,1),err,error,*999)
2953  CASE DEFAULT
2954  localerror="The number of dimensions of "//trim(numbertovstring(numberofdimensions,"*",err,error))// &
2955  & " is invalid."
2956  CALL flagerror(localerror,err,error,*999)
2957  END SELECT
2958  ENDDO !gaussIdx
2959  ENDDO !elementIdx
2960 
2961  !Output timing information if required
2962  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
2963  CALL cpu_timer(user_cpu,usertime2,err,error,*999)
2964  CALL cpu_timer(system_cpu,systemtime2,err,error,*999)
2965  userelapsed=usertime2(1)-usertime1(1)
2966  systemelapsed=systemtime2(1)-systemtime1(1)
2967  elementuserelapsed=elementuserelapsed+userelapsed
2968  elementsystemelapsed=elementsystemelapsed+systemelapsed
2969  IF(partidx==1) THEN
2970  CALL writestringvalue(general_output_type,"User time for strain field (boundary+ghost elements) calculation = ", &
2971  & userelapsed,err,error,*999)
2972  CALL writestringvalue(general_output_type,"System time for strain field (boundary+ghost elements) calculation = ", &
2973  & systemelapsed,err,error,*999)
2974  ELSE
2975  CALL writestringvalue(general_output_type,"User time for strain field (internal elements) calculation = ", &
2976  & userelapsed,err,error,*999)
2977  CALL writestringvalue(general_output_type,"System time for strain field (internal elements) calculation = ", &
2978  & systemelapsed,err,error,*999)
2979  IF(numberoftimes>0) THEN
2980  CALL writestringvalue(general_output_type,"Average element user time for strain field calculation = ", &
2981  & elementuserelapsed/numberoftimes,err,error,*999)
2982  CALL writestringvalue(general_output_type,"Average element system time for strain field calculation = ", &
2983  & elementsystemelapsed/numberoftimes,err,error,*999)
2984  ENDIF
2985  ENDIF
2986  ENDIF !EQUATIONS%OUTPUT_TYPE>=EQUATIONS_TIMING_OUTPUT
2987 
2988  IF(partidx==1) THEN
2989  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
2990  CALL cpu_timer(user_cpu,usertime3,err,error,*999)
2991  CALL cpu_timer(system_cpu,systemtime3,err,error,*999)
2992  ENDIF
2993  !Start to update the field
2994  CALL field_parametersetupdatestart(strainfield,strainfieldvariabletype,field_values_set_type,err,error,*999)
2995  ELSE
2996  !Finish to update the field
2997  CALL field_parametersetupdatefinish(strainfield,strainfieldvariabletype,field_values_set_type,err,error,*999)
2998  !Output timing information if required
2999  IF(equations%OUTPUT_TYPE>=equations_timing_output) THEN
3000  CALL cpu_timer(user_cpu,usertime4,err,error,*999)
3001  CALL cpu_timer(system_cpu,systemtime4,err,error,*999)
3002  userelapsed=usertime4(1)-usertime3(1)
3003  systemelapsed=systemtime4(1)-systemtime3(1)
3004  CALL writestringvalue(general_output_type,"User time for parameter transfer completion = ",userelapsed, &
3005  & err,error,*999)
3006  CALL writestringvalue(general_output_type,"System time for parameter transfer completion = ",systemelapsed, &
3007  & err,error,*999)
3008  ENDIF !EQUATIONS%OUTPUT_TYPE>=EQUATIONS_TIMING_OUTPUT
3009  ENDIF
3010 
3011  ENDDO !partIdx
3012 
3013  ELSE
3014  CALL flagerror("Equations set equations is not associated.",err,error,*999)
3015  ENDIF
3016  ELSE
3017  CALL flagerror("Equations set is not associated.",err,error,*999)
3018  ENDIF
3019 
3020  exits("FiniteElasticity_StrainCalculate")
3021  RETURN
3022 999 errorsexits("FiniteElasticity_StrainCalculate",err,error)
3023  RETURN 1
3024 
3025  END SUBROUTINE finiteelasticity_straincalculate
3026 
3027  !
3028  !================================================================================================================================
3029  !
3030 
3032  SUBROUTINE finiteelasticity_tensorinterpolatexi(equationsSet,tensorEvaluateType,userElementNumber,xi,values,err,error,*)
3033  ! Argument variables
3034  TYPE(equations_set_type), POINTER, INTENT(IN) :: equationsSet
3035  INTEGER(INTG), INTENT(IN) :: tensorEvaluateType
3036  INTEGER(INTG), INTENT(IN) :: userElementNumber
3037  REAL(DP), INTENT(IN) :: xi(:)
3038  REAL(DP), INTENT(OUT) :: values(3,3)
3039  INTEGER(INTG), INTENT(OUT) :: err
3040  TYPE(varying_string), INTENT(OUT) :: error
3041  ! Local variables
3042  TYPE(equations_type), POINTER :: equations
3043  TYPE(field_type), POINTER :: dependentField
3044  TYPE(field_interpolated_point_type), POINTER :: geometricInterpolatedPoint, &
3045  & fibreInterpolatedPoint,dependentInterpolatedPoint,materialsInterpolatedPoint, &
3046  & independentInterpolatedPoint,darcyInterpolatedPoint
3047  TYPE(field_interpolated_point_metrics_type), POINTER :: geometricInterpolatedPointMetrics, &
3048  & dependentInterpolatedPointMetrics
3049  TYPE(decomposition_type), POINTER :: decomposition
3050  TYPE(decomposition_topology_type), POINTER :: decompositionTopology
3051  TYPE(domain_topology_type), POINTER :: domainTopology
3052  TYPE(equations_mapping_nonlinear_type), POINTER :: nonlinearMapping
3053  TYPE(basis_type), POINTER :: elementBasis
3054  LOGICAL :: userElementExists,ghostElement
3055  INTEGER(INTG) :: dependentVarType,meshComponentNumber
3056  INTEGER(INTG) :: numberOfDimensions,numberOfXi
3057  INTEGER(INTG) :: localElementNumber,i,nh,mh
3058  REAL(DP) :: dZdNu(3,3),dZdNuT(3,3),AZL(3,3),E(3,3),cauchyStressTensor(3,3),cauchyStressVoigt(6),Jznu
3059 
3060  enters("FiniteElasticity_TensorInterpolateXi",err,error,*999)
3061 
3062  NULLIFY(equations)
3063  NULLIFY(dependentfield)
3064  NULLIFY(geometricinterpolatedpoint)
3065  NULLIFY(fibreinterpolatedpoint)
3066  NULLIFY(dependentinterpolatedpoint)
3067  NULLIFY(materialsinterpolatedpoint)
3068  NULLIFY(independentinterpolatedpoint)
3069  NULLIFY(darcyinterpolatedpoint)
3070  NULLIFY(decomposition)
3071  NULLIFY(decompositiontopology)
3072  NULLIFY(domaintopology)
3073  NULLIFY(elementbasis)
3074 
3075  IF(.NOT.ASSOCIATED(equationsset)) THEN
3076  CALL flagerror("Equations set is not associated.",err,error,*999)
3077  END IF
3078  equations=>equationsset%equations
3079  IF(.NOT.ASSOCIATED(equations)) THEN
3080  CALL flagerror("Equations set equations is not associated.",err,error,*999)
3081  END IF
3082 
3083  nonlinearmapping=>equations%equations_mapping%nonlinear_mapping
3084  IF(.NOT.ASSOCIATED(equations)) THEN
3085  CALL flagerror("Equations nonlinear mapping is not associated.",err,error,*999)
3086  END IF
3087  dependentvartype=nonlinearmapping%residual_variables(1)%ptr%variable_type
3088 
3089  IF(.NOT.ASSOCIATED(equations%interpolation)) THEN
3090  CALL flagerror("Equations interpolation is not associated.",err,error,*999)
3091  END IF
3092  dependentfield=>equations%interpolation%dependent_field
3093  IF(.NOT.ASSOCIATED(dependentfield)) THEN
3094  CALL flagerror("Equations dependent field is not associated.",err,error,*999)
3095  END IF
3096  decomposition=>dependentfield%decomposition
3097  IF(.NOT.ASSOCIATED(decomposition)) THEN
3098  CALL flagerror("Dependent field decomposition is not associated.",err,error,*999)
3099  END IF
3100  CALL decomposition_mesh_component_number_get(decomposition,meshcomponentnumber,err,error,*999)
3101  decompositiontopology=>decomposition%topology
3102  domaintopology=>decomposition%domain(meshcomponentnumber)%ptr%topology
3103  CALL decomposition_topology_element_check_exists(decompositiontopology,userelementnumber, &
3104  & userelementexists,localelementnumber,ghostelement,err,error,*999)
3105  IF(.NOT.userelementexists) THEN
3106  CALL flagerror("The specified user element number of "// &
3107  & trim(numbertovstring(userelementnumber,"*",err,error))// &
3108  & " does not exist in the decomposition for the dependent field.",err,error,*999)
3109  END IF
3110  CALL domaintopology_elementbasisget( &
3111  & domaintopology,userelementnumber,elementbasis,err,error,*999)
3112 
3113  !Get the interpolation parameters for this element
3114  CALL field_interpolation_parameters_element_get(field_values_set_type,localelementnumber, &
3115  & equations%interpolation%geometric_interp_parameters(field_u_variable_type)%ptr,err,error,*999)
3116  IF(ASSOCIATED(equations%interpolation%fibre_interp_parameters)) THEN
3117  CALL field_interpolation_parameters_element_get(field_values_set_type,localelementnumber, &
3118  & equations%interpolation%fibre_interp_parameters(field_u_variable_type)%ptr,err,error,*999)
3119  END IF
3120  CALL field_interpolation_parameters_element_get(field_values_set_type,localelementnumber, &
3121  & equations%interpolation%dependent_interp_parameters(dependentvartype)%ptr,err,error,*999)
3122 
3123  !Get interpolated points
3124  geometricinterpolatedpoint=>equations%interpolation%geometric_interp_point(field_u_variable_type)%ptr
3125  IF(ASSOCIATED(equations%interpolation%fibre_interp_point)) THEN
3126  fibreinterpolatedpoint=>equations%interpolation%fibre_interp_point(field_u_variable_type)%ptr
3127  END IF
3128  dependentinterpolatedpoint=>equations%interpolation%dependent_interp_point(dependentvartype)%ptr
3129 
3130  !Get interpolated point metrics
3131  geometricinterpolatedpointmetrics=>equations%interpolation% &
3132  & geometric_interp_point_metrics(field_u_variable_type)%ptr
3133  dependentinterpolatedpointmetrics=>equations%interpolation% &
3134  & dependent_interp_point_metrics(dependentvartype)%ptr
3135 
3136  !Interpolate fields at xi position
3137  CALL field_interpolate_xi(first_part_deriv,xi,dependentinterpolatedpoint,err,error,*999)
3138  CALL field_interpolate_xi(first_part_deriv,xi,geometricinterpolatedpoint,err,error,*999)
3139  IF(ASSOCIATED(fibreinterpolatedpoint)) THEN
3140  CALL field_interpolate_xi(first_part_deriv,xi,fibreinterpolatedpoint,err,error,*999)
3141  END IF
3142 
3143  !Calculate field metrics
3144  CALL field_interpolated_point_metrics_calculate( &
3145  & elementbasis%number_of_xi,geometricinterpolatedpointmetrics,err,error,*999)
3146  CALL field_interpolated_point_metrics_calculate( &
3147  & elementbasis%number_of_xi,dependentinterpolatedpointmetrics,err,error,*999)
3148 
3149  !Calculate F=dZ/dNU, the deformation gradient tensor at the xi location
3150  numberofdimensions=equationsset%region%coordinate_system%number_of_dimensions
3151  numberofxi=elementbasis%number_of_xi
3152  CALL finiteelasticity_gaussdeformationgradienttensor(dependentinterpolatedpointmetrics, &
3153  & geometricinterpolatedpointmetrics,fibreinterpolatedpoint,dzdnu,err,error,*999)
3154 
3155  IF(tensorevaluatetype==equations_set_evaluate_r_cauchy_green_deformation_tensor .OR. &
3156  & tensorevaluatetype==equations_set_evaluate_green_lagrange_strain_tensor) THEN
3157  CALL matrix_transpose(dzdnu,dzdnut,err,error,*999)
3158  CALL matrix_product(dzdnut,dzdnu,azl,err,error,*999)
3159  END IF
3160 
3161  IF(tensorevaluatetype==equations_set_evaluate_green_lagrange_strain_tensor) THEN
3162  !Calculate E
3163  e=0.5_dp*azl
3164  DO i=1,3
3165  e(i,i)=e(i,i)-0.5_dp
3166  END DO
3167  END IF
3168 
3169  IF(tensorevaluatetype==equations_set_evaluate_cauchy_stress_tensor) THEN
3170  !Get the interpolation parameters for this element
3171  CALL field_interpolation_parameters_element_get(field_values_set_type,localelementnumber, &
3172  & equations%interpolation%materials_interp_parameters(field_u_variable_type)%ptr,err,error,*999)
3173  IF(ASSOCIATED(equations%interpolation%independent_interp_parameters)) THEN
3174  CALL field_interpolation_parameters_element_get(field_values_set_type,localelementnumber, &
3175  & equations%interpolation%independent_interp_parameters(field_u_variable_type)%ptr,err,error,*999)
3176  END IF
3177 
3178  !Get interpolated points
3179  materialsinterpolatedpoint=>equations%interpolation%materials_interp_point(field_u_variable_type)%ptr
3180  IF(ASSOCIATED(equations%interpolation%independent_interp_point)) THEN
3181  independentinterpolatedpoint=>equations%interpolation%independent_interp_point(dependentvartype)%ptr
3182  END IF
3183 
3184  !Interpolate fields at xi position
3185  CALL field_interpolate_xi(no_part_deriv,xi,materialsinterpolatedpoint,err,error,*999)
3186  IF(ASSOCIATED(independentinterpolatedpoint)) THEN
3187  CALL field_interpolate_xi(first_part_deriv,xi,independentinterpolatedpoint,err,error,*999)
3188  END IF
3189 
3190  SELECT CASE(equationsset%specification(3))
3191  CASE(equations_set_mooney_rivlin_subtype)
3192  !Calculate the Cauchy stress tensor (in Voigt form) at the gauss point.
3193  jznu=dependentinterpolatedpointmetrics%JACOBIAN/geometricinterpolatedpointmetrics%JACOBIAN
3194  ! Note that some problems, e.g. active contraction, require additonal fields to be evaluated at Gauss points. This is
3195  ! currently achieved by providing the gausspoint number to the FINITE_ELASTICITY_GAUSS_STRESS_TENSOR routine.
3196  ! However, the current routine, FiniteElasticity_TensorInterpolateXi, aims to evaluate tensors as any xi, so the Gauss
3197  ! point number has been set to 0, which will generate an error for such problems.
3198  ! To address such issues, the FINITE_ELASTICITY_GAUSS_STRESS_TENSOR routine needs to be generalized to allow calculation
3199  ! of stress at any xi position and the GaussPoint number argument needs to be replace with a set of xi coordinates.
3200  CALL finite_elasticity_gauss_stress_tensor(equationsset,dependentinterpolatedpoint, &
3201  & materialsinterpolatedpoint,cauchystressvoigt,dzdnu,jznu,localelementnumber,0,err,error,*999)
3202 
3203  !Convert from Voigt form to tensor form.
3204  DO nh=1,3
3205  DO mh=1,3
3206  cauchystresstensor(mh,nh)=cauchystressvoigt(tensor_to_voigt3(mh,nh))
3207  ENDDO
3208  ENDDO
3209  CASE(equations_set_orthotropic_material_costa_subtype, equations_set_transverse_isotropic_guccione_subtype)
3210  CALL finite_elasticity_gauss_cauchy_tensor(equationsset,dependentinterpolatedpoint, &
3211  & materialsinterpolatedpoint,darcyinterpolatedpoint, &
3212  & independentinterpolatedpoint,cauchystresstensor,jznu,dzdnu,localelementnumber,0,err,error,*999)
3213  CASE DEFAULT
3214  CALL flagerror("Not implemented ",err,error,*999)
3215  END SELECT
3216  END IF
3217 
3218  SELECT CASE(tensorevaluatetype)
3219  CASE(equations_set_evaluate_deformation_gradient_tensor)
3220  values=dzdnu
3221  CASE(equations_set_evaluate_r_cauchy_green_deformation_tensor)
3222  values=azl
3223  CASE(equations_set_evaluate_green_lagrange_strain_tensor)
3224  values=e
3225  CASE(equations_set_evaluate_cauchy_stress_tensor)
3226  values=cauchystresstensor
3227  CASE(equations_set_evaluate_second_pk_stress_tensor)
3228  CALL flagerror("Not implemented.",err,error,*999)
3229  CASE DEFAULT
3230  CALL flagerror("The tensor evalaute type of "//trim(number_to_vstring(tensorevaluatetype,"*",err,error))//" is invalid "// &
3231  & "for finite elasticity equation sets",err,error,*999)
3232  END SELECT
3233 
3234  exits("FiniteElasticity_TensorInterpolateXi")
3235  RETURN
3236 999 errorsexits("FiniteElasticity_TensorInterpolateXi",err,error)
3237  RETURN 1
3238  END SUBROUTINE finiteelasticity_tensorinterpolatexi
3239 
3240  !
3241  !================================================================================================================================
3242  !
3243 
3244  !Evaluates the Jacobian surface traction (pressure) term of the equilibrium equation. Here it is assumed that pressure is constant
3245  !(if not: the jacobian has to be extended to include this) and that along the boundary of the boundary faces (the boundary line)
3246  !minimal one direction perpendicular to that boundary line is fixed, or that we have no boundary line at all (a closed body). In
3247  !these cases the jacobian is symmetrical. See Rumpel & Schweizerhof, "Hydrostatic fluid loading in non-linear finite element
3248  !analysis".
3249  SUBROUTINE finiteelasticity_surfacepressurejacobianevaluate(EQUATIONS_SET,ELEMENT_NUMBER,ERR,ERROR,*)
3250  !Argument variables
3251  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3252  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
3253  INTEGER(INTG), INTENT(OUT) :: ERR
3254  TYPE(varying_string), INTENT(OUT) :: ERROR
3255  !Local variables
3256  TYPE(basis_type), POINTER :: DEPENDENT_BASIS
3257  TYPE(basis_ptr_type) :: BASES(3)
3258  TYPE(decomposition_type), POINTER :: DECOMPOSITION
3259  TYPE(decomposition_element_type), POINTER :: ELEMENT
3260  TYPE(decomposition_face_type), POINTER :: FACE
3261  TYPE(equations_type), POINTER :: EQUATIONS
3262  TYPE(equations_mapping_type), POINTER :: EQUATIONS_MAPPING
3263  TYPE(equations_mapping_nonlinear_type), POINTER :: NONLINEAR_MAPPING
3264  TYPE(equations_matrices_type), POINTER :: EQUATIONS_MATRICES
3265  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
3266  TYPE(equations_jacobian_type), POINTER :: JACOBIAN_MATRIX
3267  TYPE(field_interpolation_parameters_type), POINTER :: DEPENDENT_INTERPOLATION_PARAMETERS
3268  TYPE(field_interpolation_parameters_type), POINTER :: PRESSURE_INTERPOLATION_PARAMETERS
3269  TYPE(field_interpolated_point_type), POINTER :: DEPENDENT_INTERP_POINT,PRESSURE_INTERP_POINT
3270  TYPE(field_interpolated_point_metrics_type), POINTER :: DEPENDENT_INTERP_POINT_METRICS
3271  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
3272  TYPE(field_type), POINTER :: DEPENDENT_FIELD
3273  TYPE(quadrature_scheme_type), POINTER :: DEPENDENT_QUADRATURE_SCHEME
3274  TYPE(quadrature_scheme_ptr_type) :: QUADRATURE_SCHEMES(3)
3275  INTEGER(INTG) :: FACE_NUMBER,xiDirection(3),orientation
3276  INTEGER(INTG) :: FIELD_VAR_U_TYPE,FIELD_VAR_DELUDELN_TYPE,MESH_COMPONENT_NUMBER
3277  INTEGER(INTG) :: oh,mh,ms,mhs,nh,ns,nhs,ng,naf
3278  INTEGER(INTG) :: NUMBER_OF_DIMENSIONS,NUMBER_OF_LOCAL_FACES
3279  INTEGER(INTG) :: SUM_ELEMENT_PARAMETERS
3280  INTEGER(INTG) :: ELEMENT_BASE_DOF_INDEX(3),NUMBER_OF_FACE_PARAMETERS(3)
3281  INTEGER(INTG), PARAMETER :: OFF_DIAG_COMP(3)=[0,1,3],off_diag_dep_var1(3)=[1,1,2],off_diag_dep_var2(3)=[2,3,3]
3282  REAL(DP) :: PRESSURE_GAUSS,GW_PRESSURE
3283  REAL(DP) :: NORMAL(3),GW_PRESSURE_W(2),TEMP3, TEMP4
3284  REAL(DP) :: TEMPVEC1(2),TEMPVEC2(2),TEMPVEC3(3),TEMPVEC4(3),TEMPVEC5(3)
3285  LOGICAL :: NONZERO_PRESSURE
3286 
3287  enters("FiniteElasticity_SurfacePressureJacobianEvaluate",err,error,*999)
3288 
3289  NULLIFY(dependent_basis)
3290  NULLIFY(decomposition)
3291  NULLIFY(element)
3292  NULLIFY(equations,equations_mapping,equations_matrices,nonlinear_mapping,nonlinear_matrices,jacobian_matrix)
3293  NULLIFY(dependent_interpolation_parameters,pressure_interpolation_parameters)
3294  NULLIFY(dependent_interp_point,dependent_interp_point_metrics,pressure_interp_point)
3295  NULLIFY(dependent_field)
3296  NULLIFY(field_variable)
3297  NULLIFY(dependent_quadrature_scheme)
3298 
3299  number_of_dimensions=equations_set%REGION%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
3300 
3301  equations=>equations_set%EQUATIONS
3302  equations_matrices=>equations%EQUATIONS_MATRICES
3303  nonlinear_matrices=>equations_matrices%NONLINEAR_MATRICES
3304  jacobian_matrix=>nonlinear_matrices%JACOBIANS(1)%PTR
3305 
3306  dependent_field=>equations%INTERPOLATION%DEPENDENT_FIELD
3307  decomposition=>dependent_field%DECOMPOSITION
3308  mesh_component_number=decomposition%MESH_COMPONENT_NUMBER
3309  element=>decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)
3310  number_of_local_faces=dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
3311  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS%NUMBER_OF_LOCAL_FACES
3312 
3313  field_variable=>equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR
3314  field_var_u_type=equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR%VARIABLE_TYPE
3315  field_var_deludeln_type=equations%EQUATIONS_MAPPING%RHS_MAPPING%RHS_VARIABLE_TYPE
3316 
3317  !Surface pressure term calculation: Loop over all faces
3318  DO naf=1,number_of_local_faces
3319  face_number=element%ELEMENT_FACES(naf)
3320  face=>decomposition%TOPOLOGY%FACES%FACES(face_number)
3321 
3322  !Check if it's a boundary face
3323  IF(face%BOUNDARY_FACE) THEN
3324  xidirection(3)=abs(face%XI_DIRECTION)
3325 
3326  pressure_interpolation_parameters=>equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_deludeln_type)%PTR
3327  CALL field_interpolation_parameters_face_get(field_pressure_values_set_type,face_number, &
3328  & pressure_interpolation_parameters,err,error,*999,field_geometric_components_type)
3329  pressure_interp_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(field_var_deludeln_type)%PTR
3330 
3331  !Check if nonzero surface pressure is defined on the face
3332  nonzero_pressure=any(abs(pressure_interpolation_parameters%PARAMETERS(:,xidirection(3)))>zero_tolerance)
3333 
3334  !Nonzero surface pressure found?
3335  IF(nonzero_pressure) THEN
3336  mesh_component_number=decomposition%MESH_COMPONENT_NUMBER
3337  dependent_basis=>decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%FACES%FACES(face_number)%BASIS
3338  dependent_quadrature_scheme=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
3339 
3340  dependent_interpolation_parameters=>equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_u_type)%PTR
3341  CALL field_interpolation_parameters_face_get(field_values_set_type,face_number, &
3342  & dependent_interpolation_parameters,err,error,*999,field_geometric_components_type)
3343  dependent_interp_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(field_var_u_type)%PTR
3344  dependent_interp_point_metrics=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT_METRICS(field_var_u_type)%PTR
3345 
3346  sum_element_parameters=0
3347  !Loop over geometric dependent basis functions.
3348  DO nh=1,number_of_dimensions
3349  mesh_component_number=field_variable%COMPONENTS(nh)%MESH_COMPONENT_NUMBER
3350  dependent_basis=>decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%FACES%FACES(face_number)%BASIS
3351  bases(nh)%PTR=>decomposition%DOMAIN(mesh_component_number)%PTR% &
3352  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
3353  quadrature_schemes(nh)%PTR=>dependent_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
3354  number_of_face_parameters(nh)=dependent_basis%NUMBER_OF_ELEMENT_PARAMETERS
3355  element_base_dof_index(nh)=sum_element_parameters
3356  sum_element_parameters=sum_element_parameters+bases(nh)%PTR%NUMBER_OF_ELEMENT_PARAMETERS
3357  ENDDO !nh
3358 
3359  xidirection(1)=other_xi_directions3(xidirection(3),2,1)
3360  xidirection(2)=other_xi_directions3(xidirection(3),3,1)
3361  orientation=sign(1,other_xi_orientations3(xidirection(1),xidirection(2))*face%XI_DIRECTION)
3362 
3363  !Loop over all Gauss points
3364  DO ng=1,dependent_quadrature_scheme%NUMBER_OF_GAUSS
3365  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,ng, &
3366  & pressure_interp_point,err,error,*999,field_geometric_components_type)
3367  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,ng, &
3368  & dependent_interp_point,err,error,*999,field_geometric_components_type)
3369  CALL field_interpolated_point_metrics_calculate(coordinate_jacobian_area_type, &
3370  & dependent_interp_point_metrics,err,error,*999)
3371 
3372  CALL cross_product(dependent_interp_point_metrics%DX_DXI(:,1), &
3373  & dependent_interp_point_metrics%DX_DXI(:,2),normal,err,error,*999)
3374  pressure_gauss=pressure_interp_point%VALUES(xidirection(3),no_part_deriv)*orientation
3375  gw_pressure=dependent_quadrature_scheme%GAUSS_WEIGHTS(ng)*pressure_gauss
3376 
3377  DO oh=1,off_diag_comp(number_of_dimensions)
3378  nh=off_diag_dep_var1(oh)
3379  mh=off_diag_dep_var2(oh)
3380  gw_pressure_w(1:2)=(normal(mh)*dependent_interp_point_metrics%DXI_DX(1:2,nh)- &
3381  & dependent_interp_point_metrics%DXI_DX(1:2,mh)*normal(nh))*gw_pressure
3382  DO ns=1,number_of_face_parameters(nh)
3383  !Loop over element rows belonging to geometric dependent variables
3384  nhs=element_base_dof_index(nh)+ &
3385  & bases(nh)%PTR%ELEMENT_PARAMETERS_IN_LOCAL_FACE(ns,naf)
3386  tempvec1(1:2)=gw_pressure_w(1:2)*quadrature_schemes(nh)%PTR% &
3387  & gauss_basis_fns(ns,partial_derivative_first_derivative_map(1:2),ng)
3388  DO ms=1,number_of_face_parameters(mh)
3389  mhs=element_base_dof_index(mh)+ &
3390  & bases(mh)%PTR%ELEMENT_PARAMETERS_IN_LOCAL_FACE(ms,naf)
3391  tempvec2=quadrature_schemes(mh)%PTR%GAUSS_BASIS_FNS(ms,no_part_deriv,ng)
3392  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(mhs,nhs)+ &
3393  & dot_product(tempvec1,tempvec2)* &
3394  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_u_type)%PTR%SCALE_FACTORS(ms,mh)* &
3395  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_u_type)%PTR%SCALE_FACTORS(ns,nh)
3396  ENDDO !ms
3397  ENDDO !ns
3398  ENDDO !oh
3399 
3400  DO oh=1,off_diag_comp(number_of_dimensions)
3401  nh=off_diag_dep_var1(oh)
3402  mh=off_diag_dep_var2(oh)
3403  gw_pressure_w(1:2)=(normal(nh)*dependent_interp_point_metrics%DXI_DX(1:2,mh)- &
3404  & dependent_interp_point_metrics%DXI_DX(1:2,nh)*normal(mh))*gw_pressure
3405  DO ms=1,number_of_face_parameters(mh)
3406  !Loop over element rows belonging to geometric dependent variables
3407  mhs=element_base_dof_index(mh)+ &
3408  & bases(mh)%PTR%ELEMENT_PARAMETERS_IN_LOCAL_FACE(ms,naf)
3409  tempvec1(1:2)=gw_pressure_w(1:2)*quadrature_schemes(mh)%PTR% &
3410  & gauss_basis_fns(ms,partial_derivative_first_derivative_map(1:2),ng)
3411  DO ns=1,number_of_face_parameters(nh)
3412  nhs=element_base_dof_index(nh)+ &
3413  & bases(nh)%PTR%ELEMENT_PARAMETERS_IN_LOCAL_FACE(ns,naf)
3414  tempvec2=quadrature_schemes(nh)%PTR%GAUSS_BASIS_FNS(ns,no_part_deriv,ng)
3415  jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(nhs,mhs)=jacobian_matrix%ELEMENT_JACOBIAN%MATRIX(nhs,mhs)+ &
3416  & dot_product(tempvec1,tempvec2)* &
3417  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_u_type)%PTR%SCALE_FACTORS(ms,mh)* &
3418  & equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_u_type)%PTR%SCALE_FACTORS(ns,nh)
3419  ENDDO !ns
3420  ENDDO !ms
3421  ENDDO !oh
3422  ENDDO !ng
3423  ENDIF !Non-zero pressure on face
3424  ENDIF !Boundary face
3425  ENDDO !naf
3426 
3427  exits("FiniteElasticity_SurfacePressureJacobianEvaluate")
3428  RETURN
3429 999 errors("FiniteElasticity_SurfacePressureJacobianEvaluate",err,error)
3430  exits("FiniteElasticity_SurfacePressureJacobianEvaluate")
3431  RETURN 1
3432 
3433  END SUBROUTINE finiteelasticity_surfacepressurejacobianevaluate
3434 
3435  !
3436  !================================================================================================================================
3437  !
3438 
3439  !Evaluates the surface traction (pressure) term of the equilibrium equation
3440  SUBROUTINE finiteelasticity_surfacepressureresidualevaluate(EQUATIONS_SET,ELEMENT_NUMBER,var1,var2,ERR,ERROR,*)
3441  !Argument variables
3442  TYPE(equations_set_type), POINTER :: EQUATIONS_SET
3443  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER
3444  INTEGER(INTG), INTENT(IN) :: var1
3445  INTEGER(INTG), INTENT(IN) :: var2
3446  INTEGER(INTG), INTENT(OUT) :: ERR
3447  TYPE(varying_string), INTENT(OUT) :: ERROR
3448  !Local variables
3449  TYPE(basis_type), POINTER :: DEPENDENT_FACE_BASIS,COMPONENT_FACE_BASIS,COMPONENT_BASIS
3450  TYPE(decomposition_type), POINTER :: DECOMPOSITION
3451  TYPE(decomposition_element_type), POINTER :: DECOMP_ELEMENT
3452  TYPE(decomposition_face_type), POINTER :: DECOMP_FACE
3453  TYPE(equations_type), POINTER :: EQUATIONS
3454  TYPE(equations_matrices_nonlinear_type), POINTER :: NONLINEAR_MATRICES
3455  TYPE(field_type), POINTER :: DEPENDENT_FIELD
3456  TYPE(field_interpolation_parameters_type), POINTER :: FACE_DEPENDENT_INTERPOLATION_PARAMETERS
3457  TYPE(field_interpolation_parameters_type), POINTER :: FACE_PRESSURE_INTERPOLATION_PARAMETERS
3458  TYPE(field_interpolated_point_type), POINTER :: FACE_DEPENDENT_INTERPOLATED_POINT
3459  TYPE(field_interpolated_point_metrics_type), POINTER :: FACE_DEPENDENT_INTERPOLATED_POINT_METRICS
3460  TYPE(field_interpolated_point_type), POINTER :: FACE_PRESSURE_INTERPOLATED_POINT
3461  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
3462  TYPE(quadrature_scheme_type), POINTER :: FACE_QUADRATURE_SCHEME,COMPONENT_FACE_QUADRATURE_SCHEME
3463  INTEGER(INTG) :: FIELD_VAR_U_TYPE,FIELD_VAR_DUDN_TYPE,MESH_COMPONENT_NUMBER
3464  INTEGER(INTG) :: element_face_idx,face_number,gauss_idx
3465  INTEGER(INTG) :: component_idx,element_base_dof_idx,element_dof_idx,parameter_idx,face_parameter_idx
3466  INTEGER(INTG) :: NUMBER_OF_DIMENSIONS,NUMBER_OF_LOCAL_FACES
3467  INTEGER(INTG) :: xiDirection(3),orientation
3468  REAL(DP) :: PRESSURE_GAUSS,GW_PRESSURE,GW_PRESSURE_NORMAL_COMPONENT
3469  REAL(DP) :: NORMAL(3)
3470  LOGICAL :: NONZERO_PRESSURE
3471 
3472  enters("FiniteElasticity_SurfacePressureResidualEvaluate",err,error,*999)
3473 
3474  NULLIFY(dependent_face_basis,component_face_basis,component_basis)
3475  NULLIFY(decomposition)
3476  NULLIFY(decomp_element)
3477  NULLIFY(decomp_face)
3478  NULLIFY(equations)
3479  NULLIFY(equations,nonlinear_matrices)
3480  NULLIFY(dependent_field,field_variable)
3481  NULLIFY(face_dependent_interpolation_parameters)
3482  NULLIFY(face_dependent_interpolated_point,face_dependent_interpolated_point_metrics)
3483  NULLIFY(face_pressure_interpolation_parameters,face_pressure_interpolated_point)
3484  NULLIFY(component_face_quadrature_scheme,face_quadrature_scheme)
3485 
3486  number_of_dimensions=equations_set%REGION%COORDINATE_SYSTEM%NUMBER_OF_DIMENSIONS
3487 
3488  !Grab pointers of interest
3489  equations=>equations_set%EQUATIONS
3490  nonlinear_matrices=>equations%EQUATIONS_MATRICES%NONLINEAR_MATRICES
3491  dependent_field=>equations%INTERPOLATION%DEPENDENT_FIELD
3492  decomposition=>dependent_field%DECOMPOSITION
3493  mesh_component_number=decomposition%MESH_COMPONENT_NUMBER
3494  decomp_element=>decomposition%TOPOLOGY%ELEMENTS%ELEMENTS(element_number)
3495 
3496  !Interpolation parameter for metric tensor
3497  field_variable=>equations%EQUATIONS_MAPPING%NONLINEAR_MAPPING%RESIDUAL_VARIABLES(1)%PTR
3498  field_var_u_type=field_variable%VARIABLE_TYPE
3499  field_var_dudn_type=equations%EQUATIONS_MAPPING%RHS_MAPPING%RHS_VARIABLE_TYPE
3500  number_of_local_faces=decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%ELEMENTS% &
3501  & elements(element_number)%BASIS%NUMBER_OF_LOCAL_FACES
3502 
3503  !Surface pressure term calculation: Loop over all faces
3504  DO element_face_idx=1,number_of_local_faces
3505  face_number=decomp_element%ELEMENT_FACES(element_face_idx)
3506  decomp_face=>decomposition%TOPOLOGY%FACES%FACES(face_number)
3507 
3508  !Check if it's a boundary face
3509  IF(decomp_face%BOUNDARY_FACE) THEN !!temporary until MESH_FACE (or equivalent) is available (decomp face includes ghost faces?)
3510  xidirection(3)=abs(decomp_face%XI_DIRECTION) ! if xi=0, this can be a negative number
3511  !Get pressure interpolation objects (DELUDELN pressure_values_set_type)
3512  face_pressure_interpolation_parameters=>equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_dudn_type)%PTR
3513  CALL field_interpolation_parameters_face_get(field_pressure_values_set_type,face_number, &
3514  & face_pressure_interpolation_parameters,err,error,*999,field_geometric_components_type)
3515  face_pressure_interpolated_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(var2)%PTR
3516 
3517  !Check if nonzero surface pressure is defined on the face
3518  nonzero_pressure=any(abs(face_pressure_interpolation_parameters%PARAMETERS(:,xidirection(3)))>zero_tolerance)
3519 
3520  !Nonzero surface pressure found?
3521  IF(nonzero_pressure) THEN
3522  !Grab some other pointers
3523  dependent_face_basis=>decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%FACES%FACES(face_number)%BASIS
3524  face_quadrature_scheme=>dependent_face_basis%QUADRATURE%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
3525 
3526  face_dependent_interpolation_parameters=>equations%INTERPOLATION%DEPENDENT_INTERP_PARAMETERS(field_var_u_type)%PTR
3527  CALL field_interpolation_parameters_face_get(field_values_set_type,face_number, &
3528  & face_dependent_interpolation_parameters,err,error,*999,field_geometric_components_type)
3529  face_dependent_interpolated_point=>equations%INTERPOLATION%DEPENDENT_INTERP_POINT(field_var_u_type)%PTR
3530  face_dependent_interpolated_point_metrics=>equations%INTERPOLATION% &
3531  & dependent_interp_point_metrics(field_var_u_type)%PTR
3532 
3533  xidirection(1)=other_xi_directions3(xidirection(3),2,1)
3534  xidirection(2)=other_xi_directions3(xidirection(3),3,1)
3535  orientation=sign(1,other_xi_orientations3(xidirection(1),xidirection(2))*decomp_face%XI_DIRECTION)
3536 
3537  !Start integrating
3538  ! Note: As the code will look for P(appl) in the *normal* component to the face, the
3539  ! initial assignment of P(appl) will have to be made appropriately during bc assignment
3540  DO gauss_idx=1,face_quadrature_scheme%NUMBER_OF_GAUSS
3541  !Interpolate p(appl) at gauss point
3542  CALL field_interpolate_gauss(no_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
3543  & face_pressure_interpolated_point,err,error,*999,field_geometric_components_type)
3544  CALL field_interpolate_gauss(first_part_deriv,basis_default_quadrature_scheme,gauss_idx, &
3545  & face_dependent_interpolated_point,err,error,*999)
3546  CALL field_interpolated_point_metrics_calculate(coordinate_jacobian_area_type, &
3547  & face_dependent_interpolated_point_metrics,err,error,*999)
3548 
3549  CALL cross_product(face_dependent_interpolated_point_metrics%DX_DXI(:,1), &
3550  & face_dependent_interpolated_point_metrics%DX_DXI(:,2),normal,err,error,*999)
3551  pressure_gauss=face_pressure_interpolated_point%VALUES(xidirection(3),no_part_deriv)*orientation
3552  gw_pressure=face_quadrature_scheme%GAUSS_WEIGHTS(gauss_idx)*pressure_gauss
3553  element_base_dof_idx=0
3554  !Loop over 3 components
3555  DO component_idx=1,number_of_dimensions
3556  mesh_component_number=field_variable%COMPONENTS(component_idx)%MESH_COMPONENT_NUMBER
3557  component_basis=>dependent_field%DECOMPOSITION%DOMAIN(mesh_component_number)%PTR% &
3558  & topology%ELEMENTS%ELEMENTS(element_number)%BASIS
3559  component_face_basis=>decomposition%DOMAIN(mesh_component_number)%PTR%TOPOLOGY%FACES%FACES(face_number)%BASIS
3560  component_face_quadrature_scheme=>component_face_basis% &
3561  & quadrature%QUADRATURE_SCHEME_MAP(basis_default_quadrature_scheme)%PTR
3562  gw_pressure_normal_component=gw_pressure*normal(component_idx)
3563  DO face_parameter_idx=1,component_face_basis%NUMBER_OF_ELEMENT_PARAMETERS
3564  parameter_idx=component_basis%ELEMENT_PARAMETERS_IN_LOCAL_FACE(face_parameter_idx,element_face_idx)
3565  element_dof_idx=element_base_dof_idx+parameter_idx
3566  nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)= &
3567  & nonlinear_matrices%ELEMENT_RESIDUAL%VECTOR(element_dof_idx)+ & ! sign: double -'s. p(appl) always opposite to normal'
3568  & gw_pressure_normal_component * &
3569  & component_face_quadrature_scheme%GAUSS_BASIS_FNS(face_parameter_idx,no_part_deriv,gauss_idx)
3570  ENDDO !face_parameter_idx
3571  !Update element_base_dof_idx
3572  element_base_dof_idx=element_base_dof_idx+component_basis%NUMBER_OF_ELEMENT_PARAMETERS
3573  ENDDO !component_idx
3574  ENDDO !gauss_idx
3575  ENDIF !nonzero surface pressure check
3576  ENDIF !boundary face check
3577  ENDDO !element_face_idx
3578 
3579  exits("FiniteElasticity_SurfacePressureResidualEvaluate")
3580  RETURN
3581 999 errors("FiniteElasticity_SurfacePressureResidualEvaluate",err,error)
3582  exits("FiniteElasticity_SurfacePressureResidualEvaluate")
3583  RETURN 1
3584 
3585  END SUBROUTINE finiteelasticity_surfacepressureresidualevaluate
3586 
3587  !
3588  !================================================================================================================================
3589  !
3590 
3592  SUBROUTINE finiteelasticity_gaussdeformationgradienttensor(dependentInterpPointMetrics,geometricInterpPointMetrics,&
3593  & fibreinterpolatedpoint,dzdnu,err,error,*)
3594 
3595  !Argument variables
3596  TYPE(field_interpolated_point_metrics_type), POINTER :: dependentInterpPointMetrics,geometricInterpPointMetrics
3597  TYPE(field_interpolated_point_type), POINTER :: fibreInterpolatedPoint
3598  REAL(DP), INTENT(OUT) :: dZdNu(3,3)
3599  INTEGER(INTG), INTENT(OUT) :: err
3600  TYPE(varying_string), INTENT(OUT) :: error
3601  !Local Variables
3602  INTEGER(INTG) :: numberOfXDimensions,numberOfXiDimensions,numberOfZDimensions
3603  REAL(DP) :: dNuDXi(3,3),dXidNu(3,3), dNudX(3,3),dXdNu(3,3)
3604 
3605  enters("FiniteElasticity_GaussDeformationGradientTensor",err,error,*999)
3606 
3607  IF(ASSOCIATED(dependentinterppointmetrics)) THEN
3608  IF(ASSOCIATED(geometricinterppointmetrics)) THEN
3609  numberofxdimensions=geometricinterppointmetrics%NUMBER_OF_X_DIMENSIONS
3610  numberofxidimensions=geometricinterppointmetrics%NUMBER_OF_XI_DIMENSIONS
3611  numberofzdimensions=dependentinterppointmetrics%NUMBER_OF_X_DIMENSIONS
3612 
3613  CALL coordinates_materialsystemcalculate(geometricinterppointmetrics,fibreinterpolatedpoint,dnudx,dxdnu, &
3614  & dnudxi(1:numberofxdimensions,1:numberofxidimensions), &
3615  & dxidnu(1:numberofxidimensions,1:numberofxdimensions),err,error,*999)
3616  !dZ/dNu = dZ/dXi * dXi/dNu (deformation gradient tensor, F)
3617  CALL matrixproduct(dependentinterppointmetrics%DX_DXI(1:numberofzdimensions,1:numberofxidimensions), &
3618  & dxidnu(1:numberofxidimensions,1:numberofxdimensions),dzdnu(1:numberofzdimensions,1:numberofxdimensions), &
3619  & err,error,*999)
3620 
3621  IF(numberofzdimensions == 2) THEN
3622  dzdnu(:,3) = [0.0_dp,0.0_dp,1.0_dp]
3623  dzdnu(3,1:2) = 0.0_dp
3624  ENDIF
3625 
3626  IF(diagnostics1) THEN
3627  CALL writestring(diagnostic_output_type,"",err,error,*999)
3628  CALL writestring(diagnostic_output_type,"Calculated deformation gradient tensor:",err,error,*999)
3629  CALL writestringvalue(diagnostic_output_type," Number of Z dimensions = ",numberofzdimensions,err,error,*999)
3630  CALL writestringvalue(diagnostic_output_type," Number of Xi dimensions = ",numberofxidimensions,err,error,*999)
3631  CALL writestringmatrix(diagnostic_output_type,1,1,numberofxdimensions,1,1,numberofxdimensions, &
3632  & numberofxdimensions,numberofxdimensions,dzdnu,write_string_matrix_name_and_indices, &
3633  & '(" dZdNu','(",I1,",:)',' :",3(X,E13.6))','(15X,3(X,E13.6))',err,error,*999)
3634  ENDIF
3635 
3636  ELSE
3637  CALL flagerror("Geometric interpolated point metrics is not associated.",err,error,*999)
3638  ENDIF
3639  ELSE
3640  CALL flagerror("Dependent interpolated point metrics is not associated.",err,error,*999)
3641  ENDIF
3642 
3643  exits("FiniteElasticity_GaussDeformationGradientTensor")
3644  RETURN
3645 999 errors("FiniteElasticity_GaussDeformationGradientTensor",err,error)
3646  exits("FiniteElasticity_GaussDeformationGradientTensor")
3647  RETURN 1
3648 
3649  END SUBROUTINE finiteelasticity_gaussdeformationgradienttensor
3650 
3651  !
3652  !================================================================================================================================
3653  !
3654 
3656  SUBROUTINE finite_elasticity_gauss_cauchy_tensor(EQUATIONS_SET,DEPENDENT_INTERPOLATED_POINT, &
3657  & materials_interpolated_point,darcy_dependent_interpolated_point, &
3658  & independent_interpolated_point,cauchy_tensor,jznu,dzdnu,element_number,gauss_point_number,err,error,*)
3659 
3660  !Argument variables
3661  TYPE(equations_set_type), POINTER, INTENT(IN) :: EQUATIONS_SET
3662  TYPE(field_interpolated_point_type), POINTER :: DEPENDENT_INTERPOLATED_POINT,MATERIALS_INTERPOLATED_POINT
3663  TYPE(field_interpolated_point_type), POINTER :: DARCY_DEPENDENT_INTERPOLATED_POINT
3664  TYPE(field_interpolated_point_type), POINTER :: INDEPENDENT_INTERPOLATED_POINT
3665  REAL(DP), INTENT(OUT) :: CAUCHY_TENSOR(:,:)
3666  REAL(DP), INTENT(OUT) :: Jznu !Determinant of deformation gradient tensor (AZL)
3667  REAL(DP), INTENT(IN) :: DZDNU(3,3) !Deformation gradient tensor at the Guass point
3668  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER,GAUSS_POINT_NUMBER
3669  INTEGER(INTG), INTENT(OUT) :: ERR
3670  TYPE(varying_string), INTENT(OUT) :: ERROR
3671  !Local Variables
3672  INTEGER(INTG) :: EQUATIONS_SET_SUBTYPE
3673  INTEGER(INTG) :: i,j,k,PRESSURE_COMPONENT,component_idx,dof_idx
3674  REAL(DP) :: activation
3675  REAL(DP) :: AZL(3,3),AZU(3,3),DZDNUT(3,3),PIOLA_TENSOR(3,3),E(3,3),P,IDENTITY(3,3),AZLT(3,3),AZUT(3,3)
3676  REAL(DP) :: AZL_SQUARED(3,3)
3677  REAL(DP) :: I1,I2,I3 !Invariants, if needed
3678  REAL(DP) :: ACTIVE_STRESS_11,ACTIVE_STRESS_22,ACTIVE_STRESS_33 !Active stress to be copied in from independent field.
3679  REAL(DP) :: TEMP(3,3),TEMPTERM !Temporary variables
3680  TYPE(varying_string) :: LOCAL_ERROR
3681  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
3682  REAL(DP), DIMENSION (:), POINTER :: C !Parameters for constitutive laws
3683  REAL(DP) :: a, B(3,3), Q !Parameters for orthotropic laws
3684  REAL(DP) :: ffact,dfdJfact !coupled elasticity Darcy
3685  INTEGER(INTG) :: DARCY_MASS_INCREASE_ENTRY !position of mass-increase entry in dependent-variable vector
3686  REAL(DP) :: VALUE,VAL1,VAL2
3687  REAL(DP) :: WV_PRIME,TOL,TOL1,UP,LOW
3688  REAL(DP) :: F_e(3,3),F_a(3,3),F_a_inv(3,3),F_a_T(3,3),C_a(3,3),C_a_inv(3,3),lambda_a,C_e(3,3),F_e_T(3,3)
3689  REAL(DP) :: REFERENCE_VOLUME,XB_STIFFNESS,XB_DISTORTION,V_MAX
3690  REAL(DP) :: SARCO_LENGTH,FREE_ENERGY,FREE_ENERGY_0,XB_ENERGY_PER_VOLUME,SLOPE,lambda_f,A_1,A_2,x_1,x_2
3691  REAL(DP) :: MAX_XB_NUMBER_PER_VOLUME,ENERGY_PER_XB,FORCE_LENGTH,I_1e,EVALUES(3),EVECTOR_1(3),EVECTOR_2(3),EVECTOR_3(3)
3692  REAL(DP) :: EMATRIX_1(3,3),EMATRIX_2(3,3),EMATRIX_3(3,3),TEMP1(3,3),TEMP2(3,3),TEMP3(3,3),N1(3,3),N2(3,3),N3(3,3)
3693  REAL(DP), DIMENSION(5) :: PAR
3694  INTEGER(INTG) :: LWORK,node1,node2
3695  INTEGER(INTG), PARAMETER :: LWMAX=1000
3696  REAL(DP) :: WORK(lwmax),RIGHT_NODE(3),LEFT_NODE(3),delta_t,dist1,dist2,velo
3697  TYPE(field_type), POINTER :: DEPENDENT_FIELD,INDEPENDENT_FIELD
3698  REAL(DP) :: ISOMETRIC_FORCE_AT_FULL_ACT,LENGTH_HALF_SARCO
3699  REAL(DP) :: TITIN_VALUE,TITIN_VALUE_CROSS_FIBRE,TITIN_UNBOUND,TITIN_BOUND
3700  REAL(DP) :: TITIN_UNBOUND_CROSS_FIBRE,TITIN_BOUND_CROSS_FIBRE
3701 
3702  enters("FINITE_ELASTICITY_GAUSS_CAUCHY_TENSOR",err,error,*999)
3703 
3704  NULLIFY(field_variable)
3705 
3706  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
3707  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
3708  ELSE IF(SIZE(equations_set%SPECIFICATION,1)/=3) THEN
3709  CALL flagerror("Equations set specification must have three entries for a finite elasticity type equations set.", &
3710  & err,error,*999)
3711  END IF
3712  equations_set_subtype=equations_set%SPECIFICATION(3)
3713  c=>materials_interpolated_point%VALUES(:,1)
3714 
3715  !AZL = F'*F (deformed covariant or right cauchy deformation tensor, C)
3716  !AZU - deformed contravariant tensor; I3 = det(C)
3717  !E = Green-Lagrange strain tensor = 0.5*(C-I)
3718  !PIOLA_TENSOR is the second Piola-Kirchoff tensor (PK2 or S)
3719  !P is the actual hydrostatic pressure, not double it
3720 
3721  CALL matrix_transpose(dzdnu,dzdnut,err,error,*999)
3722  CALL matrix_product(dzdnut,dzdnu,azl,err,error,*999)
3723  jznu = determinant(dzdnu,err,error)
3724 
3725  pressure_component=dependent_interpolated_point%INTERPOLATION_PARAMETERS%FIELD_VARIABLE%NUMBER_OF_COMPONENTS
3726  p=dependent_interpolated_point%VALUES(pressure_component,1)
3727 
3728  CALL invert(azl,azu,i3,err,error,*999)
3729 
3730  e = 0.5_dp*azl
3731  DO i=1,3
3732  e(i,i)=e(i,i)-0.5_dp
3733  ENDDO
3734  IF(diagnostics1) THEN
3735  CALL write_string_matrix(diagnostic_output_type,1,1,3,1,1,3, &
3736  & 3,3,e,write_string_matrix_name_and_indices,'(" E','(",I1,",:)',' :",3(X,E13.6))', &
3737  & '(17X,3(X,E13.6))',err,error,*999)
3738  ENDIF
3739  identity=0.0_dp
3740  DO i=1,3
3741  identity(i,i)=1.0_dp
3742  ENDDO
3743 
3744  SELECT CASE(equations_set_subtype)
3745  CASE(equations_set_nearly_incompressible_mooney_rivlin_subtype)
3746  !Form of constitutive model is:
3747  ! W_hat=c1*(I1_hat-3)+c2*(I2_hat-3)+p*J*C^(-1) + W^v(J)
3748  ! take W^v(J) = 1/2 * kappa * (J-1)^2
3749  wv_prime = c(3)*(jznu - 1.0_dp)
3750  !compute the invariants, I3 a few lines up
3751  i1 = azl(1,1) + azl(2,2) + azl(3,3)
3752  CALL matrix_product(azl,azl,azl_squared,err,error,*999)
3753  i2 = 0.5_dp * (i1**2 - azl_squared(1,1) - azl_squared(2,2) - azl_squared(3,3))
3754 
3755  piola_tensor=2.0_dp*jznu**(-2.0_dp/3.0_dp)*((c(1)+c(2)*i1)*identity-c(2)*azl &
3756  & -(c(1)*i1+2.0_dp*c(2)*i2-1.5_dp*wv_prime*jznu**(5.0_dp/3.0_dp))/3.0_dp*azu)
3757 
3758  CASE(equations_set_incompressible_mooney_rivlin_subtype)
3759  !Form of constitutive model is:
3760  ! W_hat=c1*(I1_hat-3)+c2*(I2_hat-3)+p*J*C^(-1)
3761 
3762  !compute the invariants, I3 a few lines up
3763  i1 = azl(1,1) + azl(2,2) + azl(3,3)
3764  CALL matrix_product(azl,azl,azl_squared,err,error,*999)
3765  i2 = 0.5_dp * (i1**2 - azl_squared(1,1) - azl_squared(2,2) - azl_squared(3,3))
3766 
3767  !compute 2PK
3768 ! PIOLA_TENSOR(1,1) = 2.0_DP * Jznu**(-2.0_DP/3.0_DP) * (C(1) + C(2) * I1 - C(2) * AZL(1,1) &
3769 ! & - (C(1) * I1 + 2.0_DP * C(2) * I2 - 1.5_DP * P * Jznu**(5.0_DP/3.0_DP)) / 3.0_DP * AZU(1,1))
3770 ! PIOLA_TENSOR(1,2) = 2.0_DP * Jznu**(-2.0_DP/3.0_DP) * (-C(2) * AZL(1,2) &
3771 ! & - (C(1) * I1 + 2.0_DP * C(2) * I2 - 1.5_DP * P * Jznu**(5.0_DP/3.0_DP)) / 3.0_DP * AZU(1,2))
3772 ! PIOLA_TENSOR(1,3) = 2.0_DP * Jznu**(-2.0_DP/3.0_DP) * (-C(2) * AZL(1,3) &
3773 ! & - (C(1) * I1 + 2.0_DP * C(2) * I2 - 1.5_DP * P * Jznu**(5.0_DP/3.0_DP)) / 3.0_DP * AZU(1,3))
3774 ! PIOLA_TENSOR(2,1) = PIOLA_TENSOR(1,2)
3775 ! PIOLA_TENSOR(2,2) = 2.0_DP * Jznu**(-2.0_DP/3.0_DP) * (C(1) + C(2) * I1 - C(2) * AZL(2,2) &
3776 ! & - (C(1) * I1 + 2.0_DP * C(2) * I2 - 1.5_DP * P * Jznu**(5.0_DP/3.0_DP)) / 3.0_DP * AZU(2,2))
3777 ! PIOLA_TENSOR(2,3) = 2.0_DP * Jznu**(-2.0_DP/3.0_DP) * (-C(2) * AZL(2,3) &
3778 ! & - (C(1) * I1 + 2.0_DP * C(2) * I2 - 1.5_DP * P * Jznu**(5.0_DP/3.0_DP)) / 3.0_DP * AZU(2,3))
3779 ! PIOLA_TENSOR(3,1) = PIOLA_TENSOR(1,3)
3780 ! PIOLA_TENSOR(3,2) = PIOLA_TENSOR(2,3)
3781 ! PIOLA_TENSOR(3,3) = 2.0_DP * Jznu**(-2.0_DP/3.0_DP) * (C(1) + C(2) * I1 - C(2) * AZL(3,3) &
3782 ! & - (C(1) * I1 + 2.0_DP * C(2) * I2 - 1.5_DP * P * Jznu**(5.0_DP/3.0_DP)) / 3.0_DP * AZU(3,3))
3783  !????
3784  piola_tensor=2.0_dp*jznu**(-2.0_dp/3.0_dp)*((c(1)+c(2)*i1)*identity-c(2)*azl &
3785  & -(c(1)*i1+2.0_dp*c(2)*i2-1.5_dp*p*jznu**(5.0_dp/3.0_dp))/3.0_dp*azu)
3786 
3787  CASE(equations_set_active_strain_subtype)
3788 
3789  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
3790  node1=dependent_field%decomposition%domain(1)%ptr%topology%elements%elements(element_number)%element_nodes(13)
3791  node2=dependent_field%decomposition%domain(1)%ptr%topology%elements%elements(element_number)%element_nodes(15)
3792 
3793  NULLIFY(field_variable)
3794  ! compute the nodal distance of the previous time step
3795  CALL field_variable_get(dependent_field,field_v_variable_type,field_variable,err,error,*999)
3796  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
3797  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,left_node(1), &
3798  & err,error,*999)
3799  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
3800  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,left_node(2), &
3801  & err,error,*999)
3802  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
3803  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,left_node(3), &
3804  & err,error,*999)
3805 
3806  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
3807  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,right_node(1), &
3808  & err,error,*999)
3809  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
3810  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,right_node(2), &
3811  & err,error,*999)
3812  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
3813  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,right_node(3), &
3814  & err,error,*999)
3815 
3816  dist1=sqrt((right_node(1)-left_node(1))*(right_node(1)-left_node(1))+ &
3817  & (right_node(2)-left_node(2))*(right_node(2)-left_node(2))+ &
3818  & (right_node(3)-left_node(3))*(right_node(3)-left_node(3)))
3819 
3820  NULLIFY(field_variable)
3821  ! compute the nodal distance of the current time step
3822  CALL field_variable_get(dependent_field,field_u_variable_type,field_variable,err,error,*999)
3823  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
3824  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,left_node(1), &
3825  & err,error,*999)
3826  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
3827  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,left_node(2), &
3828  & err,error,*999)
3829  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
3830  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,left_node(3), &
3831  & err,error,*999)
3832 
3833  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
3834  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,right_node(1), &
3835  & err,error,*999)
3836  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
3837  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,right_node(2), &
3838  & err,error,*999)
3839  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
3840  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,right_node(3), &
3841  & err,error,*999)
3842 
3843  dist2=sqrt((right_node(1)-left_node(1))*(right_node(1)-left_node(1))+ &
3844  & (right_node(2)-left_node(2))*(right_node(2)-left_node(2))+ &
3845  & (right_node(3)-left_node(3))*(right_node(3)-left_node(3)))
3846 
3847  delta_t=0.01_dp;
3848  velo=(dist2-dist1)/delta_t ! velo>0 for lengthening
3849 ! velo=(dist1-dist2)/delta_t ! velo<0 for shortening
3850  !velo=velo*1.0e-6_DP
3851  velo=velo*5.0e-8_dp
3852 
3853  !--------------------------------------------------------------------------------------------
3854 
3855  !Force-Velocity-Relation
3856 ! PAR=[1.0_DP,0.5_DP,0.5_DP,0.8_DP,0.2_DP] ! Muscle-Parameters for F-v-Relation
3857 ! IF(velo.GE.0.0_DP) THEN
3858 ! ENERGY_PER_XB=(PAR(1)+PAR(2))*PAR(3)/(velo+PAR(3))-PAR(2)
3859 ! ELSE
3860 ! ENERGY_PER_XB=((2.0_DP*PAR(1)-PAR(4))*velo-PAR(1)*PAR(5))/(velo-PAR(5))
3861 ! ENDIF
3862  v_max=8.9e-8_dp
3863  xb_distortion=8.0e-9_dp*(1+velo/v_max) ! [m]
3864 
3865  xb_stiffness=2.2e-3_dp ! [N/m]
3866 
3867  reference_volume=1.4965e+06_dp ! [nm^3]
3868  max_xb_number_per_volume=120.0_dp*2.0_dp/reference_volume ! [cross-bridges per nm^3]
3869  energy_per_xb=0.5_dp*xb_stiffness*xb_distortion**2 ! [J]
3870 
3871  sarco_length=dzdnu(1,1)
3872 
3873  ! Calculate Filament-Overlap
3874  IF(sarco_length.LE.0.635_dp) THEN
3875  force_length=0.0_dp
3876  ELSE IF(sarco_length.LE.0.835_dp) THEN
3877  force_length=4.2_dp*(sarco_length-0.635_dp)
3878  ELSE IF(sarco_length.LE.1.0_dp) THEN
3879  force_length=0.84_dp+0.9697_dp*(sarco_length-0.835_dp)
3880  ELSE IF(sarco_length.LE.1.125_dp) THEN
3881  force_length=1.0_dp
3882  ELSE IF(sarco_length.LE.1.825_dp) THEN
3883  force_length=1.0_dp-1.4286_dp*(sarco_length-1.125_dp)
3884  ELSE
3885  force_length=0.0_dp
3886  ENDIF
3887 
3888  !Mechanical Energy stored in cross-bridges [10^4 J per cubic meter] = [N/cm^2]
3889  xb_energy_per_volume=max_xb_number_per_volume*force_length*c(8)*energy_per_xb*10.0_dp**23 ! [10^4 J per cubic meter]
3890  !XB_ENERGY_PER_VOLUME=0.16_DP*C(8)
3891  !WRITE(*,*) XB_ENERGY_PER_VOLUME
3892 
3893  !Initalize lambda_a
3894  lambda_a=1.0_dp
3895 
3896  f_a_inv=0.0_dp
3897  f_a_inv(1,1)=1.0_dp/lambda_a
3898  f_a_inv(2,2)=1.0_dp
3899  f_a_inv(3,3)=1.0_dp
3900 
3901  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
3902  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
3903  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
3904 
3905  !Neo-Hook Material
3906 ! I_1e=C_e(1,1)+C_e(2,2)+C_e(3,3)
3907 ! FREE_ENERGY_0=1.0_DP/2.0_DP*C(1)*(I_1e-3.0_DP)
3908 
3909  !Odgen law - 3 terms. Material Parameters C = [mu(1) mu(2) mu(3) alpha(1) alpha(2) alpha(3) mu_0 XB]
3910 
3911 ! CALL Eigenvalue(C_e,EVALUES,ERR,ERROR,*999)
3912  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
3913  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
3914  lwork=min(lwmax,int(work(1)))
3915  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
3916  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
3917  evector_1=c_e(:,1)
3918  evector_2=c_e(:,2)
3919  evector_3=c_e(:,3)
3920 
3921  DO i=1,3
3922  DO j=1,3
3923  ematrix_1(i,j)=evector_1(i)*evector_1(j)
3924  ematrix_2(i,j)=evector_2(i)*evector_2(j)
3925  ematrix_3(i,j)=evector_3(i)*evector_3(j)
3926  END DO
3927  END DO
3928 
3929  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
3930  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
3931  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
3932  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
3933  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
3934  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
3935 
3936  free_energy_0=0.0_dp
3937  DO i=1,3
3938  free_energy_0=free_energy_0+c(i)/c(i+3)*( &
3939  & evalues(1)**(c(i+3)/2.0_dp)+ &
3940  & evalues(2)**(c(i+3)/2.0_dp)+ &
3941  & evalues(3)**(c(i+3)/2.0_dp)-3.0_dp)
3942  END DO
3943  free_energy_0=c(7)*free_energy_0
3944 
3945  free_energy=free_energy_0
3946 
3947  VALUE=xb_energy_per_volume-(free_energy-free_energy_0)
3948  !VALUE=0.0_DP
3949 
3950  tol=0.00001_dp
3951  tol1=tol !0.05_DP
3952  up=lambda_a !1.0_DP
3953  low=0.001_dp
3954 
3955  DO WHILE (abs(VALUE).GE.tol)
3956 
3957  IF (abs(VALUE).GE.tol1) THEN
3958  lambda_a=up-(up-low)/2.0_dp
3959 
3960  f_a_inv=0.0_dp
3961  f_a_inv(1,1)=1.0_dp/lambda_a
3962  f_a_inv(2,2)=1.0_dp
3963  f_a_inv(3,3)=1.0_dp
3964 
3965  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
3966  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
3967  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
3968 
3969 ! I_1e=C_e(1,1)+C_e(2,2)+C_e(3,3)
3970 ! FREE_ENERGY=1.0_DP/2.0_DP*(I_1e-3.0_DP)
3971 ! CALL Eigenvalue(C_e,EVALUES,ERR,ERROR,*999)
3972  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
3973  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
3974  lwork=min(lwmax,int(work(1)))
3975  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
3976  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
3977  evector_1=c_e(:,1)
3978  evector_2=c_e(:,2)
3979  evector_3=c_e(:,3)
3980 
3981  DO i=1,3
3982  DO j=1,3
3983  ematrix_1(i,j)=evector_1(i)*evector_1(j)
3984  ematrix_2(i,j)=evector_2(i)*evector_2(j)
3985  ematrix_3(i,j)=evector_3(i)*evector_3(j)
3986  END DO
3987  END DO
3988 
3989  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
3990  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
3991  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
3992  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
3993  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
3994  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
3995 
3996  free_energy=0.0_dp
3997  DO i=1,3
3998  free_energy=free_energy+c(i)/c(i+3)*( &
3999  & evalues(1)**(c(i+3)/2.0_dp)+ &
4000  & evalues(2)**(c(i+3)/2.0_dp)+ &
4001  & evalues(3)**(c(i+3)/2.0_dp)-3.0_dp)
4002  END DO
4003  free_energy=c(7)*free_energy
4004 
4005  VALUE=xb_energy_per_volume-(free_energy-free_energy_0)
4006 
4007  IF (VALUE .GE. 0.0_dp) THEN
4008  up=lambda_a
4009  ELSE
4010  low=lambda_a
4011  ENDIF
4012 
4013  ELSE
4014 
4015  temp=dzdnu+dzdnut
4016  CALL matrix_product(f_e_t,temp,temp,err,error,*999)
4017  CALL matrix_product(temp,n1,temp1,err,error,*999)
4018  CALL matrix_product(temp,n2,temp2,err,error,*999)
4019  CALL matrix_product(temp,n3,temp3,err,error,*999)
4020 
4021  temp=0.0_dp
4022  DO i=1,3
4023  temp=temp+ &
4024  & c(i)*evalues(1)**(c(i+3)/2.0_dp-1.0_dp)*temp1+ &
4025  & c(i)*evalues(2)**(c(i+3)/2.0_dp-1.0_dp)*temp2+ &
4026  & c(i)*evalues(3)**(c(i+3)/2.0_dp-1.0_dp)*temp3
4027  END DO
4028  slope=temp(1,1)*c(7)
4029  lambda_a=lambda_a-VALUE/slope
4030  !IF (lambda_a.LE.0.0_DP) THEN
4031  ! lambda_a=0.1_DP
4032  !END IF
4033  !lambda_a=lambda_a-0.001
4034 
4035  f_a_inv=0.0_dp
4036  f_a_inv(1,1)=1.0_dp/lambda_a
4037  f_a_inv(2,2)=1.0_dp
4038  f_a_inv(3,3)=1.0_dp
4039 
4040  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
4041  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
4042  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
4043 
4044 ! I_1e=C_e(1,1)+C_e(2,2)+C_e(3,3)
4045 ! FREE_ENERGY=1.0_DP/2.0_DP*(I_1e-3.0_DP)
4046 ! CALL Eigenvalue(C_e,EVALUES,ERR,ERROR,*999)
4047  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
4048  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4049  lwork=min(lwmax,int(work(1)))
4050  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
4051  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4052  evector_1=c_e(:,1)
4053  evector_2=c_e(:,2)
4054  evector_3=c_e(:,3)
4055 
4056  DO i=1,3
4057  DO j=1,3
4058  ematrix_1(i,j)=evector_1(i)*evector_1(j)
4059  ematrix_2(i,j)=evector_2(i)*evector_2(j)
4060  ematrix_3(i,j)=evector_3(i)*evector_3(j)
4061  END DO
4062  END DO
4063 
4064  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
4065  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
4066  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
4067  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
4068  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
4069  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
4070 
4071  free_energy=0.0_dp
4072  DO i=1,3
4073  free_energy=free_energy+c(i)/c(i+3)*( &
4074  & evalues(1)**(c(i+3)/2.0_dp)+ &
4075  & evalues(2)**(c(i+3)/2.0_dp)+ &
4076  & evalues(3)**(c(i+3)/2.0_dp)-3.0_dp)
4077  END DO
4078  free_energy=c(7)*free_energy
4079 
4080  VALUE=xb_energy_per_volume-(free_energy-free_energy_0)
4081  ENDIF
4082  ENDDO
4083 
4084  ! Neo-Hook
4085 ! F_a = 0.0_DP
4086 ! F_a(1,1) = lambda_a
4087 ! F_a(2,2) = 1.0_DP
4088 ! F_a(3,3) = 1.0_DP
4089 ! CALL MATRIX_TRANSPOSE(F_a,F_a_T,ERR,ERROR,*999)
4090 ! CALL MATRIX_PRODUCT(F_a_T,F_a,C_a,ERR,ERROR,*999)
4091 ! CALL INVERT(C_a,C_a_inv,a,ERR,ERROR,*999) !a is not required (=1/lambda_a^2 ?)
4092 ! PIOLA_TENSOR=C(1)*C_a_inv+2.0_DP*P*AZU
4093 
4094  !Odgen
4095 ! CALL Eigenvector(C_e,EVALUES(1),EVECTOR_1,ERR,ERROR,*999)
4096 ! CALL Eigenvector(C_e,EVALUES(2),EVECTOR_2,ERR,ERROR,*999)
4097 ! CALL Eigenvector(C_e,EVALUES(3),EVECTOR_3,ERR,ERROR,*999)
4098 ! CALL MATRIX_PRODUCT(F_e_T,F_e,C_e,ERR,ERROR,*999)
4099 ! CALL DSYEV('V','U',3,C_e,3,EVALUES,WORK,-1,ERR)
4100 ! IF(ERR.NE.0) CALL FlagError("Error in Eigenvalue computation",ERR,ERROR,*999)
4101 ! LWORK=MIN(LWMAX,INT(WORK(1)))
4102 ! CALL DSYEV('V','U',3,C_e,3,EVALUES,WORK,LWORK,ERR)
4103 ! IF(ERR.NE.0) CALL FlagError("Error in Eigenvalue computation",ERR,ERROR,*999)
4104 ! EVECTOR_1=C_e(:,1)
4105 ! EVECTOR_2=C_e(:,2)
4106 ! EVECTOR_3=C_e(:,3)
4107 
4108 ! DO i=1,3
4109 ! DO j=1,3
4110 ! EMATRIX_1(i,j)=EVECTOR_1(i)*EVECTOR_1(j)
4111 ! EMATRIX_2(i,j)=EVECTOR_2(i)*EVECTOR_2(j)
4112 ! EMATRIX_3(i,j)=EVECTOR_3(i)*EVECTOR_3(j)
4113 ! END DO
4114 ! END DO
4115 
4116 ! CALL MATRIX_TRANSPOSE(F_a_inv,F_a_inv_T,ERR,ERROR,*999)
4117 
4118 ! CALL MATRIX_PRODUCT(F_a_inv,EMATRIX_1,TEMP1,ERR,ERROR,*999)
4119 ! CALL MATRIX_PRODUCT(TEMP1,F_a_inv_T,TEMP1,ERR,ERROR,*999)
4120 
4121 ! CALL MATRIX_PRODUCT(F_a_inv,EMATRIX_2,TEMP2,ERR,ERROR,*999)
4122 ! CALL MATRIX_PRODUCT(TEMP2,F_a_inv_T,TEMP2,ERR,ERROR,*999)
4123 
4124 ! CALL MATRIX_PRODUCT(F_a_inv,EMATRIX_3,TEMP3,ERR,ERROR,*999)
4125 ! CALL MATRIX_PRODUCT(TEMP3,F_a_inv_T,TEMP3,ERR,ERROR,*999)
4126 
4127  piola_tensor=0.0_dp
4128  DO i=1,3
4129  piola_tensor=piola_tensor+ &
4130  & c(i)*evalues(1)**(c(i+3)/2.0_dp-1.0_dp)*n1+ &
4131  & c(i)*evalues(2)**(c(i+3)/2.0_dp-1.0_dp)*n2+ &
4132  & c(i)*evalues(3)**(c(i+3)/2.0_dp-1.0_dp)*n3
4133  END DO
4134  piola_tensor=piola_tensor*c(7)+2.0_dp*p*azu
4135 
4136 
4137  CASE(equations_set_multiscale_active_strain_subtype)
4138 
4139  dependent_field=>equations_set%DEPENDENT%DEPENDENT_FIELD
4140  node1=dependent_field%decomposition%domain(1)%ptr%topology%elements%elements(element_number)%element_nodes(13)
4141  node2=dependent_field%decomposition%domain(1)%ptr%topology%elements%elements(element_number)%element_nodes(15)
4142 
4143  NULLIFY(field_variable)
4144  ! compute the nodal distance of the previous time step
4145  CALL field_variable_get(dependent_field,field_v_variable_type,field_variable,err,error,*999)
4146  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
4147  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,left_node(1), &
4148  & err,error,*999)
4149  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
4150  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,left_node(2), &
4151  & err,error,*999)
4152  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
4153  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,left_node(3), &
4154  & err,error,*999)
4155 
4156  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
4157  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,right_node(1), &
4158  & err,error,*999)
4159  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
4160  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,right_node(2), &
4161  & err,error,*999)
4162  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
4163  CALL field_parameter_set_get_local_dof(dependent_field,field_v_variable_type,field_values_set_type,dof_idx,right_node(3), &
4164  & err,error,*999)
4165 
4166  dist1=sqrt((right_node(1)-left_node(1))*(right_node(1)-left_node(1))+ &
4167  & (right_node(2)-left_node(2))*(right_node(2)-left_node(2))+ &
4168  & (right_node(3)-left_node(3))*(right_node(3)-left_node(3)))
4169 
4170  NULLIFY(field_variable)
4171  ! compute the nodal distance of the current time step
4172  CALL field_variable_get(dependent_field,field_u_variable_type,field_variable,err,error,*999)
4173  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
4174  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,left_node(1), &
4175  & err,error,*999)
4176  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
4177  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,left_node(2), &
4178  & err,error,*999)
4179  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node1)%DERIVATIVES(1)%VERSIONS(1)
4180  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,left_node(3), &
4181  & err,error,*999)
4182 
4183  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
4184  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,right_node(1), &
4185  & err,error,*999)
4186  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
4187  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,right_node(2), &
4188  & err,error,*999)
4189  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%NODE_PARAM2DOF_MAP%NODES(node2)%DERIVATIVES(1)%VERSIONS(1)
4190  CALL field_parameter_set_get_local_dof(dependent_field,field_u_variable_type,field_values_set_type,dof_idx,right_node(3), &
4191  & err,error,*999)
4192 
4193  dist2=sqrt((right_node(1)-left_node(1))*(right_node(1)-left_node(1))+ &
4194  & (right_node(2)-left_node(2))*(right_node(2)-left_node(2))+ &
4195  & (right_node(3)-left_node(3))*(right_node(3)-left_node(3)))
4196 
4197  delta_t=0.001_dp;
4198  velo=(dist2-dist1)/delta_t ! velo>0 == lengthening
4199  !conversion of velocity at the continuum macroscale to the micromechanical cell model half-sarcomere velocity
4200  velo=velo*5.0e-8_dp
4201 ! velo=velo*5.0e-2_DP
4202 ! velo=velo*5.0e-7_DP
4203 
4204  CALL field_parameter_set_update_gauss_point(dependent_field,field_u1_variable_type,field_values_set_type,gauss_point_number, &
4205  & element_number,2,velo,err,error,*999)
4206 
4207 
4208  !--------------------------------------------------------------------------------------------
4209  NULLIFY(independent_field)
4210  independent_field=>equations_set%INDEPENDENT%INDEPENDENT_FIELD
4211  NULLIFY(field_variable)
4212  CALL field_variable_get(independent_field,field_u_variable_type,field_variable,err,error,*999)
4213 
4214  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4215  & element_number)
4216  CALL field_parameter_set_get_local_dof(independent_field,field_u_variable_type,field_values_set_type,dof_idx,a_1, &
4217  & err,error,*999)
4218  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4219  & element_number)
4220  CALL field_parameter_set_get_local_dof(independent_field,field_u_variable_type,field_values_set_type,dof_idx,a_2, &
4221  & err,error,*999)
4222  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4223  & element_number)
4224  CALL field_parameter_set_get_local_dof(independent_field,field_u_variable_type,field_values_set_type,dof_idx,x_1, &
4225  & err,error,*999)
4226  dof_idx=field_variable%COMPONENTS(4)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4227  & element_number)
4228  CALL field_parameter_set_get_local_dof(independent_field,field_u_variable_type,field_values_set_type,dof_idx,x_2, &
4229  & err,error,*999)
4230 
4231  !--------------------------------------------------------------------------------------------
4232  sarco_length=dzdnu(1,1)
4233  ! Calculate Filament-Overlap
4234  IF(sarco_length.LE.0.635_dp) THEN
4235  force_length=0.0_dp
4236  ELSE IF(sarco_length.LE.0.835_dp) THEN
4237  force_length=4.2_dp*(sarco_length-0.635_dp)
4238  ELSE IF(sarco_length.LE.1.0_dp) THEN
4239  force_length=0.84_dp+0.9697_dp*(sarco_length-0.835_dp)
4240  ELSE IF(sarco_length.LE.1.125_dp) THEN
4241  force_length=1.0_dp
4242  ELSE IF(sarco_length.LE.1.825_dp) THEN
4243  force_length=1.0_dp-1.4286_dp*(sarco_length-1.125_dp)
4244  ELSE
4245  force_length=0.0_dp
4246  ENDIF
4247 
4248  reference_volume=1.4965e+06_dp ! [nm^3]
4249  max_xb_number_per_volume=120.0_dp*2.0_dp/reference_volume ! [cross-bridges per nm^3]
4250  energy_per_xb=0.5_dp*x_2**2*c(8) ! joule
4251 
4252  !Mechanical Energy stored in cross-bridges - conversion from J/nm^3 to N/cm^2
4253  xb_energy_per_volume=max_xb_number_per_volume*force_length*energy_per_xb*a_2*10.0_dp**23
4254 
4255  !Initalize lambda_a
4256  lambda_a=1.0_dp
4257 
4258  f_a_inv=0.0_dp
4259  f_a_inv(1,1)=1.0_dp/lambda_a
4260  f_a_inv(2,2)=1.0_dp
4261  f_a_inv(3,3)=1.0_dp
4262 
4263  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
4264  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
4265  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
4266 
4267  !Odgen law - 3 terms. Material Parameters C = [mu(1) mu(2) mu(3) alpha(1) alpha(2) alpha(3) mu_0]
4268 ! CALL Eigenvalue(C_e,EVALUES,ERR,ERROR,*999)
4269  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
4270  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4271  lwork=min(lwmax,int(work(1)))
4272  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
4273  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4274  evector_1=c_e(:,1)
4275  evector_2=c_e(:,2)
4276  evector_3=c_e(:,3)
4277 
4278  DO i=1,3
4279  DO j=1,3
4280  ematrix_1(i,j)=evector_1(i)*evector_1(j)
4281  ematrix_2(i,j)=evector_2(i)*evector_2(j)
4282  ematrix_3(i,j)=evector_3(i)*evector_3(j)
4283  END DO
4284  END DO
4285 
4286  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
4287  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
4288  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
4289  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
4290  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
4291  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
4292 
4293  free_energy_0=0.0_dp
4294  DO i=1,3
4295  free_energy_0=free_energy_0+c(i)/c(i+3)*( &
4296  & evalues(1)**(c(i+3)/2.0_dp)+ &
4297  & evalues(2)**(c(i+3)/2.0_dp)+ &
4298  & evalues(3)**(c(i+3)/2.0_dp)-3.0_dp)
4299  END DO
4300  free_energy_0=c(7)*free_energy_0
4301 
4302  free_energy=free_energy_0
4303 
4304  VALUE=xb_energy_per_volume-(free_energy-free_energy_0)
4305 
4306  !tolerance for Newton's method
4307  tol=0.00001_dp
4308  !tolerance for the bisection method as preconditioner. Since Newton's method does not converge, we only use the bisection method here
4309  tol1=tol
4310  up=lambda_a
4311  low=0.001_dp
4312 
4313 ! WRITE(*,*) "VALUE: ", VALUE
4314 
4315  DO WHILE (abs(VALUE).GE.tol)
4316 
4317  !bisection method
4318  IF (abs(VALUE).GE.tol1) THEN
4319  lambda_a=up-(up-low)/2.0_dp
4320 
4321  f_a_inv=0.0_dp
4322  IF(lambda_a<tol) THEN
4323  CALL flagwarning("lambda_a is close to zero",err,error,*999)
4324 ! WRITE(*,*) "UP: ", UP
4325 ! WRITE(*,*) "LOW: ", LOW
4326 ! WRITE(*,*) "lambda_a: ", lambda_a
4327  lambda_a=lambda_a+tol
4328  ENDIF
4329  f_a_inv(1,1)=1.0_dp/lambda_a
4330  f_a_inv(2,2)=1.0_dp
4331  f_a_inv(3,3)=1.0_dp
4332 
4333  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
4334  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
4335  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
4336 
4337  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
4338  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4339  lwork=min(lwmax,int(work(1)))
4340  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
4341  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4342  evector_1=c_e(:,1)
4343  evector_2=c_e(:,2)
4344  evector_3=c_e(:,3)
4345 
4346  DO i=1,3
4347  DO j=1,3
4348  ematrix_1(i,j)=evector_1(i)*evector_1(j)
4349  ematrix_2(i,j)=evector_2(i)*evector_2(j)
4350  ematrix_3(i,j)=evector_3(i)*evector_3(j)
4351  END DO
4352  END DO
4353 
4354  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
4355  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
4356  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
4357  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
4358  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
4359  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
4360 
4361  free_energy=0.0_dp
4362  DO i=1,3
4363  free_energy=free_energy+c(i)/c(i+3)*( &
4364  & evalues(1)**(c(i+3)/2.0_dp)+ &
4365  & evalues(2)**(c(i+3)/2.0_dp)+ &
4366  & evalues(3)**(c(i+3)/2.0_dp)-3.0_dp)
4367  END DO
4368  free_energy=c(7)*free_energy
4369 
4370  VALUE=xb_energy_per_volume-(free_energy-free_energy_0)
4371 
4372  IF (VALUE.GE.0) THEN
4373  up=lambda_a
4374  ELSE
4375  low=lambda_a
4376  ENDIF
4377 
4378  ELSE
4379  !Newton's method -- needs to be checked TODO
4380 
4381  temp=dzdnu+dzdnut
4382  CALL matrix_product(f_e_t,temp,temp,err,error,*999)
4383  CALL matrix_product(temp,n1,temp1,err,error,*999)
4384  CALL matrix_product(temp,n2,temp2,err,error,*999)
4385  CALL matrix_product(temp,n3,temp3,err,error,*999)
4386 
4387  temp=0.0_dp
4388  DO i=1,3
4389  temp=temp+ &
4390  & c(i)*evalues(1)**(c(i+3)/2.0_dp-1.0_dp)*temp1+ &
4391  & c(i)*evalues(2)**(c(i+3)/2.0_dp-1.0_dp)*temp2+ &
4392  & c(i)*evalues(3)**(c(i+3)/2.0_dp-1.0_dp)*temp3
4393  END DO
4394  slope=temp(1,1)*c(7)
4395  lambda_a=lambda_a-VALUE/slope
4396  !IF (lambda_a.LE.0.0_DP) THEN
4397  ! lambda_a=0.1_DP
4398  !END IF
4399  !lambda_a=lambda_a-0.001
4400 
4401  f_a_inv=0.0_dp
4402  f_a_inv(1,1)=1.0_dp/lambda_a
4403  f_a_inv(2,2)=1.0_dp
4404  f_a_inv(3,3)=1.0_dp
4405 
4406  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
4407  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
4408  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
4409 
4410  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
4411  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4412  lwork=min(lwmax,int(work(1)))
4413  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
4414  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4415  evector_1=c_e(:,1)
4416  evector_2=c_e(:,2)
4417  evector_3=c_e(:,3)
4418 
4419  DO i=1,3
4420  DO j=1,3
4421  ematrix_1(i,j)=evector_1(i)*evector_1(j)
4422  ematrix_2(i,j)=evector_2(i)*evector_2(j)
4423  ematrix_3(i,j)=evector_3(i)*evector_3(j)
4424  END DO
4425  END DO
4426 
4427  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
4428  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
4429  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
4430  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
4431  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
4432  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
4433 
4434  free_energy=0.0_dp
4435  DO i=1,3
4436  free_energy=free_energy+c(i)/c(i+3)*( &
4437  & evalues(1)**(c(i+3)/2.0_dp)+ &
4438  & evalues(2)**(c(i+3)/2.0_dp)+ &
4439  & evalues(3)**(c(i+3)/2.0_dp)-3.0_dp)
4440  END DO
4441  free_energy=c(7)*free_energy
4442 
4443  VALUE=xb_energy_per_volume-(free_energy-free_energy_0)
4444  ENDIF
4445  ENDDO
4446 
4447  piola_tensor=0.0_dp
4448  DO i=1,3
4449  piola_tensor=piola_tensor+ &
4450  & c(i)*evalues(1)**(c(i+3)/2.0_dp-1.0_dp)*n1+ &
4451  & c(i)*evalues(2)**(c(i+3)/2.0_dp-1.0_dp)*n2+ &
4452  & c(i)*evalues(3)**(c(i+3)/2.0_dp-1.0_dp)*n3
4453  END DO
4454  piola_tensor=piola_tensor*c(7)+2.0_dp*p*azu
4455 
4456  !store lambda_f, so it can be used in the CellML file
4457  lambda_f=sqrt(azl(1,1))
4458  CALL field_parameter_set_update_gauss_point(dependent_field,field_u1_variable_type,field_values_set_type,gauss_point_number, &
4459  & element_number,1,lambda_f,err,error,*999)
4460 
4461 
4462  CASE(equations_set_1d3d_monodomain_active_strain_subtype)
4463 
4464  NULLIFY(independent_field)
4465  independent_field=>equations_set%INDEPENDENT%INDEPENDENT_FIELD
4466  NULLIFY(field_variable)
4467  CALL field_variable_get(independent_field,field_u_variable_type,field_variable,err,error,*999)
4468 
4469  dof_idx=field_variable%COMPONENTS(5)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4470  & element_number)
4471  CALL field_parameter_set_get_local_dof(independent_field,field_u_variable_type,field_values_set_type,dof_idx,lambda_a, &
4472  & err,error,*999)
4473 
4474  f_a_inv=0.0_dp
4475  f_a_inv(1,1)=1.0_dp/lambda_a
4476  f_a_inv(2,2)=1.0_dp
4477  f_a_inv(3,3)=1.0_dp
4478 
4479  CALL matrix_product(dzdnu,f_a_inv,f_e,err,error,*999)
4480  CALL matrix_transpose(f_e,f_e_t,err,error,*999)
4481  CALL matrix_product(f_e_t,f_e,c_e,err,error,*999)
4482 
4483  !Odgen law - 3 terms. Material Parameters C = [mu(1) mu(2) mu(3) alpha(1) alpha(2) alpha(3) mu_0]
4484 ! CALL Eigenvalue(C_e,EVALUES,ERR,ERROR,*999)
4485  CALL dsyev('V','U',3,c_e,3,evalues,work,-1,err)
4486  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4487  lwork=min(lwmax,int(work(1)))
4488  CALL dsyev('V','U',3,c_e,3,evalues,work,lwork,err)
4489  IF(err.NE.0) CALL flagerror("Error in Eigenvalue computation",err,error,*999)
4490  evector_1=c_e(:,1)
4491  evector_2=c_e(:,2)
4492  evector_3=c_e(:,3)
4493 
4494  DO i=1,3
4495  DO j=1,3
4496  ematrix_1(i,j)=evector_1(i)*evector_1(j)
4497  ematrix_2(i,j)=evector_2(i)*evector_2(j)
4498  ematrix_3(i,j)=evector_3(i)*evector_3(j)
4499  END DO
4500  END DO
4501 
4502  CALL matrix_product(f_a_inv,ematrix_1,n1,err,error,*999)
4503  CALL matrix_product(n1,f_a_inv,n1,err,error,*999) ! F_a_inv=F_a_inv_T
4504  CALL matrix_product(f_a_inv,ematrix_2,n2,err,error,*999)
4505  CALL matrix_product(n2,f_a_inv,n2,err,error,*999) ! F_a_inv=F_a_inv_T
4506  CALL matrix_product(f_a_inv,ematrix_3,n3,err,error,*999)
4507  CALL matrix_product(n3,f_a_inv,n3,err,error,*999) ! F_a_inv=F_a_inv_T
4508 
4509  piola_tensor=0.0_dp
4510  DO i=1,3
4511  piola_tensor=piola_tensor+ &
4512  & c(i)*evalues(1)**(c(i+3)/2.0_dp-1.0_dp)*n1+ &
4513  & c(i)*evalues(2)**(c(i+3)/2.0_dp-1.0_dp)*n2+ &
4514  & c(i)*evalues(3)**(c(i+3)/2.0_dp-1.0_dp)*n3
4515  END DO
4516  piola_tensor=piola_tensor*c(7)+2.0_dp*p*azu
4517 
4518  CASE(equations_set_mooney_rivlin_subtype,equations_set_mooney_rivlin_activecontraction_subtype,equations_set_membrane_subtype, &
4519  & equations_set_no_subtype,equations_set_anisotropic_polynomial_subtype,equations_set_anisotropic_polynomial_active_subtype, &
4520  & equations_set_incompressible_finite_elasticity_darcy_subtype,equations_set_standard_monodomain_elasticity_subtype, &
4521  & equations_set_1d3d_monodomain_elasticity_subtype,equations_set_transverse_isotropic_polynomial_subtype, &
4522  & equations_set_monodomain_elasticity_w_titin_subtype,equations_set_monodomain_elasticity_velocity_subtype, &
4523  & equations_set_transverse_isotropic_active_subtype)
4524  !Form of constitutive model is:
4525  ! W=c1*(I1-3)+c2*(I2-3)+p*(I3-1)
4526  !Also assumed I3 = det(AZL) = 1.0
4527  ! Note that because PIOLA = 2.del{W}/del{C}=[...]+2.lambda.J^2.C^{-1}
4528  ! lambda here is actually half of hydrostatic pressure -- is this comment still correct?
4529  !If subtype is membrane, assume Mooney Rivlin constitutive law
4530  IF (equations_set_subtype/=equations_set_membrane_subtype) THEN
4531  piola_tensor(1,3)=2.0_dp*(c(2)*(-azl(3,1)))+p*azu(1,3)
4532  piola_tensor(2,3)=2.0_dp*(c(2)*(-azl(3,2)))+p*azu(2,3)
4533  piola_tensor(3,1)=piola_tensor(1,3)
4534  piola_tensor(3,2)=piola_tensor(2,3)
4535  piola_tensor(3,3)=2.0_dp*(c(1)+c(2)*(azl(1,1)+azl(2,2)))+p*azu(3,3)
4536  ELSE
4537  ! Membrane Equations
4538  ! Assume incompressible => I3 = 1 => C33(C11 x C22 - C12*C21) = 1
4539  azl(3,3) = 1.0_dp / ((azl(1,1) * azl(2,2)) - (azl(1,2) * azl(2,1)))
4540  ! Assume Mooney-Rivlin constitutive relation
4541  p = -1.0_dp*((c(1) + c(2) * (azl(1,1) + azl(2,2))) * azl(3,3))
4542  ! Assume stress normal to the surface is neglible i.e. PIOLA_TENSOR(:,3) = 0,PIOLA_TENSOR(3,:) = 0
4543  piola_tensor(:,3) = 0.0_dp
4544  piola_tensor(3,:) = 0.0_dp
4545  ENDIF
4546  piola_tensor(1,1)=2.0_dp*(c(1)+c(2)*(azl(2,2)+azl(3,3)))+p*azu(1,1)
4547  piola_tensor(1,2)=2.0_dp*( c(2)*(-azl(2,1)))+p*azu(1,2)
4548  piola_tensor(2,1)=piola_tensor(1,2)
4549  piola_tensor(2,2)=2.0_dp*(c(1)+c(2)*(azl(3,3)+azl(1,1)))+p*azu(2,2)
4550 
4551 
4552  SELECT CASE(equations_set_subtype)
4553  CASE(equations_set_mooney_rivlin_activecontraction_subtype)
4554  !add active contraction stress value to the trace of the stress tensor - basically adding to hydrostatic pressure.
4555  !the active stress is stored inside the independent field that has been set up in the user program.
4556  !for generality we could set up 3 components in independent field for 3 different active stress components
4557  !1 isotropic value assumed here.
4558  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4559  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,1,active_stress_11, &
4560  & err,error,*999) ! get the independent field stress value
4561 
4562  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4563  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,2,active_stress_22, &
4564  & err,error,*999) ! get the independent field stress value
4565 
4566  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4567  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,3,active_stress_33, &
4568  & err,error,*999) ! get the independent field stress value
4569 
4570  piola_tensor(1,1)=piola_tensor(1,1)+active_stress_11
4571  piola_tensor(2,2)=piola_tensor(2,2)+active_stress_22
4572  piola_tensor(3,3)=piola_tensor(3,3)+active_stress_33
4573 
4574  CASE(equations_set_standard_monodomain_elasticity_subtype)
4575  ! add the active stress component (stored in the independent field) to the 1,1-direction of the 2-PK tensor
4576  piola_tensor(1,1)=piola_tensor(1,1)+independent_interpolated_point%VALUES(1,no_part_deriv)
4577 
4578  CASE(equations_set_1d3d_monodomain_elasticity_subtype)
4579  !passive anisotropic stiffness -- only in the tension range
4580  IF(azl(1,1) > 1.0_dp) THEN
4581  piola_tensor(1,1)=piola_tensor(1,1)+c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4582  ENDIF
4583  !active stress component
4584  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4585  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,1,VALUE, &
4586  & err,error,*999)
4587  !divide by lambda and multiply by P_max
4588  VALUE=VALUE/sqrt(azl(1,1))*c(5)
4589 
4590  !HINDAWI paper - force-length relation at the continuum level
4591 ! if((SQRT(AZL(1,1))>0.72_DP).AND.(SQRT(AZL(1,1))<1.68_DP)) then
4592 ! VALUE=VALUE*(-25.0_DP/4.0_DP*AZL(1,1)/1.2_DP/1.2_DP + 25.0_DP/2.0_DP*SQRT(AZL(1,1))/1.2_DP - 5.25_DP)
4593 ! else
4594 ! VALUE=0.0_DP
4595 ! endif
4596 
4597  piola_tensor(1,1)=piola_tensor(1,1)+VALUE
4598 
4599  CASE(equations_set_monodomain_elasticity_w_titin_subtype)
4600  !passive anisotropic stiffness -- only in the tension range
4601  IF(azl(1,1) > 1.0_dp) THEN
4602  piola_tensor(1,1)=piola_tensor(1,1)+c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4603  ENDIF
4604  !active stress component
4605  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
4606  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4607  & element_number)
4608  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4609  & field_values_set_type,dof_idx,VALUE,err,error,*999)
4610 
4611  IF(VALUE.LT.0.0_dp) VALUE=0.0_dp
4612 
4613  !divide by lambda and multiply by P_max
4614  VALUE=VALUE/sqrt(azl(1,1))*c(5)
4615 
4616  piola_tensor(1,1)=piola_tensor(1,1)+VALUE
4617 
4618  ! unbound Titin-stress
4619  dof_idx=field_variable%COMPONENTS(2)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4620  & element_number)
4621  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4622  & field_values_set_type,dof_idx,titin_unbound,err,error,*999)
4623  ! bound Titin-stress -> Rode Model
4624  dof_idx=field_variable%COMPONENTS(3)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4625  & element_number)
4626  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4627  & field_values_set_type,dof_idx,titin_bound,err,error,*999)
4628  ! activation
4629  dof_idx=field_variable%COMPONENTS(6)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4630  & element_number)
4631  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4632  & field_values_set_type,dof_idx,activation,err,error,*999)
4633 
4634  IF(activation.GT.1.0_dp) activation=1.0_dp
4635  IF(activation.LT.0.0_dp) activation=0.0_dp
4636 
4637  ! parameter to switch on and off actin-titin interaction
4638  activation=c(6)*activation
4639 
4640  ! normalized Titin-stress -> weighted sum of bound and unbound titin-stress
4641  titin_value=activation*titin_bound+(1.0_dp-activation)*titin_unbound
4642  !TITIN_VALUE=activation*TITIN_BOUND*0.5_DP+(1.0_DP-activation)*TITIN_UNBOUND !TK Hack
4643  ! divide by lambda and multiply by P_max
4644  titin_value=titin_value/sqrt(azl(1,1))*c(5)
4645 
4646  piola_tensor(1,1)=piola_tensor(1,1)+titin_value
4647 
4648  ! unbound titin-stress in cross-fibre direction
4649  dof_idx=field_variable%COMPONENTS(4)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4650  & element_number)
4651  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4652  & field_values_set_type,dof_idx,titin_unbound_cross_fibre,err,error,*999)
4653  ! bound titin-stress in cross-fibre direction
4654  dof_idx=field_variable%COMPONENTS(5)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4655  & element_number)
4656  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4657  & field_values_set_type,dof_idx,titin_bound_cross_fibre,err,error,*999)
4658 
4659  ! normalized XF-Titin-stress -> weighted sum of bound and unbound XF-titin-stress
4660  titin_value_cross_fibre=activation*titin_bound_cross_fibre+(1.0_dp-activation)*titin_unbound_cross_fibre
4661  ! divide by lambda and multiply by P_max
4662  titin_value_cross_fibre=titin_value_cross_fibre*c(5) !/SQRT(AZL(1,1))
4663 
4664  piola_tensor(2,2)=piola_tensor(2,2)+titin_value_cross_fibre
4665  piola_tensor(3,3)=piola_tensor(3,3)+titin_value_cross_fibre
4666 
4667  CASE(equations_set_monodomain_elasticity_velocity_subtype)
4668  !passive anisotropic stiffness -- only in the tension range
4669  IF(azl(1,1) > 1.0_dp) THEN
4670 !tomo
4671 ! PIOLA_TENSOR(1,1)=PIOLA_TENSOR(1,1)+C(3)/AZL(1,1)*(AZL(1,1)**(C(4)/2.0_DP)-1.0_DP)
4672  piola_tensor(1,1)=piola_tensor(1,1)+0.355439810963035_dp/azl(1,1)*(azl(1,1)**(12.660539325481963_dp/2.0_dp)-1.0_dp)
4673  ENDIF
4674 !tomo
4675  IF(azl(2,2) > 1.0_dp) THEN
4676  piola_tensor(2,2)=piola_tensor(2,2)+5316.372204148964_dp/azl(2,2)*(azl(2,2)**(0.014991843974911_dp/2.0_dp)-1.0_dp)
4677  ENDIF
4678  IF(azl(3,3) > 1.0_dp) THEN
4679  piola_tensor(3,3)=piola_tensor(3,3)+5316.372204148964_dp/azl(3,3)*(azl(3,3)**(0.014991843974911_dp/2.0_dp)-1.0_dp)
4680  ENDIF
4681 !tomo end
4682  !active stress component
4683  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
4684  dof_idx=field_variable%COMPONENTS(1)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP%GAUSS_POINTS(gauss_point_number, &
4685  & element_number)
4686  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
4687  & field_values_set_type,dof_idx,VALUE,err,error,*999)
4688  !divide by lambda and multiply by P_max
4689 !tomo RFE
4690  val1=VALUE
4691 !tomo REF end
4692  VALUE=VALUE/sqrt(azl(1,1))*c(5)
4693 
4694 
4695 !tomo RFE
4696  !alpha*K_rfe*(lambda-lambda_start)/lambda
4697  !TODO make lambda_start variable --> independent field
4698 ! VAL2=VAL1*100.0_DP*(SQRT(AZL(1,1))-1) !stretch and compression!!!
4699  val2=100.0_dp*(sqrt(azl(1,1))-1) !stretch and compression!!!
4700  VALUE=VALUE+val2/sqrt(azl(1,1))
4701  piola_tensor(1,1)=piola_tensor(1,1)+VALUE
4702 !tomo REF end
4703 
4704 ! PIOLA_TENSOR(1,1)=PIOLA_TENSOR(1,1)+VALUE
4705 
4706  CASE(equations_set_transverse_isotropic_polynomial_subtype)
4707  !Additional term for transversely isotropic (fibre-reinforced) materials (Markert, B., W. Ehlers, and N. Karajan.
4708  !A general polyconvex strain-energy function for fiber-reinforced materials.
4709  !Proceedings in Applied Mathematics and Mechanics 5.1 (2005): 245-246.)
4710 
4711  ! W_aniso=c3*(sqrt(I4)^(c4-2)-1/I4)M
4712  ! with M being the mapping towards the fibre direction, here: I4=C_11
4713  !C(3)=c3...polynomial coefficient
4714  !C(4)=c4...power coefficient
4715  IF(azl(1,1) > 1.0_dp) THEN ! only in the tension range
4716  piola_tensor(1,1)=piola_tensor(1,1)+c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4717  ENDIF
4718 
4719  CASE(equations_set_transverse_isotropic_active_subtype)
4720  !Isotropic and anisotropic part from above, additionally an active part in fibre direction
4721  ! W=W_iso+W_aniso+W_act
4722  ! with W_act=(1/sqrt(I4)*P_max*f*alpha)M
4723  !C(5)=alpha...activation parameter [0,1]
4724  IF(azl(1,1) > 1.0_dp) THEN ! only in the tension range
4725  piola_tensor(1,1)=piola_tensor(1,1)+c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4726  ENDIF
4727 ! IF((SQRT(AZL(1,1))>0.84_DP).AND.(SQRT(AZL(1,1))<1.96_DP)) THEN
4728  if((sqrt(azl(1,1))>0.72_dp).AND.(sqrt(azl(1,1))<1.68_dp)) then
4729 ! VALUE=(-25.0_DP/4.0_DP*AZL(1,1)/1.4_DP/1.4_DP + 25.0_DP/2.0_DP*SQRT(AZL(1,1))/1.4_DP - 5.25_DP) !f
4730  VALUE=(-25.0_dp/4.0_dp*azl(1,1)/1.2_dp/1.2_dp + 25.0_dp/2.0_dp*sqrt(azl(1,1))/1.2_dp - 5.25_dp)
4731  VALUE=VALUE*(1.0_dp/sqrt(azl(1,1)))*20.0_dp*c(5)
4732  piola_tensor(1,1)=piola_tensor(1,1)+VALUE
4733  ENDIF
4734 
4735  CASE(equations_set_anisotropic_polynomial_subtype)
4736  !Three additional terms for transversely isotropic (fibre-reinforced) materials (Markert, B., W. Ehlers, and N. Karajan.
4737  !A general polyconvex strain-energy function for fiber-reinforced materials.
4738  !Proceedings in Applied Mathematics and Mechanics 5.1 (2005): 245-246.)
4739  ! W_aniso=c3*(sqrt(I4)^(c4-2)-1/I4)M_1 + c5*(sqrt(I4)^(c6-2)-1/I4)M_2 + c7*(sqrt(I4)^(c8-2)-1/I4)M_3
4740  ! with M_1 being the mapping towards the fibre direction, here: I4=C_11
4741  !C(3)=c3...polynomial coefficient
4742  !C(4)=c4...power coefficient
4743  !C(5)=c5...polynomial coefficient
4744  !C(6)=c6...power coefficient
4745  !C(7)=c7...polynomial coefficient
4746  !C(8)=c8...power coefficient
4747  IF(azl(1,1) > 1.0_dp) THEN ! only in the tension range
4748  piola_tensor(1,1)=piola_tensor(1,1)+c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4749  ENDIF
4750  IF(azl(2,2) > 1.0_dp) THEN
4751  piola_tensor(2,2)=piola_tensor(2,2)+c(5)/azl(2,2)*(azl(2,2)**(c(6)/2.0_dp)-1.0_dp)
4752  ENDIF
4753  IF(azl(3,3) > 1.0_dp) THEN
4754  piola_tensor(3,3)=piola_tensor(3,3)+c(7)/azl(3,3)*(azl(3,3)**(c(8)/2.0_dp)-1.0_dp)
4755  ENDIF
4756 
4757  CASE(equations_set_anisotropic_polynomial_active_subtype)
4758  !Three additional terms for transversely isotropic (fibre-reinforced) materials (Markert, B., W. Ehlers, and N. Karajan.
4759  !A general polyconvex strain-energy function for fiber-reinforced materials.
4760  !Proceedings in Applied Mathematics and Mechanics 5.1 (2005): 245-246.)
4761  ! W_aniso=c3*(sqrt(I4)^(c4-2)-1/I4)M_1 + c5*(sqrt(I4)^(c6-2)-1/I4)M_2 + c7*(sqrt(I4)^(c8-2)-1/I4)M_3
4762  ! with M_1 being the mapping towards the fibre direction, here: I4=C_11
4763  !C(3)=c3...polynomial coefficient
4764  !C(4)=c4...power coefficient
4765  !C(5)=c5...polynomial coefficient
4766  !C(6)=c6...power coefficient
4767  !C(7)=c7...polynomial coefficient
4768  !C(8)=c8...power coefficient
4769  !C(9)=lambda_opt...optimal fibre stretch
4770  !C(10)=P_max...maximum active tension
4771  !C(11)=alpha...activation parameter [0 1]
4772  !C(12)=K_rfe...stiffness of the residual force enhancement
4773  IF(azl(1,1) > 1.0_dp) THEN ! only in the tension range
4774  piola_tensor(1,1)=piola_tensor(1,1)+c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4775  ENDIF
4776  IF(azl(2,2) > 1.0_dp) THEN
4777  piola_tensor(2,2)=piola_tensor(2,2)+c(5)/azl(2,2)*(azl(2,2)**(c(6)/2.0_dp)-1.0_dp)
4778  ENDIF
4779  IF(azl(3,3) > 1.0_dp) THEN
4780  piola_tensor(3,3)=piola_tensor(3,3)+c(7)/azl(3,3)*(azl(3,3)**(c(8)/2.0_dp)-1.0_dp)
4781  ENDIF
4782 
4783  val1=sqrt(azl(1,1))/c(9) !lambda/lambda_opt
4784  IF((val1>0.7_dp).AND.(val1<1.3_dp)) THEN
4785  !active force-length relation
4786  VALUE=(-11.1111_dp*val1*val1+22.2222_dp*val1-10.1111_dp)
4787  !multiply by P_max and alpha, divide by lambda
4788  VALUE=VALUE*c(10)*c(11)/sqrt(azl(1,1))
4789  ELSE
4790  VALUE=0.0_dp
4791  ENDIF
4792  !alpha*K_rfe*(lambda-lambda_start)/lambda
4793  !TODO make lambda_start variable --> independent field
4794  val2=c(11)*c(12)*(sqrt(azl(1,1))-1) !stretch and compression!!!
4795  VALUE=VALUE+val2/sqrt(azl(1,1))
4796  piola_tensor(1,1)=piola_tensor(1,1)+VALUE
4797 
4798  END SELECT
4799 
4800 
4801  CASE(equations_set_trans_isotropic_active_transition_subtype)
4802  !Equations set for transversely isotropic (fibre-reinforced), active contractible bodies consitisting of two materials
4803  ! The local portion between them is defined by the parameter trans
4804  ! Material 1 is active contractible, material 2 is only passive
4805  !W=W_iso+W_aniso+W_act
4806  ! where the three parts are adopted from above (iso Mooney-Rivlin, aniso Markert, active part)
4807  !Markert, B., W. Ehlers, and N. Karajan.
4808  !A general polyconvex strain-energy function for fiber-reinforced materials.
4809  !Proceedings in Applied Mathematics and Mechanics 5.1 (2005): 245-246.)
4810 
4811  !C(1)=c1_m1...Mooney Rivlin parameter material 1
4812  !C(2)=c2_m1...Mooney Rivlin parameter material 1
4813  !C(3)=c4_m1...polynomial coefficient (Markert model) material 1
4814  !C(4)=c5_m1...power coefficient (Markert model) material 1
4815  !C(5)=c1_m2...Mooney Rivlin parameter material 2
4816  !C(6)=c2_m2...Mooney Rivlin parameter material 2
4817  !C(7)=c4_m2...polynomial coefficient (Markert model) material 2
4818  !C(8)=c5_m2...power coefficient (Markert model) material 2
4819  !C(9)=alpha...activation parameter [0,1]
4820  !C(10)=trans...transition parameter [0,1] for the portion between the two materials
4821  !C(11)=P_max...maximum isometric stress
4822 
4823  !Weighting the Mooney Rivlin parameters and obtaining resulting c1 and c2
4824  val1=c(1)*c(10)+c(5)*(1.0_dp-c(10))
4825  val2=c(2)*c(10)+c(6)*(1.0_dp-c(10))
4826 
4827  !Mooney-Rivlin for the isotropic part
4828  piola_tensor(1,1)=2.0_dp*(val1+val2*(azl(2,2)+azl(3,3))+p*azu(1,1))
4829  piola_tensor(1,2)=2.0_dp*( val2*(-azl(2,1)) +p*azu(1,2))
4830  piola_tensor(1,3)=2.0_dp*( val2*(-azl(3,1)) +p*azu(1,3))
4831  piola_tensor(2,1)=piola_tensor(1,2)
4832  piola_tensor(2,2)=2.0_dp*(val1+val2*(azl(3,3)+azl(1,1))+p*azu(2,2))
4833  piola_tensor(2,3)=2.0_dp*( val2*(-azl(3,2)) +p*azu(2,3))
4834  piola_tensor(3,1)=piola_tensor(1,3)
4835  piola_tensor(3,2)=piola_tensor(2,3)
4836  piola_tensor(3,3)=2.0_dp*(val1+val2*(azl(1,1)+azl(2,2))+p*azu(3,3))
4837 
4838  !passive anisotropic part -- only in the tension range (Markert)
4839  IF(azl(1,1) > 1.0_dp) THEN
4840  val1=c(3)/azl(1,1)*(azl(1,1)**(c(4)/2.0_dp)-1.0_dp)
4841  val2=c(7)/azl(1,1)*(azl(1,1)**(c(8)/2.0_dp)-1.0_dp)
4842  piola_tensor(1,1)=piola_tensor(1,1)+(val1*c(10)+val2*(1.0_dp-c(10)))
4843  ENDIF
4844 
4845  !active part
4846  IF((sqrt(azl(1,1))>0.84_dp).AND.(sqrt(azl(1,1))<1.96_dp)) THEN
4847  VALUE=(-25.0_dp/4.0_dp*azl(1,1)/1.4_dp/1.4_dp + 25.0_dp/2.0_dp*sqrt(azl(1,1))/1.4_dp - 5.25_dp)
4848  VALUE=VALUE*(1.0_dp/sqrt(azl(1,1)))*c(9)*c(10)*c(11)
4849  piola_tensor(1,1)=piola_tensor(1,1)+VALUE
4850  ENDIF
4851 
4852  CASE(equations_set_isotropic_exponential_subtype)
4853  !Form of constitutive model is:
4854  ! W=c1/2 (e^(c2*(I1-3)) - 1)
4855  ! S = 2*dW/dC + 2pC^-1
4856  piola_tensor=c(1)*c(2)*exp(c(2)*(azl(1,1)+azl(2,2)+azl(3,3)-3.0_dp))*identity+2.0_dp*p*azu
4857  CASE(equations_set_elasticity_fluid_pressure_static_inria_subtype)
4858  !C(1)=Mooney Rivlin parameter
4859  !C(2)=Mooney Rivlin parameter
4860  !C(3)=K
4861  !C(4)=M, Biot modulus
4862  !C(5)=b, skeleton parameter
4863  !C(6)=p0, reference pressure
4864 
4865  p=darcy_dependent_interpolated_point%VALUES(1,no_part_deriv) !Fluid pressure
4866  CALL matrix_transpose(azl,azlt,err,error,*999)
4867  i1=azl(1,1)+azl(2,2)+azl(3,3)
4868  temp=matmul(azl,azl)
4869  i2=0.5_dp*(i1**2.0_dp-temp(1,1)-temp(2,2)-temp(3,3))
4870 
4871  CALL evaluate_chapelle_function(jznu,ffact,dfdjfact,err,error,*999)
4872 
4873  piola_tensor=2.0_dp*c(1)*jznu**(-2.0_dp/3.0_dp)*(identity-(1.0_dp/3.0_dp)*i1*azu)
4874  piola_tensor=piola_tensor+2.0_dp*c(2)*jznu**(-4.0_dp/3.0_dp)*(i1*identity-azlt-(2.0_dp/3.0_dp)*i2*azu)
4875  piola_tensor=piola_tensor+(c(3)-c(4)*c(5)**2)*(jznu-1.0_dp)*azu
4876  piola_tensor=piola_tensor-c(5)*(p-c(6))*jznu*azu
4877  piola_tensor=piola_tensor+0.5_dp*((p-c(6))**2/c(4))*(dfdjfact/(ffact**2))*jznu*azu
4878  CASE(equations_set_elasticity_fluid_pressure_holmes_mow_subtype)
4879  ! See Holmes MH, Mow VC. The nonlinear characteristics of soft gels and hydrated connective tissues in ultrafiltration.
4880  ! Journal of Biomechanics. 1990;23(11):1145-1156. DOI: 10.1016/0021-9290(90)90007-P
4881  ! The form of constitutive relation is:
4882  ! sigma = sigma^s + sigma^f
4883  ! sigma^f = -phi^f p I
4884  ! sigma^s = -phi^s p I + rho_0^s sigma^s_E
4885  ! sigma^s_E is the effective Cauchy stress obtained by differentiating
4886  ! the free energy function to get the second Piola-Kirchoff stress tensor:
4887  ! rho_0^s W^s = c0 exp(c1(I1 - 3) + c2(I2 - 3)) / (I_3^(c1 + 2c2))
4888  ! Rather than add the "phi^s p I" term to the Cauchy stress, we add it here as "phi^s p J C^-1"
4889  ! We also set rho_0^s = the solid density * initial solidity, and move the solidity
4890  ! inside the strain energy density function
4891  !
4892  ! c0 = C(1)
4893  ! c1 = C(2)
4894  ! c2 = C(3)
4895  ! phi^s_0 = C(4)
4896 
4897  CALL matrix_transpose(azl,azlt,err,error,*999)
4898  CALL matrix_transpose(azu,azut,err,error,*999)
4899  i1=azl(1,1)+azl(2,2)+azl(3,3)
4900  temp=matmul(azl,azl)
4901  i2=0.5_dp*(i1**2.0_dp-temp(1,1)-temp(2,2)-temp(3,3))
4902  !I3 already defined
4903 
4904  tempterm=2.0_dp*c(4)*c(1)*exp(c(2)*(i1 - 3.0_dp) + c(3)*(i2 - 3.0_dp)) / (i3**(c(2)+2.0_dp*c(3)))
4905  piola_tensor=c(2)*tempterm*identity + c(3)*tempterm*(i1*identity-azlt) - (c(2)+2.0_dp*c(3))*tempterm*azut
4906  piola_tensor=piola_tensor - darcy_dependent_interpolated_point%VALUES(1,no_part_deriv)*jznu*azu
4907 
4908  CASE(equations_set_elasticity_fluid_pres_holmes_mow_active_subtype)
4909  ! See Holmes MH, Mow VC. The nonlinear characteristics of soft gels and hydrated connective tissues in ultrafiltration.
4910  ! Journal of Biomechanics. 1990;23(11):1145-1156. DOI: 10.1016/0021-9290(90)90007-P
4911  ! The form of constitutive relation is:
4912  ! sigma = sigma^s + sigma^f
4913  ! sigma^f = -phi^f p I
4914  ! sigma^s = -phi^s p I + rho_0^s sigma^s_E
4915  ! sigma^s_E is the effective Cauchy stress obtained by differentiating
4916  ! the free energy function to get the second Piola-Kirchoff stress tensor:
4917  ! rho_0^s W^s = c0 exp(c1(I1 - 3) + c2(I2 - 3)) / (I_3^(c1 + 2c2))
4918  ! Rather than add the "phi^s p I" term to the Cauchy stress, we add it here as "phi^s p J C^-1"
4919  ! We also set rho_0^s = the solid density * initial solidity, and move the solidity
4920  ! inside the strain energy density function
4921  !
4922  ! c0 = C(1)
4923  ! c1 = C(2)
4924  ! c2 = C(3)
4925  ! phi^s_0 = C(4)
4926  ! alpha = C(5) (activation level)
4927  ! P_max = C(6) (maximum isometric active stress)
4928 
4929  CALL matrix_transpose(azl,azlt,err,error,*999)
4930  CALL matrix_transpose(azu,azut,err,error,*999)
4931  i1=azl(1,1)+azl(2,2)+azl(3,3)
4932  temp=matmul(azl,azl)
4933  i2=0.5_dp*(i1**2.0_dp-temp(1,1)-temp(2,2)-temp(3,3))
4934  !I3 already defined
4935 
4936  tempterm=2.0_dp*c(4)*c(1)*exp(c(2)*(i1 - 3.0_dp) + c(3)*(i2 - 3.0_dp)) / (i3**(c(2)+2.0_dp*c(3)))
4937  piola_tensor=c(2)*tempterm*identity + c(3)*tempterm*(i1*identity-azlt) - (c(2)+2.0_dp*c(3))*tempterm*azut
4938  piola_tensor=piola_tensor - darcy_dependent_interpolated_point%VALUES(1,no_part_deriv)*jznu*azu
4939 
4940  IF((sqrt(azl(1,1))>0.72_dp).AND.(sqrt(azl(1,1))<1.68_dp)) THEN
4941  VALUE=(-25.0_dp/4.0_dp*azl(1,1)/1.2_dp/1.2_dp + 25.0_dp/2.0_dp*sqrt(azl(1,1))/1.2_dp - 5.25_dp)
4942  ELSE
4943  VALUE=0.0_dp
4944  END IF
4945 
4946  piola_tensor(1,1) = piola_tensor(1,1) + 1.0_dp/sqrt(azl(1,1))*c(5)*c(6)*VALUE
4947 
4948  CASE(equations_set_stvenant_kirchoff_activecontraction_subtype)
4949  ! For of constitutive model is:
4950  ! W = 0.5lambda*tr(E)^2 + mu*tr(E^2)
4951  ! S = dW/dE = lambda*tr(E)Identity + 2muE
4952  piola_tensor(1,3)=(2.0_dp*c(2)*e(1,3))+(2.0_dp*p*azu(1,3))
4953  piola_tensor(2,3)=(2.0_dp*c(2)*e(2,3))+(2.0_dp*p*azu(2,3))
4954  piola_tensor(3,1)=piola_tensor(1,3)
4955  piola_tensor(3,2)=piola_tensor(2,3)
4956  piola_tensor(3,3)=c(1)*(e(1,1)+e(2,2)+e(3,3))+(2.0_dp*e(3,3)*c(2)+(2.0_dp*p*azu(3,3)))
4957 
4958  piola_tensor(1,1)=c(1)*(e(1,1)+e(2,2)+e(3,3))+(2.0_dp*e(1,1)*c(2)+(2.0_dp*p*azu(1,1)))
4959  piola_tensor(1,2)=(2.0_dp*c(2)*e(1,2))+(2.0_dp*p*azu(1,2))
4960  piola_tensor(2,1)=piola_tensor(1,2)
4961  piola_tensor(2,2)=c(1)*(e(1,1)+e(2,2)+e(3,3))+(2.0_dp*e(2,2)*c(2)+(2.0_dp*p*azu(2,2)))
4962 
4963  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4964  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,1,active_stress_11, &
4965  & err,error,*999) ! get the independent field stress value
4966 
4967  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4968  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,2,active_stress_22, &
4969  & err,error,*999) ! get the independent field stress value
4970 
4971  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
4972  & field_u_variable_type, field_values_set_type,gauss_point_number,element_number,3,active_stress_33, &
4973  & err,error,*999) ! get the independent field stress value
4974 
4975  piola_tensor(1,1)=piola_tensor(1,1)+active_stress_11
4976  piola_tensor(2,2)=piola_tensor(2,2)+active_stress_22
4977  piola_tensor(3,3)=piola_tensor(3,3)+active_stress_33
4978 
4979  CASE(equations_set_transverse_isotropic_exponential_subtype)
4980  !Form of constitutive model is:
4981  ! W=c1/2 (e^Q - 1)
4982  ! where Q=2c2(E11+E22+E33)+c3(E11^2)+c4(E22^2+E33^2+E23^2+E32^2)+c5(E12^2+E21^2+E31^2+E13^2)
4983  ! with E expressed in fibre coordinates
4984 
4985  tempterm=c(1)*exp(2.0*c(2)*(e(1,1)+e(2,2)+e(3,3))+c(3)*e(1,1)**2+c(4)*(e(2,2)**2+e(3,3)**2+2.0_dp*e(2,3)**2)+ &
4986  & c(5)*2.0_dp*(e(1,2)**2+e(1,3)**2))
4987  piola_tensor(1,1)=(c(2)+c(3)*e(1,1))*tempterm+2.0_dp*p*azu(1,1)
4988  piola_tensor(1,2)=c(5)*e(1,2)*tempterm+2.0_dp*p*azu(1,2)
4989  piola_tensor(1,3)=c(5)*e(1,3)*tempterm+2.0_dp*p*azu(1,3)
4990  piola_tensor(2,1)=piola_tensor(1,2)
4991  piola_tensor(2,2)=(c(2)+c(4)*e(2,2))*tempterm+2.0_dp*p*azu(2,2)
4992  piola_tensor(2,3)=c(4)*e(2,3)*tempterm+2.0_dp*p*azu(2,3)
4993  piola_tensor(3,1)=piola_tensor(1,3)
4994  piola_tensor(3,2)=piola_tensor(2,3)
4995  piola_tensor(3,3)=(c(2)+c(4)*e(3,3))*tempterm+2.0_dp*p*azu(3,3)
4996 
4997  CASE(equations_set_transverse_isotropic_guccione_subtype,equations_set_guccione_activecontraction_subtype)
4998  ! W=C1*exp*(Q) + p(J-1)
4999  ! Q=C2*E(1,1)^2 + C3*(E(2,2)^2+E(3,3)^2+2*E(2,3)*E(3,2)) + 2*C4*(E(1,2)*E(2,1)+E(1,3)*E(3,1))
5000  q=c(2)*e(1,1)**2 + c(3)*(e(2,2)**2+e(3,3)**2+2.0_dp*e(2,3)**2) + 2.0_dp*c(4)*(e(1,2)**2+e(1,3)**2)
5001  tempterm=0.5_dp*c(1)*exp(q) ! iso term
5002  piola_tensor(1,1) = 2.0_dp*c(2) * e(1,1)
5003  piola_tensor(2,2) = 2.0_dp*c(3) * e(2,2)
5004  piola_tensor(3,3) = 2.0_dp*c(3) * e(3,3)
5005  piola_tensor(1,2) = 2.0_dp*c(4) * e(1,2)
5006  piola_tensor(2,1) = piola_tensor(1,2)
5007  piola_tensor(1,3) = 2.0_dp*c(4) * e(1,3)
5008  piola_tensor(3,1) = piola_tensor(1,3)
5009  piola_tensor(3,2) = 2.0_dp*c(3) * e(2,3)
5010  piola_tensor(2,3) = piola_tensor(3,2)
5011  piola_tensor = piola_tensor * tempterm
5012  ! pressure terms
5013 !
5014 ! TEMP DURING MERGE
5015 !
5016 ! PIOLA_TENSOR = PIOLA_TENSOR + 2.0_DP*p*Jznu*AZU ! is Jznu required here, or is it omitted everywhere else?
5017 !
5018 ! IF(EQUATIONS_SET%SPECIFICATION(3)==EQUATIONS_SET_GUCCIONE_ACTIVECONTRACTION_SUBTYPE) THEN
5019 ! !the active stress is stored inside the independent field that has been set up in the user program.
5020 ! !for better generality we could set up 3 components in independent field for 3 different active stress components,
5021 ! !but only one component is implemented so far for fibre active tension.
5022 ! CALL FIELD_VARIABLE_GET(EQUATIONS_SET%INDEPENDENT%INDEPENDENT_FIELD,FIELD_U_VARIABLE_TYPE,FIELD_VARIABLE,ERR,ERROR,*999)
5023 ! DO i=1,FIELD_VARIABLE%NUMBER_OF_COMPONENTS
5024 ! dof_idx=FIELD_VARIABLE%COMPONENTS(i)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
5025 ! & GAUSS_POINTS(GAUSS_POINT_NUMBER,ELEMENT_NUMBER)
5026 ! CALL FIELD_PARAMETER_SET_GET_LOCAL_DOF(EQUATIONS_SET%INDEPENDENT%INDEPENDENT_FIELD,FIELD_U_VARIABLE_TYPE, &
5027 ! & FIELD_VALUES_SET_TYPE,dof_idx,VALUE,ERR,ERROR,*999)
5028 ! PIOLA_TENSOR(1,1)=PIOLA_TENSOR(1,1)+VALUE
5029 ! ENDDO
5030 ! ENDIF
5031  !PIOLA_TENSOR = PIOLA_TENSOR + 2.0_DP*p*Jznu*AZU ! is Jznu required here, or is it omitted everywhere else?
5032  piola_tensor = piola_tensor + p*azu ! is Jznu required here, or is it omitted everywhere else?
5033  IF(equations_set_subtype==equations_set_guccione_activecontraction_subtype) THEN
5034  !add active contraction stress value to the trace of the stress tensor - basically adding to hydrostatic pressure.
5035  !the active stress is stored inside the independent field that has been set up in the user program.
5036  !for generality we could set up 3 components in independent field for 3 different active stress components
5037  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
5038  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
5039  dof_idx=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
5040  & gauss_points(gauss_point_number,element_number)
5041  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
5042  & field_values_set_type,dof_idx,VALUE,err,error,*999)
5043  piola_tensor(component_idx,component_idx)=piola_tensor(component_idx,component_idx)+VALUE
5044  ENDDO
5045  ENDIF
5046  CASE(equations_set_transverse_isotropic_humphrey_yin_subtype)
5047  ! W=a*(exp(b(I1-3))-1) + c*(exp(d(alpha-1)^2)-1)
5048  ! a=C(1), b=C(2), c=C(3), d=C(4)
5049  i1=azl(1,1)+azl(2,2)+azl(3,3)
5050  piola_tensor(1,1)=c(1)*c(2)*exp(c(2)*(i1-3))+ &
5051  & c(3)*2.0_dp*(sqrt(azl(1,1))-1)*c(4)*exp(c(4)*(sqrt(azl(1,1))-1)**2)/(2*sqrt(azl(1,1)))+p*azu(1,1)
5052  piola_tensor(2,2)=c(1)*c(2)*exp(c(2)*(i1-3))+p*azu(2,2)
5053  piola_tensor(3,3)=c(1)*c(2)*exp(c(2)*(i1-3))+p*azu(3,3)
5054  piola_tensor(1,2)=p*azu(1,2)
5055  piola_tensor(1,3)=p*azu(1,3)
5056  piola_tensor(2,3)=p*azu(2,3)
5057  piola_tensor(2,1)=piola_tensor(1,2)
5058  piola_tensor(3,1)=piola_tensor(1,3)
5059  piola_tensor(3,2)=piola_tensor(2,3)
5060  piola_tensor=piola_tensor*2.0_dp
5061  CASE(equations_set_orthotropic_material_costa_subtype,equations_set_activecontraction_subtype) !added by Robert 2010-01-23
5062  !Form of constitutive model is:
5063  ! W=a/2 (e^Q - 1)
5064  ! where Q=[b_ff 2b_fs 2b_fn b_ss 2b_sn b_nn]'* [E_ff E_fs E_fn E_ss E_sn E_nn].^2;
5065  ! f,s,n denotes the fibre sheet and sheet-normal direction
5066  a = materials_interpolated_point%VALUES(1,1)
5067  b(1,1) = materials_interpolated_point%VALUES(1+1,1)
5068  b(1,2) = materials_interpolated_point%VALUES(1+2,1)
5069  b(1,3) = materials_interpolated_point%VALUES(1+3,1)
5070  b(2,1) = b(1,2);
5071  b(2,2) = materials_interpolated_point%VALUES(1+4,1)
5072  b(2,3) = materials_interpolated_point%VALUES(1+5,1)
5073  b(3,1) = b(1,3);
5074  b(3,2) = b(2,3);
5075  b(3,3) = materials_interpolated_point%VALUES(1+6,1)
5076  q = 0.0_dp;
5077  DO i=1,3,1
5078  DO j=1,3,1
5079  IF (i==j) THEN
5080  e(i,j) = 0.5_dp * (azl(i,j)-1);
5081  ELSE
5082  e(i,j) = 0.5_dp * azl(i,j);
5083  ENDIF
5084  q = q + b(i,j) * e(i,j) * e(i,j)
5085  ENDDO
5086  ENDDO
5087  q = exp(q);
5088  DO i=1,3,1
5089  DO j=1,3,1
5090  piola_tensor(i,j)=a*b(i,j)*e(i,j)*q + p*azu(i,j);
5091  ENDDO
5092  ENDDO
5093 
5094  IF(equations_set_subtype == equations_set_activecontraction_subtype) THEN
5095  CALL finiteelasticity_piolaaddactivecontraction(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
5096  & equations_set%EQUATIONS%INTERPOLATION%MATERIALS_FIELD, piola_tensor(1,1),e(1,1), &
5097  & element_number,gauss_point_number,err,error,*999)
5098  ENDIF
5099  CASE (equations_set_compressible_finite_elasticity_subtype,equations_set_elasticity_darcy_inria_model_subtype, &
5100  & equations_set_compressible_activecontraction_subtype, &
5101  & equations_set_incompressible_elasticity_driven_darcy_subtype,equations_set_incompressible_elast_multi_comp_darcy_subtype)
5102  !Form of constitutive model is:
5103  ! W=c1*(I1-3)+c2*(I2-3)+c3*(J-1)^2 (this is actually nearly incompressible)
5104  c(1)=materials_interpolated_point%VALUES(1,1)
5105  c(2)=materials_interpolated_point%VALUES(2,1)
5106 
5107  piola_tensor(1,1)=c(1)+c(2)*(azl(2,2)+azl(3,3))
5108  piola_tensor(1,2)=c(2)*(-azl(2,1))
5109  piola_tensor(1,3)=c(2)*(-azl(3,1))
5110  piola_tensor(2,1)=piola_tensor(1,2)
5111  piola_tensor(2,2)=c(1)+c(2)*(azl(3,3)+azl(1,1))
5112  piola_tensor(2,3)=c(2)*(-azl(3,2))
5113  piola_tensor(3,1)=piola_tensor(1,3)
5114  piola_tensor(3,2)=piola_tensor(2,3)
5115  piola_tensor(3,3)=c(1)+c(2)*(azl(1,1)+azl(2,2))
5116  piola_tensor=piola_tensor*2.0_dp
5117 
5118  IF(diagnostics1) THEN
5119  CALL write_string_value(diagnostic_output_type," C(1) = ",c(1),err,error,*999)
5120  CALL write_string_value(diagnostic_output_type," C(2) = ",c(2),err,error,*999)
5121  CALL write_string_matrix(diagnostic_output_type,1,1,3,1,1,3, &
5122  & 3,3,azl,write_string_matrix_name_and_indices,'(" AZL','(",I1,",:)',' :",3(X,E13.6))', &
5123  & '(17X,3(X,E13.6))',err,error,*999)
5124  ENDIF
5125 
5126  IF(equations_set_subtype==equations_set_compressible_activecontraction_subtype) THEN
5127 
5128  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
5129  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,1,active_stress_11, &
5130  & err,error,*999) ! get the independent field stress value
5131 
5132  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
5133  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,2,active_stress_22, &
5134  & err,error,*999) ! get the independent field stress value
5135 
5136  CALL field_parametersetgetlocalgausspoint(equations_set%INDEPENDENT%INDEPENDENT_FIELD, &
5137  & field_u_variable_type,field_values_set_type,gauss_point_number,element_number,3,active_stress_33, &
5138  & err,error,*999) ! get the independent field stress value
5139 
5140  piola_tensor(1,1)=piola_tensor(1,1)+active_stress_11
5141  piola_tensor(2,2)=piola_tensor(2,2)+active_stress_22
5142  piola_tensor(3,3)=piola_tensor(3,3)+active_stress_33
5143  ENDIF
5144  IF(equations_set_subtype==equations_set_compressible_finite_elasticity_subtype .OR. &
5145  & equations_set_subtype==equations_set_compressible_activecontraction_subtype) THEN
5146  c(3)=materials_interpolated_point%VALUES(3,1)
5147  piola_tensor=piola_tensor+2.0_dp*c(3)*(i3-sqrt(i3))*azu
5148  ELSEIF(equations_set_subtype==equations_set_elasticity_darcy_inria_model_subtype.OR. &
5149  & equations_set_subtype==equations_set_incompressible_elasticity_driven_darcy_subtype .OR. &
5150  & equations_set_subtype==equations_set_incompressible_elast_multi_comp_darcy_subtype) THEN
5151  SELECT CASE (equations_set_subtype)
5152  CASE (equations_set_elasticity_darcy_inria_model_subtype) !Nearly incompressible
5153  c(3)=materials_interpolated_point%VALUES(3,1)
5154  !Starting point for this models is above compressible form of 2nd PK tensor
5155  !Adjust for the modified Ciarlet-Geymonat expression: Eq.(22) of the INRIA paper
5156  ! Question is: What deviation is to be penalized : (J-1) or (J-1-m/rho) ??? Probably the latter !
5157  ! However, m/rho is a given 'constant' and, upon differentiation, drops out.
5158  ! But it is important to retain I3 = J^2, since J ~ 1 + m/rho /= 1
5159  piola_tensor=piola_tensor+c(3)*(sqrt(i3)-1.0_dp)*azu
5160  darcy_mass_increase_entry = 5 !fifth entry
5161  CASE (equations_set_incompressible_elasticity_driven_darcy_subtype, &
5162  & equations_set_incompressible_elast_multi_comp_darcy_subtype) !Incompressible
5163  !Constitutive model: W=c1*(I1-3)+c2*(I2-3)+p*(I3-1)
5164  ! The term 'p*(I3-1)' gives rise to: '2p I3 AZU'
5165  ! Retain I3 = J^2, since J ~ 1 + m/rho /= 1
5166 ! CASE (EQUATIONS_SET_INCOMPRESSIBLE_ELASTICITY_DRIVEN_MR_SUBTYPE)
5167  !Constitutive model: W=C1*(J1-3)+C2*(J2-3)+C3*(J-1)^2+lambda.(J-1-m/rho)
5168  !J1 and J2 are the modified invariants, adjusted for volume change (J1=I1*J^(-2/3), J2=I2*J^(-4/3))
5169  !Strictly speaking this law isn't for an incompressible material, but the fourth equation in the elasticity
5170  !is used to satisfy a subtly different constraint, which is to require the solid portion of the poroelastic
5171  !material retains its volume. (This law is applied on the whole pororous body).
5172 
5173  piola_tensor=0.0_dp
5174  temp=0.0_dp
5175 
5176  c(1)=materials_interpolated_point%VALUES(1,1)
5177  c(2)=materials_interpolated_point%VALUES(2,1)
5178  c(3)=materials_interpolated_point%VALUES(3,1)
5179 
5180  !J1 term: del(J1)/del(C)=J^(-2/3)*I-2/3*I_1*J^(-2/3)*C^-1
5181  tempterm=jznu**(-2.0_dp/3.0_dp)
5182  temp(1,1)=tempterm
5183  temp(2,2)=tempterm
5184  temp(3,3)=tempterm
5185  i1=azl(1,1)+azl(2,2)+azl(3,3)
5186  piola_tensor=c(1)* (temp-1.0_dp/3.0_dp*i1*tempterm*azu)
5187 
5188  !J2 term: del(J2)/del(C)=J^(-4/3)*del(I2)/del(C) -4/3*I_2*J^(-4/3)*C^-1
5189  temp=matmul(azl,azl) ! C^2
5190  i2=0.5_dp*(i1**2.0_dp-(temp(1,1)+temp(2,2)+temp(3,3)))
5191  tempterm=jznu**(-4.0_dp/3.0_dp)
5192  !TEMP is now del(I2)/del(C)
5193  temp(1,1)=azl(2,2)+azl(3,3)
5194 ! TEMP(1,2)=-2.0_DP*AZL(1,2)
5195  temp(1,2)=-1.0_dp*azl(1,2)
5196 ! TEMP(1,3)=-2.0_DP*AZL(1,3)
5197  temp(1,3)=-1.0_dp*azl(1,3)
5198  temp(2,1)=temp(1,2)
5199  temp(2,2)=azl(1,1)+azl(3,3)
5200 ! TEMP(2,3)=-2.0_DP*AZL(2,3)
5201  temp(2,3)=-1.0_dp*azl(2,3)
5202  temp(3,1)=temp(1,3)
5203  temp(3,2)=temp(2,3)
5204  temp(3,3)=azl(1,1)+azl(2,2)
5205  piola_tensor=piola_tensor+c(2)* (tempterm*temp-2.0_dp/3.0_dp*i2*tempterm*azu)
5206 
5207  !J (det(F)) term: (2.C3.(J-1)+lambda)*J.C^-1
5208  piola_tensor=piola_tensor+(2.0_dp*c(3)*(jznu-1.0_dp)+p)*jznu*azu
5209 
5210  !Don't forget, it's wrt C so there is a factor of 2 - but not for the pressure !!??
5211  piola_tensor=2.0_dp*piola_tensor
5212 
5213 
5214  darcy_mass_increase_entry = 4 !fourth entry
5215 
5216  END SELECT
5217 
5218 ! DARCY_MASS_INCREASE = DARCY_DEPENDENT_INTERPOLATED_POINT%VALUES(DARCY_MASS_INCREASE_ENTRY,NO_PART_DERIV)
5219 !
5220 ! CALL EVALUATE_CHAPELLE_PIOLA_TENSOR_ADDITION(AZL,AZU,DARCY_MASS_INCREASE,PIOLA_TENSOR_ADDITION,ERR,ERROR,*999)
5221 !
5222 ! IF(DIAGNOSTICS1) THEN
5223 ! CALL WRITE_STRING_MATRIX(DIAGNOSTIC_OUTPUT_TYPE,1,1,3,1,1,3, &
5224 ! & 3,3,PIOLA_TENSOR,WRITE_STRING_MATRIX_NAME_AND_INDICES,'(" PIOLA_TENSOR','(",I1,",:)',' :",3(X,E13.6))', &
5225 ! & '(17X,3(X,E13.6))',ERR,ERROR,*999)
5226 ! CALL WRITE_STRING_MATRIX(DIAGNOSTIC_OUTPUT_TYPE,1,1,3,1,1,3, &
5227 ! & 3,3,PIOLA_TENSOR_ADDITION, &
5228 ! & WRITE_STRING_MATRIX_NAME_AND_INDICES,'(" PIOLA_TENSOR_ADDITION','(",I1,",:)',' :",3(X,E13.6))', &
5229 ! & '(17X,3(X,E13.6))',ERR,ERROR,*999)
5230 ! ENDIF
5231 !
5232 ! PIOLA_TENSOR = PIOLA_TENSOR + PIOLA_TENSOR_ADDITION
5233  ENDIF
5234 
5235  CASE (equations_set_orthotropic_material_holzapfel_ogden_subtype, &
5236  & equations_set_holzapfel_ogden_activecontraction_subtype)
5237  !Form of the constitutive model is:
5238  ! W = a/(2*b)*exp[b*(I1-3)] + sum_(i=f,s)[H(I4i-1)*a_i/(2*b_i)*(exp[b_i*(I4i-1)^2]-1)] + a_fs/(2*b_fs)*(exp[b_fs*I8fs^2]-1)
5239  !where H is the Heaviside step function. Fibres only contribute stiffness if in tension.
5240  !Also assumed I3 = det(AZL) = J^2 = 1.0 - incompressible material
5241  !Assume directions: fibre f_0=[1 0 0], sheet s_0=[0 1 0], (sheet) normal n_0=[0 0 1]
5242  !Based on: Holzapfel, G. A., & Ogden, R. W. (2009). Constitutive modelling of passive myocardium: A structurally based
5243  ! framework for material characterization. Philosophical Transactions of the Royal Society A: Mathematical, Physical and
5244  ! Engineering Sciences, 367(1902), 3445-3475. doi:10.1098/rsta.2009.0091
5245  c(1)=materials_interpolated_point%VALUES(1,1) !a
5246  c(2)=materials_interpolated_point%VALUES(2,1) !b
5247  c(3)=materials_interpolated_point%VALUES(3,1) !a_f
5248  c(4)=materials_interpolated_point%VALUES(4,1) !a_s
5249  c(5)=materials_interpolated_point%VALUES(5,1) !b_f
5250  c(6)=materials_interpolated_point%VALUES(6,1) !b_s
5251  c(7)=materials_interpolated_point%VALUES(7,1) !a_fs
5252  c(8)=materials_interpolated_point%VALUES(8,1) !b_fs
5253  i1=azl(1,1)+azl(2,2)+azl(3,3)
5254  tempterm=c(1)*exp(c(2)*(i1-3.0_dp))
5255  piola_tensor(1,1)=-p*azu(1,1)+tempterm
5256  IF(azl(1,1)>1.0_dp) THEN
5257  piola_tensor(1,1)=piola_tensor(1,1)+2.0_dp*c(3)*(azl(1,1)-1.0_dp)*exp(c(5)*(azl(1,1)-1.0_dp)**2.0_dp)
5258  END IF
5259  piola_tensor(1,2)=-p*azu(1,2)+c(7)*azl(1,2)*exp(c(8)*azl(1,2)**2.0_dp)
5260  piola_tensor(1,3)=-p*azu(1,3)
5261  piola_tensor(2,1)=piola_tensor(1,2)
5262  piola_tensor(2,2)=-p*azu(2,2)+tempterm
5263  IF(azl(2,2)>1.0_dp) THEN
5264  piola_tensor(2,2)=piola_tensor(2,2)+2.0_dp*c(4)*(azl(2,2)-1.0_dp)*exp(c(6)*(azl(2,2)-1.0_dp)**2.0_dp)
5265  END IF
5266  piola_tensor(2,3)=-p*azu(2,3)
5267  piola_tensor(3,1)=piola_tensor(1,3)
5268  piola_tensor(3,2)=piola_tensor(2,3)
5269  piola_tensor(3,3)=-p*azu(3,3)+tempterm
5270 
5271  IF(equations_set_subtype==equations_set_holzapfel_ogden_activecontraction_subtype) THEN
5272  !add active contraction stress value to the trace of the stress tensor - basically adding to hydrostatic pressure.
5273  !the active stress is stored inside the independent field that has been set up in the user program.
5274  !for generality we could set up 3 components in independent field for 3 different active stress components
5275  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
5276  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
5277  dof_idx=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
5278  & gauss_points(gauss_point_number,element_number)
5279  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
5280  & field_values_set_type,dof_idx,VALUE,err,error,*999)
5281  piola_tensor(component_idx,component_idx)=piola_tensor(component_idx,component_idx)+VALUE
5282  ENDDO
5283  ENDIF
5284 
5285  CASE DEFAULT
5286  local_error="The third equations set specification of "//trim(number_to_vstring(equations_set_subtype,"*",err,error))// &
5287  & " is not valid for a finite elasticity type of an elasticity equation set."
5288  CALL flagerror(local_error,err,error,*999)
5289  END SELECT
5290 
5291  CALL matrix_product(dzdnu,piola_tensor,temp,err,error,*999)
5292  CALL matrix_product(temp,dzdnut,cauchy_tensor,err,error,*999)
5293 
5294  cauchy_tensor=cauchy_tensor/jznu
5295  IF(diagnostics1) THEN
5296  CALL write_string_value(diagnostic_output_type," ELEMENT_NUMBER = ",element_number,err,error,*999)
5297  CALL write_string_value(diagnostic_output_type," gauss_idx = ",gauss_point_number,err,error,*999)
5298  CALL write_string_matrix(diagnostic_output_type,1,1,3,1,1,3, &
5299  & 3,3,piola_tensor,write_string_matrix_name_and_indices,'(" PIOLA_TENSOR','(",I1,",:)',' :",3(X,E13.6))', &
5300  & '(17X,3(X,E13.6))',err,error,*999)
5301  CALL write_string_matrix(diagnostic_output_type,1,1,3,1,1,3, &
5302  & 3,3,cauchy_tensor,write_string_matrix_name_and_indices,'(" CAUCHY_TENSOR','(",I1,",:)',' :",3(X,E13.6))', &
5303  & '(17X,3(X,E13.6))',err,error,*999)
5304  ENDIF
5305  NULLIFY(c)
5306 
5307  exits("FINITE_ELASTICITY_GAUSS_CAUCHY_TENSOR")
5308  RETURN
5309 999 errorsexits("FINITE_ELASTICITY_GAUSS_CAUCHY_TENSOR",err,error)
5310  RETURN 1
5311  END SUBROUTINE finite_elasticity_gauss_cauchy_tensor
5312 
5313  !
5314  !================================================================================================================================
5315  !
5316 
5318  SUBROUTINE finiteelasticity_gaussgrowthtensor_newer123(equationsSet,numberOfDimensions,gaussPointNumber,elementNumber, &
5319  & dependentfield, deformationgradienttensor,growthtensor,elasticdeformationgradienttensor,jg,je,err,error,*)
5320 
5321  !Argument variables
5322  TYPE(equations_set_type), POINTER, INTENT(IN) :: equationsSet
5323  INTEGER(INTG), INTENT(IN) :: numberOfDimensions
5324  INTEGER(INTG), INTENT(IN) :: gaussPointNumber
5325  INTEGER(INTG), INTENT(IN) :: elementNumber
5326  TYPE(field_type), POINTER :: dependentField
5327  REAL(DP), INTENT(IN) :: deformationGradientTensor(3,3)
5328  REAL(DP), INTENT(OUT) :: growthTensor(3,3)
5329  REAL(DP), INTENT(OUT) :: elasticDeformationGradientTensor(3,3)
5330  REAL(DP), INTENT(OUT) :: Jg
5331  REAL(DP), INTENT(OUT) :: Je
5332  INTEGER(INTG), INTENT(OUT) :: err
5333  TYPE(varying_string), INTENT(OUT) :: error
5334  !Local Variables
5335  REAL(DP) :: growthTensorInverse(3,3), growthTensorInverseTranspose(3,3)
5336 
5337  enters("FiniteElasticity_GaussGrowthTensor",err,error,*999)
5338 
5339  IF(ASSOCIATED(equationsset)) THEN
5340  CALL identitymatrix(growthtensor,err,error,*999)
5341  IF(equationsset%specification(3)==equations_set_constitutive_and_growth_law_in_cellml_subtype) THEN
5342  CALL field_parametersetgetlocalgausspoint(dependentfield,field_u3_variable_type,field_values_set_type, &
5343  & gausspointnumber,elementnumber,1,growthtensor(1,1),err,error,*999)
5344  IF(numberofdimensions>1) THEN
5345  CALL field_parametersetgetlocalgausspoint(dependentfield,field_u3_variable_type,field_values_set_type, &
5346  & gausspointnumber,elementnumber,2,growthtensor(2,2),err,error,*999)
5347  IF(numberofdimensions>2) THEN
5348  CALL field_parametersetgetlocalgausspoint(dependentfield,field_u3_variable_type,field_values_set_type, &
5349  & gausspointnumber,elementnumber,3,growthtensor(3,3),err,error,*999)
5350  ENDIF
5351  ENDIF
5352  !Calculate inverse growth deformation tensor, Fg^-1, Jg
5353  CALL invert(growthtensor,growthtensorinverse,jg,err,error,*999)
5354  !Calculate elastic deformation tensor, Fe=F.(Fg)^-1.
5355  CALL matrixproduct(deformationgradienttensor,growthtensorinverse,elasticdeformationgradienttensor,err,error,*999)
5356  ELSE
5357  jg=1.0_dp
5358  elasticdeformationgradienttensor=deformationgradienttensor
5359  ENDIF
5360  je=determinant(elasticdeformationgradienttensor,err,error)
5361  IF(err/=0) GOTO 999
5362  ELSE
5363  CALL flagerror("Equations set is not associated.",err,error,*999)
5364  ENDIF
5365 
5366  IF(diagnostics1) THEN
5367  CALL writestring(diagnostic_output_type,"",err,error,*999)
5368  CALL writestring(diagnostic_output_type,"Growth information:",err,error,*999)
5369  CALL writestring(diagnostic_output_type," Total deformation gradient tensor:",err,error,*999)
5370  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3,3,3,deformationgradienttensor, &
5371  & write_string_matrix_name_and_indices,'(" F','(",I1,",:)',' :",3(X,E13.6))','(13X,3(X,E13.6))',err,error,*999)
5372  CALL writestringvalue(diagnostic_output_type," Determinant F, J = ",determinant(deformationgradienttensor,err,error), &
5373  & err,error,*999)
5374  CALL writestring(diagnostic_output_type," Elastic component of the deformation gradient tensor:",err,error,*999)
5375  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3,3,3,elasticdeformationgradienttensor, &
5376  & write_string_matrix_name_and_indices,'(" Fe','(",I1,",:)',' :",3(X,E13.6))','(13X,3(X,E13.6))',err,error,*999)
5377  CALL writestringvalue(diagnostic_output_type," Determinant Fe, Je = ",je,err,error,*999)
5378  CALL writestring(diagnostic_output_type," Growth component of the deformation gradient tensor:",err,error,*999)
5379  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3,3,3,growthtensor, &
5380  & write_string_matrix_name_and_indices,'(" Fg','(",I1,",:)',' :",3(X,E13.6))','(13X,3(X,E13.6))',err,error,*999)
5381  CALL writestringvalue(diagnostic_output_type," Determinant Fg, Jg = ",jg,err,error,*999)
5382  ENDIF
5383 
5384  exits("FiniteElasticity_GaussGrowthTensor")
5385  RETURN
5386  999 errorsexits("FiniteElasticity_GaussGrowthTensor",err,error)
5387  RETURN 1
5388 
5389  END SUBROUTINE finiteelasticity_gaussgrowthtensor_newer123
5390 
5391  !
5392  !================================================================================================================================
5393  !
5394 
5396  SUBROUTINE finiteelasticity_straintensor_newer123(deformationGradientTensor,rightCauchyDeformationTensor,&
5397  & fingerdeformationtensor, jacobian,greenstraintensor,err,error,*)
5398 
5399  !Argument variables
5400  REAL(DP), INTENT(IN) :: deformationGradientTensor(3,3)
5401  REAL(DP), INTENT(OUT) :: rightCauchyDeformationTensor(3,3)
5402  REAL(DP), INTENT(OUT) :: fingerDeformationTensor(3,3)
5403  REAL(DP), INTENT(OUT) :: Jacobian
5404  REAL(DP), INTENT(OUT) :: greenStrainTensor(3,3)
5405  INTEGER(INTG), INTENT(OUT) :: err
5406  TYPE(varying_string), INTENT(OUT) :: error
5407  !Local Variables
5408  INTEGER(INTG) :: i
5409  REAL(DP) :: I3
5410 
5411  enters("FiniteElasticity_StrainTensor",err,error,*999)
5412 
5413  CALL matrixtransposeproduct(deformationgradienttensor,deformationgradienttensor,rightcauchydeformationtensor,err,error,*999)
5414  CALL invert(rightcauchydeformationtensor,fingerdeformationtensor,i3,err,error,*999)
5415  jacobian=determinant(deformationgradienttensor,err,error)
5416 
5417  greenstraintensor=0.5_dp*rightcauchydeformationtensor
5418  DO i=1,3
5419  greenstraintensor(i,i)=greenstraintensor(i,i)-0.5_dp
5420  ENDDO !i
5421 
5422  IF(diagnostics1) THEN
5423  CALL writestring(diagnostic_output_type,"",err,error,*999)
5424  CALL writestring(diagnostic_output_type,"Strain information:",err,error,*999)
5425  CALL writestring(diagnostic_output_type," Right Cauchy-Green deformation tensor:",err,error,*999)
5426  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
5427  & 3,3,rightcauchydeformationtensor,write_string_matrix_name_and_indices, '(" C','(",I1,",:)', &
5428  & ' :",3(X,E13.6))','(12X,3(X,E13.6))',err,error,*999)
5429  CALL writestring(diagnostic_output_type," Finger deformation tensor:",err,error,*999)
5430  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
5431  & 3,3,fingerdeformationtensor,write_string_matrix_name_and_indices, '(" f','(",I1,",:)', &
5432  & ' :",3(X,E13.6))','(12X,3(X,E13.6))',err,error,*999)
5433  CALL writestringvalue(diagnostic_output_type," Jacobian = ",jacobian,err,error,*999)
5434  CALL writestring(diagnostic_output_type," Green-Lagrange strain tensor:",err,error,*999)
5435  CALL writestringmatrix(diagnostic_output_type,1,1,3,1,1,3, &
5436  & 3,3,greenstraintensor,write_string_matrix_name_and_indices, '(" E','(",I1,",:)', &
5437  & ' :",3(X,E13.6))','(12X,3(X,E13.6))',err,error,*999)
5438  ENDIF
5439 
5440  exits("FiniteElasticity_StrainTensor")
5441  RETURN
5442  999 errorsexits("FiniteElasticity_StrainTensor",err,error)
5443  RETURN 1
5444 
5445  END SUBROUTINE finiteelasticity_straintensor_newer123
5446 
5447  !
5448  !================================================================================================================================
5449  !
5450 
5452  SUBROUTINE finite_elasticity_gauss_stress_tensor(EQUATIONS_SET,DEPENDENT_INTERPOLATED_POINT, &
5453  & materials_interpolated_point,stress_tensor,dzdnu,jznu,element_number,gauss_point_number,err,error,*)
5454 
5455  !Argument variables
5456  TYPE(equations_set_type), POINTER, INTENT(IN) :: EQUATIONS_SET
5457  TYPE(field_interpolated_point_type), POINTER :: DEPENDENT_INTERPOLATED_POINT,MATERIALS_INTERPOLATED_POINT
5458  REAL(DP), INTENT(OUT) :: STRESS_TENSOR(:)
5459  REAL(DP), INTENT(IN) :: DZDNU(3,3) !Deformation gradient tensor at the gauss point
5460  REAL(DP), INTENT(IN) :: Jznu !Determinant of deformation gradient tensor (AZL)
5461  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER,GAUSS_POINT_NUMBER
5462  INTEGER(INTG), INTENT(OUT) :: ERR
5463  TYPE(varying_string), INTENT(OUT) :: ERROR
5464  !Local Variables
5465  INTEGER(INTG) :: PRESSURE_COMPONENT,component_idx,dof_idx
5466  REAL(DP) :: P
5467  REAL(DP) :: I1 !Invariants, if needed
5468  REAL(DP) :: TEMPTERM1,TEMPTERM2,VALUE !Temporary variables
5469  REAL(DP) :: ONETHIRD_TRACE
5470  TYPE(varying_string) :: LOCAL_ERROR
5471  TYPE(field_variable_type), POINTER :: FIELD_VARIABLE
5472  REAL(DP) :: MOD_DZDNU(3,3),MOD_DZDNUT(3,3),AZL(3,3)
5473  REAL(DP) :: B(6),E(6),DQ_DE(6)
5474  REAL(DP), POINTER :: C(:) !Parameters for constitutive laws
5475 
5476  enters("FINITE_ELASTICITY_GAUSS_STRESS_TENSOR",err,error,*999)
5477 
5478  NULLIFY(field_variable,c)
5479 
5480  !AZL = F'*F (deformed covariant or right cauchy deformation tensor, C)
5481  !AZU - deformed contravariant tensor; I3 = det(C)
5482 
5483  mod_dzdnu=dzdnu*jznu**(-1.0_dp/3.0_dp)
5484  CALL matrix_transpose(mod_dzdnu,mod_dzdnut,err,error,*999)
5485  CALL matrix_product(mod_dzdnut,mod_dzdnu,azl,err,error,*999)
5486  c=>materials_interpolated_point%VALUES(:,no_part_deriv)
5487 
5488  SELECT CASE(equations_set%specification(3))
5489  CASE(equations_set_mooney_rivlin_activecontraction_subtype,equations_set_mooney_rivlin_subtype)
5490  pressure_component=dependent_interpolated_point%INTERPOLATION_PARAMETERS%FIELD_VARIABLE%NUMBER_OF_COMPONENTS
5491  p=dependent_interpolated_point%VALUES(pressure_component,no_part_deriv)
5492  !Form of constitutive model is:
5493  !W=c1*(I1-3)+c2*(I2-3)+p/2*(I3-1)
5494 
5495  !Calculate isochoric fictitious 2nd Piola tensor (in Voigt form)
5496  i1=azl(1,1)+azl(2,2)+azl(3,3)
5497  tempterm1=-2.0_dp*c(2)
5498  tempterm2=2.0_dp*(c(1)+i1*c(2))
5499  stress_tensor(1)=tempterm1*azl(1,1)+tempterm2
5500  stress_tensor(2)=tempterm1*azl(2,2)+tempterm2
5501  stress_tensor(3)=tempterm1*azl(3,3)+tempterm2
5502  stress_tensor(4)=tempterm1*azl(2,1)
5503  stress_tensor(5)=tempterm1*azl(3,1)
5504  stress_tensor(6)=tempterm1*azl(3,2)
5505 
5506  IF(equations_set%specification(3)==equations_set_mooney_rivlin_activecontraction_subtype) THEN
5507  !add active contraction stress values
5508  !Be aware for modified DZDNU, should active contraction be added here? Normally should be okay as modified DZDNU and DZDNU
5509  !converge during the Newton iteration.
5510  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
5511  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
5512  dof_idx=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
5513  & gauss_points(gauss_point_number,element_number)
5514  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
5515  & field_values_set_type,dof_idx,VALUE,err,error,*999)
5516  stress_tensor(component_idx)=stress_tensor(component_idx)+VALUE
5517  ENDDO
5518  ENDIF
5519 
5520  !Do push-forward of 2nd Piola tensor.
5521  CALL finite_elasticity_push_stress_tensor(stress_tensor,mod_dzdnu,jznu,err,error,*999)
5522  !Calculate isochoric Cauchy tensor (the deviatoric part) and add the volumetric part (the hydrostatic pressure).
5523  onethird_trace=sum(stress_tensor(1:3))/3.0_dp
5524  stress_tensor(1:3)=stress_tensor(1:3)-onethird_trace+p
5525 
5526  CASE(equations_set_transverse_isotropic_guccione_subtype,equations_set_guccione_activecontraction_subtype)
5527  pressure_component=dependent_interpolated_point%INTERPOLATION_PARAMETERS%FIELD_VARIABLE%NUMBER_OF_COMPONENTS
5528  p=dependent_interpolated_point%VALUES(pressure_component,no_part_deriv)
5529  b=[2.0_dp*c(2),2.0_dp*c(3),2.0_dp*c(3),c(4),c(4),c(3)] ![2*b_f,2*b_t,2*b_t,b_ft,b_ft,b_t]
5530  e=[0.5_dp*(azl(1,1)-1.0_dp),0.5_dp*(azl(2,2)-1.0_dp),0.5_dp*(azl(3,3)-1.0_dp),azl(2,1),azl(3,1),azl(3,2)] !(Modified) strain tensor in Voigt form.
5531  dq_de=b*e
5532  tempterm1=0.5_dp*c(1)*exp(0.5_dp*dot_product(e,dq_de))
5533  ! Calculate isochoric fictitious 2nd Piola tensor (in Voigt form)
5534  stress_tensor=tempterm1*dq_de
5535  IF(equations_set%specification(3)==equations_set_guccione_activecontraction_subtype) THEN
5536  !add active contraction stress values
5537  !Be aware for modified DZDNU, should active contraction be added here? Normally should be okay as modified DZDNU and DZDNU
5538  !converge during the Newton iteration.
5539  CALL field_variable_get(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type,field_variable,err,error,*999)
5540  DO component_idx=1,field_variable%NUMBER_OF_COMPONENTS
5541  dof_idx=field_variable%COMPONENTS(component_idx)%PARAM_TO_DOF_MAP%GAUSS_POINT_PARAM2DOF_MAP% &
5542  & gauss_points(gauss_point_number,element_number)
5543  CALL field_parameter_set_get_local_dof(equations_set%INDEPENDENT%INDEPENDENT_FIELD,field_u_variable_type, &
5544  & field_values_set_type,dof_idx,VALUE,err,error,*999)
5545  stress_tensor(component_idx)=stress_tensor(component_idx)+VALUE
5546  ENDDO
5547  ENDIF
5548  ! Do push-forward of 2nd Piola tensor.
5549  CALL finite_elasticity_push_stress_tensor(stress_tensor,mod_dzdnu,jznu,err,error,*999)
5550  !Calculate isochoric Cauchy tensor (the deviatoric part) and add the volumetric part (the hydrostatic pressure).
5551  onethird_trace=sum(stress_tensor(1:3))/3.0_dp
5552  stress_tensor(1:3)=stress_tensor(1:3)-onethird_trace+p
5553  CASE DEFAULT
5554  local_error="The third equations set specification of "// &
5555  & trim(number_to_vstring(equations_set%specification(3),"*",err,error))// &
5556  & " is not valid for a finite elasticity type of an elasticity equation set."
5557  CALL flagerror(local_error,err,error,*999)
5558  END SELECT
5559 
5560  exits("FINITE_ELASTICITY_GAUSS_STRESS_TENSOR")
5561  RETURN
5562  999 errorsexits("FINITE_ELASTICITY_GAUSS_STRESS_TENSOR",err,error)
5563  RETURN 1
5564  END SUBROUTINE finite_elasticity_gauss_stress_tensor
5565 
5566  !
5567  !================================================================================================================================
5568  !
5569 
5570  ! calculates the current active contraction component using the independent field
5571  ! Uses a hardcoded tension transient based on GPB+NHS with length-dependence for now
5572  SUBROUTINE finiteelasticity_piolaaddactivecontraction(INDEPENDENT_FIELD,MATERIALS_FIELD,PIOLA_FF,E_FF,&
5573  & element_number,gauss_point_number,err,error,*)
5574  !Argument variables
5575  TYPE(field_type), POINTER, INTENT(IN) :: INDEPENDENT_FIELD, MATERIALS_FIELD
5576  REAL(DP), INTENT(INOUT) :: PIOLA_FF
5577  REAL(DP), INTENT(IN) :: E_FF
5578  INTEGER(INTG), INTENT(IN) :: ELEMENT_NUMBER,GAUSS_POINT_NUMBER
5579  INTEGER(INTG), INTENT(OUT) :: ERR
5580  TYPE(varying_string), INTENT(OUT) :: ERROR
5581 
5582  INTEGER(INTG) :: I
5583  REAL(DP) :: S, LAMBDA, ISO_TA, TA, ACTIVTIME, TIME, DT
5584  REAL(DP), DIMENSION(1:4) :: QL
5585 
5586  REAL(DP), PARAMETER :: PERIOD = 1000 ! 1 Hz
5587  REAL(DP), PARAMETER, DIMENSION(28) :: TIMES = [ 0, 20, 30, 40, 60, 80, 100, 120, 150, 160, 170, 175, 180, 190, 200,&
5588  & 225, 250, 300,