OpenCMISS-Iron Internal API Documentation
problem_routines.f90
Go to the documentation of this file.
1 
43 
45 MODULE problem_routines
46 
47  USE base_routines
55  USE field_routines
60  USE input_output
62  USE interface_conditions_routines
63  USE interface_routines
65  USE kinds
69  USE solver_routines
71  USE strings
72  USE timer
73  USE types
74 
75 #include "macros.h"
76 
77  IMPLICIT NONE
78 
79  PRIVATE
80 
81  !Module parameters
82 
83  !Module types
84 
85  !Module variables
86 
87  TYPE(problems_type), TARGET :: problems
88 
89  !Interfaces
90 
91  INTERFACE problem_cellml_equations_get
92  MODULE PROCEDURE problem_cellml_equations_get_0
93  MODULE PROCEDURE problem_cellml_equations_get_1
94  END INTERFACE !PROBLEM_CELLML_EQUATIONS_GET
95 
96  INTERFACE problem_control_loop_get
97  MODULE PROCEDURE problem_control_loop_get_0
98  MODULE PROCEDURE problem_control_loop_get_1
99  END INTERFACE !PROBLEM_CONTROL_LOOP_GET
100 
101  INTERFACE problem_solver_equations_get
102  MODULE PROCEDURE problem_solver_equations_get_0
103  MODULE PROCEDURE problem_solver_equations_get_1
104  END INTERFACE !PROBLEM_SOLVER_EQUATIONS_GET
105 
106  INTERFACE problem_solver_get
107  MODULE PROCEDURE problem_solver_get_0
108  MODULE PROCEDURE problem_solver_get_1
109  END INTERFACE !PROBLEM_SOLVER_GET
110 
111  PUBLIC problems_initialise,problems_finalise
112 
113  PUBLIC problem_cellml_equations_create_start,problem_cellml_equations_create_finish
114 
115  PUBLIC problem_cellml_equations_get
116 
117  PUBLIC problem_create_start,problem_create_finish,problem_destroy
118 
119  PUBLIC problem_specificationget,problem_specificationsizeget
120 
121  PUBLIC problem_control_loop_create_start,problem_control_loop_create_finish
122 
123  PUBLIC problem_control_loop_destroy
124 
125  PUBLIC problem_control_loop_get
126 
127  PUBLIC problem_solverdaecellmlrhsevaluate
128 
129  PUBLIC problem_solverequationsboundaryconditionsanalytic
130 
131  PUBLIC problem_solver_equations_create_start,problem_solver_equations_create_finish
132 
133  PUBLIC problem_solver_equations_destroy
134 
135  PUBLIC problem_solver_equations_get
136 
137  PUBLIC problem_solver_jacobian_evaluate,problem_solver_residual_evaluate
138 
139  PUBLIC problem_solver_get
140 
141  PUBLIC problem_solvernonlinearmonitor
142 
143  PUBLIC problem_solve
144 
145  PUBLIC problem_solvers_create_start,problem_solvers_create_finish
146 
147  PUBLIC problem_solvers_destroy
148 
149  PUBLIC problem_user_number_find
150 
151 CONTAINS
152 
153  !
154  !================================================================================================================================
155  !
156 
158  SUBROUTINE problem_cellml_equations_create_finish(PROBLEM,ERR,ERROR,*)
159 
160  !Argument variables
161  TYPE(problem_type), POINTER :: problem
162  INTEGER(INTG), INTENT(OUT) :: err
163  TYPE(varying_string), INTENT(OUT) :: error
164  !Local Variables
165  TYPE(problem_setup_type) :: problem_setup_info
166 
167  enters("PROBLEM_CELLML_EQUATIONS_CREATE_FINISH",err,error,*999)
168 
169  IF(ASSOCIATED(problem)) THEN
170  !Initialise the problem setup information
171  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
172  problem_setup_info%SETUP_TYPE=problem_setup_cellml_equations_type
173  problem_setup_info%ACTION_TYPE=problem_setup_finish_action
174  !Finish problem specific startup
175  CALL problem_setup(problem,problem_setup_info,err,error,*999)
176  !Finalise the problem setup information
177  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
178  ELSE
179  CALL flagerror("Problem is not associated.",err,error,*999)
180  ENDIF
181 
182  exits("PROBLEM_CELLML_EQUATIONS_CREATE_FINISH")
183  RETURN
184 999 errorsexits("PROBLEM_CELLML_EQUATIONS_CREATE_FINISH",err,error)
185  RETURN 1
186  END SUBROUTINE problem_cellml_equations_create_finish
187 
188  !
189  !================================================================================================================================
190  !
191 
193  SUBROUTINE problem_cellml_equations_create_start(PROBLEM,ERR,ERROR,*)
194 
195  !Argument variablesg
196  TYPE(problem_type), POINTER :: problem
197  INTEGER(INTG), INTENT(OUT) :: err
198  TYPE(varying_string), INTENT(OUT) :: error
199  !Local Variables
200  TYPE(problem_setup_type) :: problem_setup_info
201 
202  enters("PROBLEM_CELLML_EQUATIONS_CREATE_START",err,error,*999)
203 
204  IF(ASSOCIATED(problem)) THEN
205  !Initialise the problem setup information
206  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
207  problem_setup_info%SETUP_TYPE=problem_setup_cellml_equations_type
208  problem_setup_info%ACTION_TYPE=problem_setup_start_action
209  !Start the problem specific control setup
210  CALL problem_setup(problem,problem_setup_info,err,error,*999)
211  !Finalise the problem setup information
212  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
213  ELSE
214  CALL flagerror("Problem is not associated.",err,error,*999)
215  ENDIF
216 
217  exits("PROBLEM_CELLML_EQUATIONS_CREATE_START")
218  RETURN
219 999 errorsexits("PROBLEM_CELLML_EQUATIONS_CREATE_START",err,error)
220  RETURN 1
221  END SUBROUTINE problem_cellml_equations_create_start
222 
223  !
224  !================================================================================================================================
225  !
226 
228  SUBROUTINE problem_cellml_equations_get_0(PROBLEM,CONTROL_LOOP_IDENTIFIER,SOLVER_INDEX,CELLML_EQUATIONS,ERR,ERROR,*)
229 
230  !Argument variables
231  TYPE(problem_type), POINTER :: problem
232  INTEGER(INTG), INTENT(IN) :: control_loop_identifier
233  INTEGER(INTG), INTENT(IN) :: solver_index
234  TYPE(cellml_equations_type), POINTER :: cellml_equations
235  INTEGER(INTG), INTENT(OUT) :: err
236  TYPE(varying_string), INTENT(OUT) :: error
237  !Local Variables
238 
239  enters("PROBLEM_CELLML_EQUATIONS_GET_0",err,error,*999)
240 
241  CALL problem_cellml_equations_get_1(problem,[control_loop_identifier],solver_index,cellml_equations,err,error,*999)
242 
243  exits("PROBLEM_CELLML_EQUATIONS_GET_0")
244  RETURN
245 999 errorsexits("PROBLEM_CELLML_EQUATIONS_GET_0",err,error)
246  RETURN 1
247  END SUBROUTINE problem_cellml_equations_get_0
248 
249  !
250  !================================================================================================================================
251  !
252 
254  SUBROUTINE problem_cellml_equations_get_1(PROBLEM,CONTROL_LOOP_IDENTIFIER,SOLVER_INDEX,CELLML_EQUATIONS,ERR,ERROR,*)
255 
256  !Argument variables
257  TYPE(problem_type), POINTER :: problem
258  INTEGER(INTG), INTENT(IN) :: control_loop_identifier(:)
259  INTEGER(INTG), INTENT(IN) :: solver_index
260  TYPE(cellml_equations_type), POINTER :: cellml_equations
261  INTEGER(INTG), INTENT(OUT) :: err
262  TYPE(varying_string), INTENT(OUT) :: error
263  !Local Variables
264  TYPE(control_loop_type), POINTER :: control_loop,control_loop_root
265  TYPE(solver_type), POINTER :: solver
266  TYPE(solvers_type), POINTER :: solvers
267  TYPE(varying_string) :: local_error
268 
269  enters("PROBLEM_CELLML_EQUATIONS_GET_1",err,error,*999)
270 
271  IF(ASSOCIATED(problem)) THEN
272  IF(ASSOCIATED(cellml_equations)) THEN
273  CALL flagerror("The CellML equations is already associated.",err,error,*999)
274  ELSE
275  NULLIFY(cellml_equations)
276  control_loop_root=>problem%CONTROL_LOOP
277  IF(ASSOCIATED(control_loop_root)) THEN
278  NULLIFY(control_loop)
279  CALL control_loop_get(control_loop_root,control_loop_identifier,control_loop,err,error,*999)
280  solvers=>control_loop%SOLVERS
281  IF(ASSOCIATED(solvers)) THEN
282  IF(solver_index>0.AND.solver_index<=solvers%NUMBER_OF_SOLVERS) THEN
283  solver=>solvers%SOLVERS(solver_index)%PTR
284  IF(ASSOCIATED(solver)) THEN
285  cellml_equations=>solver%CELLML_EQUATIONS
286  IF(.NOT.ASSOCIATED(cellml_equations)) CALL flagerror("CellML equations is not associated.",err,error,*999)
287  ELSE
288  CALL flagerror("Solver is not associated.",err,error,*999)
289  ENDIF
290  ELSE
291  local_error="The specified solver index of "//trim(number_to_vstring(solver_index,"*",err,error))// &
292  & " is invalid. The index must be > 0 and <= "// &
293  & trim(number_to_vstring(solvers%NUMBER_OF_SOLVERS,"*",err,error))//"."
294  CALL flagerror(local_error,err,error,*999)
295  ENDIF
296  ELSE
297  CALL flagerror("Solvers is not associated.",err,error,*999)
298  ENDIF
299  ELSE
300  CALL flagerror("Problem control loop is not associated.",err,error,*999)
301  ENDIF
302  ENDIF
303  ELSE
304  CALL flagerror("Problem is not associated.",err,error,*999)
305  ENDIF
306 
307  exits("PROBLEM_CELLML_EQUATIONS_GET_1")
308  RETURN
309 999 errorsexits("PROBLEM_CELLML_EQUATIONS_GET_1",err,error)
310  RETURN 1
311  END SUBROUTINE problem_cellml_equations_get_1
312 
313  !
314  !================================================================================================================================
315  !
316 
318  SUBROUTINE problem_cellml_equations_solve(CELLML_EQUATIONS,ERR,ERROR,*)
319 
320  !Argument variables
321  TYPE(cellml_equations_type), POINTER :: cellml_equations
322  INTEGER(INTG), INTENT(OUT) :: err
323  TYPE(varying_string), INTENT(OUT) :: error
324  !Local Variables
325  TYPE(solver_type), POINTER :: solver
326 
327  enters("PROBLEM_CELLML_EQUATIONS_SOLVE",err,error,*999)
328 
329  IF(ASSOCIATED(cellml_equations)) THEN
330  IF(cellml_equations%CELLML_EQUATIONS_FINISHED) THEN
331  solver=>cellml_equations%SOLVER
332  IF(ASSOCIATED(solver)) THEN
333 
334  CALL solver_solve(solver,err,error,*999)
335 
336  ELSE
337  CALL flagerror("CellML equations solver is not associated.",err,error,*999)
338  ENDIF
339  ELSE
340  CALL flagerror("CellML equations have not been finished.",err,error,*999)
341  ENDIF
342  ELSE
343  CALL flagerror("CellML equations is not associated.",err,error,*999)
344  ENDIF
345 
346  exits("PROBLEM_CELLML_EQUATIONS_SOLVE")
347  RETURN
348 999 errorsexits("PROBLEM_CELLML_EQUATIONS_SOLVE",err,error)
349  RETURN 1
350 
351  END SUBROUTINE problem_cellml_equations_solve
352 
353  !
354  !================================================================================================================================
355  !
356 
358  SUBROUTINE problem_solverdaecellmlrhsevaluate(cellML,time,dofIdx,stateData,rateData,err,error,*)
359 
360  !Argument variables
361  TYPE(cellml_type), POINTER :: cellml
362  REAL(DP), INTENT(IN) :: time
363  INTEGER(INTG), INTENT(IN) :: dofidx
364  REAL(DP), POINTER :: statedata(:)
365  REAL(DP), POINTER :: ratedata(:)
366  INTEGER(INTG), INTENT(OUT) :: err
367  TYPE(varying_string), INTENT(OUT) :: error
368  !Local Variables
369  INTEGER(INTG) :: dofordertype,intermediatedataoffset,maxnumberofintermediates,maxnumberofparameters,maxnumberofstates, &
370  modelidx,parameterdataoffset
371  INTEGER(INTG), POINTER :: modelsdata(:)
372  REAL(DP), POINTER :: intermediatedata(:),parameterdata(:)
373  TYPE(cellml_model_type), POINTER :: model
374  TYPE(field_type), POINTER :: intermediatefield,modelsfield,parametersfield
375  TYPE(field_variable_type), POINTER :: modelsvariable
376 
377  enters("Problem_SolverDAECellMLRHSEvaluate",err,error,*999)
378 
379  IF(ASSOCIATED(cellml)) THEN
380  maxnumberofstates=cellml%MAXIMUM_NUMBER_OF_STATE
381  maxnumberofintermediates=cellml%MAXIMUM_NUMBER_OF_INTERMEDIATE
382  maxnumberofparameters=cellml%MAXIMUM_NUMBER_OF_PARAMETERS
383  !Make sure CellML fields have been updated to the current value of any mapped fields
384  IF(ASSOCIATED(cellml%MODELS_FIELD)) THEN
385  modelsfield=>cellml%MODELS_FIELD%MODELS_FIELD
386  IF(ASSOCIATED(modelsfield)) THEN
387  NULLIFY(modelsvariable)
388  CALL field_variableget(modelsfield,field_u_variable_type,modelsvariable,err,error,*999)
389  CALL field_dofordertypeget(modelsfield,field_u_variable_type,dofordertype,err,error,*999)
390  CALL field_parametersetdataget(modelsfield,field_u_variable_type,field_values_set_type,modelsdata,err,error,*999)
391  modelidx=modelsdata(dofidx)
392  model=>cellml%models(modelidx)%ptr
393  IF(ASSOCIATED(model)) THEN
394  IF(dofordertype==field_separated_component_dof_order) THEN
395  parameterdataoffset=modelsvariable%TOTAL_NUMBER_OF_DOFS
396  intermediatedataoffset=modelsvariable%TOTAL_NUMBER_OF_DOFS
397  ELSE
398  parameterdataoffset=maxnumberofparameters
399  intermediatedataoffset=maxnumberofintermediates
400  ENDIF
401  NULLIFY(parameterdata)
402  !Get the parameters information if this environment has any.
403  IF(ASSOCIATED(cellml%PARAMETERS_FIELD)) THEN
404  parametersfield=>cellml%PARAMETERS_FIELD%PARAMETERS_FIELD
405  IF(ASSOCIATED(parametersfield)) THEN
406  CALL field_parametersetdataget(parametersfield,field_u_variable_type,field_values_set_type,parameterdata, &
407  & err,error,*999)
408  ENDIF
409  ENDIF
410  !Get the intermediate information if this environment has any.
411  NULLIFY(intermediatedata)
412  IF(ASSOCIATED(cellml%INTERMEDIATE_FIELD)) THEN
413  intermediatefield=>cellml%INTERMEDIATE_FIELD%INTERMEDIATE_FIELD
414  IF(ASSOCIATED(intermediatefield)) THEN
415  CALL field_parametersetdataget(intermediatefield,field_u_variable_type,field_values_set_type,intermediatedata, &
416  & err,error,*999)
417  ENDIF
418  ENDif!associated intermediate
419 
420  !Evaluate the CellML RHS
421  CALL solver_daecellmlrhsevaluate(model,time,1,1,statedata,dofidx,parameterdataoffset,parameterdata,dofidx, &
422  intermediatedataoffset,intermediatedata,1,1,ratedata,err,error,*999)
423 
424  ELSE
425  CALL flagerror("Model is not associated.",err,error,*999)
426  ENDIF
427  ELSE
428  CALL flagerror("Models field not associated.",err,error,*999)
429  ENDIF
430  ELSE
431  CALL flagerror("CellML models field is not associated.",err,error,*999)
432  ENDIF
433  ELSE
434  CALL flagerror("CellML is not associated.",err,error,*999)
435  ENDIF
436 
437  exits("Problem_SolverDAECellMLRHSEvaluate")
438  RETURN
439 999 errorsexits("Problem_SolverDAECellMLRHSEvaluate",err,error)
440  RETURN 1
441 
442  END SUBROUTINE problem_solverdaecellmlrhsevaluate
443 
444  !
445  !================================================================================================================================
446  !
447 
449  RECURSIVE SUBROUTINE problem_control_loop_solve(CONTROL_LOOP,ERR,ERROR,*)
450 
451  !Argument variables
452  TYPE(control_loop_type), POINTER :: control_loop
453  INTEGER(INTG), INTENT(OUT) :: err
454  TYPE(varying_string), INTENT(OUT) :: error
455  !Local Variables
456  INTEGER(INTG) :: iteration_idx,loop_idx,solver_idx
457  TYPE(control_loop_type), POINTER :: control_loop2
458  TYPE(control_loop_fixed_type), POINTER :: fixed_loop
459  TYPE(control_loop_simple_type), POINTER :: simple_loop
460  TYPE(control_loop_time_type), POINTER :: time_loop
461  TYPE(control_loop_while_type), POINTER :: while_loop
462  TYPE(control_loop_load_increment_type), POINTER :: load_increment_loop
463  TYPE(solver_type), POINTER :: solver
464  TYPE(solvers_type), POINTER :: solvers
465  TYPE(varying_string) :: local_error
466 
467  enters("PROBLEM_CONTROL_LOOP_SOLVE",err,error,*999)
468 
469  IF(ASSOCIATED(control_loop)) THEN
470  IF(control_loop%CONTROL_LOOP_FINISHED) THEN
471  !Solve this control loop
472  IF(control_loop%OUTPUT_TYPE>=control_loop_progress_output) THEN
473  CALL write_string(general_output_type,"",err,error,*999)
474  CALL write_string_value(general_output_type,"Control loop: ",control_loop%LABEL,err,error,*999)
475  CALL write_string_value(general_output_type," Control loop level = ",control_loop%CONTROL_LOOP_LEVEL,err,error,*999)
476  CALL write_string_value(general_output_type," Sub loop index = ",control_loop%SUB_LOOP_INDEX,err,error,*999)
477  ENDIF
478  SELECT CASE(control_loop%LOOP_TYPE)
479  CASE(problem_control_simple_type)
480  simple_loop=>control_loop%SIMPLE_LOOP
481  IF(ASSOCIATED(simple_loop)) THEN
482  IF(control_loop%OUTPUT_TYPE>=control_loop_progress_output) THEN
483  CALL write_string(general_output_type,"",err,error,*999)
484  CALL write_string(general_output_type,"Simple control loop: ",err,error,*999)
485  ENDIF
486  CALL problem_control_loop_pre_loop(control_loop,err,error,*999)
487  IF(control_loop%NUMBER_OF_SUB_LOOPS==0) THEN
488  !If there are no sub loops then solve.
489  solvers=>control_loop%SOLVERS
490  IF(ASSOCIATED(solvers)) THEN
491  DO solver_idx=1,solvers%NUMBER_OF_SOLVERS
492  solver=>solvers%SOLVERS(solver_idx)%PTR
493 
494  CALL problem_solver_solve(solver,err,error,*999)
495 
496  ENDDO !solver_idx
497  ELSE
498  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
499  ENDIF
500  ELSE
501  !If there are sub loops the recursively solve those control loops
502  DO loop_idx=1,control_loop%NUMBER_OF_SUB_LOOPS
503  control_loop2=>control_loop%SUB_LOOPS(loop_idx)%PTR
504  CALL problem_control_loop_solve(control_loop2,err,error,*999)
505  ENDDO !loop_idx
506  ENDIF
507  CALL problem_control_loop_post_loop(control_loop,err,error,*999)
508  ELSE
509  CALL flagerror("Control loop simple loop is not associated.",err,error,*999)
510  ENDIF
511  CASE(problem_control_fixed_loop_type)
512  fixed_loop=>control_loop%FIXED_LOOP
513  IF(ASSOCIATED(fixed_loop)) THEN
514  DO iteration_idx=fixed_loop%START_ITERATION,fixed_loop%STOP_ITERATION,fixed_loop%ITERATION_INCREMENT
515  IF(control_loop%OUTPUT_TYPE>=control_loop_progress_output) THEN
516  CALL write_string(general_output_type,"",err,error,*999)
517  CALL write_string_value(general_output_type,"Fixed control loop iteration: ",iteration_idx,err,error,*999)
518  ENDIF
519  fixed_loop%ITERATION_NUMBER=iteration_idx
520  CALL problem_control_loop_pre_loop(control_loop,err,error,*999)
521  IF(control_loop%NUMBER_OF_SUB_LOOPS==0) THEN
522  !If there are no sub loops then solve
523  solvers=>control_loop%SOLVERS
524  IF(ASSOCIATED(solvers)) THEN
525  DO solver_idx=1,solvers%NUMBER_OF_SOLVERS
526  solver=>solvers%SOLVERS(solver_idx)%PTR
527 
528  CALL problem_solver_solve(solver,err,error,*999)
529 
530  ENDDO !solver_idx
531  ELSE
532  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
533  ENDIF
534  ELSE
535  !If there are sub loops the recursively solve those control loops
536  DO loop_idx=1,control_loop%NUMBER_OF_SUB_LOOPS
537  control_loop2=>control_loop%SUB_LOOPS(loop_idx)%PTR
538  CALL problem_control_loop_solve(control_loop2,err,error,*999)
539  ENDDO !loop_idx
540  ENDIF
541  CALL problem_control_loop_post_loop(control_loop,err,error,*999)
542  ENDDO !iteration_idx
543  ELSE
544  CALL flagerror("Control loop fixed loop is not associated.",err,error,*999)
545  ENDIF
546  CASE(problem_control_time_loop_type)
547  time_loop=>control_loop%TIME_LOOP
548  IF(ASSOCIATED(time_loop)) THEN
549  !Set the current time to be the start time. Solvers should use the first time step to do any initialisation.
550  time_loop%CURRENT_TIME=time_loop%START_TIME
551 
552  !Precompute the number of iterations from total time span and time increment if it was not specified explicitely
553  IF (time_loop%NUMBER_OF_ITERATIONS==0) THEN
554  time_loop%NUMBER_OF_ITERATIONS=ceiling((time_loop%STOP_TIME-time_loop%START_TIME)/time_loop%TIME_INCREMENT)
555  !If number of iterations was specified but does not match TIME_INCREMENT, e.g. TIME_INCREMENT is still at the default value, compute correct TIME_INCREMENT
556  ELSEIF (ceiling((time_loop%STOP_TIME-time_loop%START_TIME)/time_loop%TIME_INCREMENT) &
557  & /= time_loop%NUMBER_OF_ITERATIONS) THEN
558  time_loop%TIME_INCREMENT = (time_loop%STOP_TIME-time_loop%START_TIME)/time_loop%NUMBER_OF_ITERATIONS
559  ENDIF
560 
561  time_loop%ITERATION_NUMBER=0
562  DO WHILE(time_loop%ITERATION_NUMBER<time_loop%NUMBER_OF_ITERATIONS)
563  IF(control_loop%OUTPUT_TYPE>=control_loop_progress_output) THEN
564  CALL write_string(general_output_type,"",err,error,*999)
565  CALL write_string_value(general_output_type,"Time control loop iteration: ",time_loop%ITERATION_NUMBER, &
566  & err,error,*999)
567  CALL write_string_value(general_output_type," Total number of iterations: ",time_loop%NUMBER_OF_ITERATIONS, &
568  & err,error,*999)
569  CALL write_string_value(general_output_type," Current time = ",time_loop%CURRENT_TIME, &
570  & err,error,*999)
571  CALL write_string_value(general_output_type," Stop time = ",time_loop%STOP_TIME, &
572  & err,error,*999)
573  CALL write_string_value(general_output_type," Time increment = ",time_loop%TIME_INCREMENT, &
574  & err,error,*999)
575  ENDIF
576  !Perform any pre-loop actions.
577  CALL problem_control_loop_pre_loop(control_loop,err,error,*999)
578  IF(control_loop%NUMBER_OF_SUB_LOOPS==0) THEN
579  !If there are no sub loops then solve.
580  solvers=>control_loop%SOLVERS
581  IF(ASSOCIATED(solvers)) THEN
582  DO solver_idx=1,solvers%NUMBER_OF_SOLVERS
583  solver=>solvers%SOLVERS(solver_idx)%PTR
584 
585  CALL problem_solver_solve(solver,err,error,*999)
586 
587  ENDDO !solver_idx
588  ELSE
589  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
590  ENDIF
591  ELSE
592  !If there are sub loops the recursively solve those control loops
593  DO loop_idx=1,control_loop%NUMBER_OF_SUB_LOOPS
594  control_loop2=>control_loop%SUB_LOOPS(loop_idx)%PTR
595  CALL problem_control_loop_solve(control_loop2,err,error,*999)
596  ENDDO !loop_idx
597  ENDIF
598  !Perform any post loop actions.
599  CALL problem_control_loop_post_loop(control_loop,err,error,*999)
600  !Increment loop counter and time
601  time_loop%ITERATION_NUMBER=time_loop%ITERATION_NUMBER+1
602  time_loop%GLOBAL_ITERATION_NUMBER=time_loop%GLOBAL_ITERATION_NUMBER+1
603  time_loop%CURRENT_TIME=time_loop%CURRENT_TIME+time_loop%TIME_INCREMENT
604  ENDDO !time loop
605  ELSE
606  CALL flagerror("Control loop time loop is not associated.",err,error,*999)
607  ENDIF
608  CASE(problem_control_while_loop_type)
609  while_loop=>control_loop%WHILE_LOOP
610  IF(ASSOCIATED(while_loop)) THEN
611  while_loop%ITERATION_NUMBER=0
612  while_loop%CONTINUE_LOOP=.true.
613  DO WHILE(while_loop%CONTINUE_LOOP.AND.while_loop%ITERATION_NUMBER &
614  & <while_loop%MAXIMUM_NUMBER_OF_ITERATIONS)
615  while_loop%ITERATION_NUMBER=while_loop%ITERATION_NUMBER+1
616  IF(control_loop%OUTPUT_TYPE>=control_loop_progress_output) THEN
617  CALL write_string(general_output_type,"",err,error,*999)
618  CALL write_string_value(general_output_type,"While control loop iteration: ",while_loop%ITERATION_NUMBER, &
619  & err,error,*999)
620  CALL write_string_value(general_output_type," Maximum number of iterations = ", &
621  & while_loop%MAXIMUM_NUMBER_OF_ITERATIONS,err,error,*999)
622  ENDIF
623  CALL problem_control_loop_pre_loop(control_loop,err,error,*999)
624  IF(control_loop%NUMBER_OF_SUB_LOOPS==0) THEN
625  !If there are no sub loops then solve
626  solvers=>control_loop%SOLVERS
627  IF(ASSOCIATED(solvers)) THEN
628  DO solver_idx=1,solvers%NUMBER_OF_SOLVERS
629  solver=>solvers%SOLVERS(solver_idx)%PTR
630  IF(ASSOCIATED(solver)) THEN
631  IF(ASSOCIATED(solver%SOLVER_EQUATIONS)) THEN
632  CALL problem_solver_load_increment_apply(solver%SOLVER_EQUATIONS,1, &
633  & 1,err,error,*999)
634  ENDIF
635  CALL problem_solver_solve(solver,err,error,*999)
636  ELSE
637  CALL flagerror("Solver is not associated.",err,error,*999)
638  ENDIF
639  ENDDO !solver_idx
640  ELSE
641  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
642  ENDIF
643  ELSE
644  !If there are sub loops the recursively solve those control loops
645  DO loop_idx=1,control_loop%NUMBER_OF_SUB_LOOPS
646  control_loop2=>control_loop%SUB_LOOPS(loop_idx)%PTR
647  CALL problem_control_loop_solve(control_loop2,err,error,*999)
648  ENDDO !loop_idx
649  ENDIF
650  CALL problem_control_loop_post_loop(control_loop,err,error,*999)
651  ENDDO !while loop
652  ELSE
653  CALL flagerror("Control loop while loop is not associated.",err,error,*999)
654  ENDIF
655  CASE(problem_control_load_increment_loop_type)
656  load_increment_loop=>control_loop%LOAD_INCREMENT_LOOP
657  IF(ASSOCIATED(load_increment_loop)) THEN
658  load_increment_loop%ITERATION_NUMBER=0
659  IF (load_increment_loop%MAXIMUM_NUMBER_OF_ITERATIONS<1) THEN
660  ! automatic stepping
661  CALL flagerror("Automatic load incrementing is not implemented yet.",err,error,*999)
662  ELSE
663  ! fixed number of steps
664  DO WHILE(load_increment_loop%ITERATION_NUMBER<load_increment_loop%MAXIMUM_NUMBER_OF_ITERATIONS)
665  load_increment_loop%ITERATION_NUMBER=load_increment_loop%ITERATION_NUMBER+1
666  IF(control_loop%OUTPUT_TYPE>=control_loop_progress_output) THEN
667  CALL write_string(general_output_type,"",err,error,*999)
668  CALL write_string_value(general_output_type,"Load increment control loop iteration: ", &
669  & load_increment_loop%ITERATION_NUMBER,err,error,*999)
670  CALL write_string_value(general_output_type," Maximum number of iterations = ", &
671  & load_increment_loop%MAXIMUM_NUMBER_OF_ITERATIONS,err,error,*999)
672  ENDIF
673  CALL problem_control_loop_pre_loop(control_loop,err,error,*999)
674  IF(control_loop%NUMBER_OF_SUB_LOOPS==0) THEN
675  !If there are no sub loops then solve
676  solvers=>control_loop%SOLVERS
677  IF(ASSOCIATED(solvers)) THEN
678  DO solver_idx=1,solvers%NUMBER_OF_SOLVERS
679  solver=>solvers%SOLVERS(solver_idx)%PTR
680  IF(ASSOCIATED(solver)) THEN
681  IF(ASSOCIATED(solver%SOLVER_EQUATIONS)) THEN
682  !Apply incremented boundary conditions here =>
683  CALL problem_solver_load_increment_apply(solver%SOLVER_EQUATIONS,load_increment_loop%ITERATION_NUMBER, &
684  & load_increment_loop%MAXIMUM_NUMBER_OF_ITERATIONS,err,error,*999)
685  ENDIF
686  CALL problem_solver_solve(solver,err,error,*999)
687  ELSE
688  CALL flagerror("Solver is not associated.",err,error,*999)
689  ENDIF
690  ENDDO !solver_idx
691  ELSE
692  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
693  ENDIF
694  ELSE
695  !If there are sub loops the recursively solve those control loops
696  DO loop_idx=1,control_loop%NUMBER_OF_SUB_LOOPS
697  control_loop2=>control_loop%SUB_LOOPS(loop_idx)%PTR
698  CALL problem_control_loop_solve(control_loop2,err,error,*999)
699  ENDDO !loop_idx
700  ENDIF
701  CALL problem_control_loop_post_loop(control_loop,err,error,*999)
702  ENDDO !while loop
703  ENDIF
704  ELSE
705  CALL flagerror("Control loop while loop is not associated.",err,error,*999)
706  ENDIF
707  CASE DEFAULT
708  local_error="The control loop loop type of "//trim(number_to_vstring(control_loop%LOOP_TYPE,"*",err,error))// &
709  & " is invalid."
710  CALL flagerror(local_error,err,error,*999)
711  END SELECT
712  ELSE
713  CALL flagerror("Control loop has not been finished.",err,error,*999)
714  ENDIF
715  ELSE
716  CALL flagerror("Control loop is not associated",err,error,*999)
717  ENDIF
718 
719  exits("PROBLEM_CONTROL_LOOP_SOLVE")
720  RETURN
721 999 errorsexits("PROBLEM_CONTROL_LOOP_SOLVE",err,error)
722  RETURN 1
723  END SUBROUTINE problem_control_loop_solve
724 
725  !
726  !================================================================================================================================
727  !
728 
730  SUBROUTINE problem_create_finish(PROBLEM,ERR,ERROR,*)
731 
732  !Argument variables
733  TYPE(problem_type), POINTER :: problem
734  INTEGER(INTG), INTENT(OUT) :: err
735  TYPE(varying_string), INTENT(OUT) :: error
736  !Local Variables
737  INTEGER(INTG) :: problem_idx
738  TYPE(problem_setup_type) :: problem_setup_info
739 
740  enters("PROBLEM_CREATE_FINISH",err,error,*999)
741 
742  IF(ASSOCIATED(problem)) THEN
743  !Initialise the problem setup information
744  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
745  problem_setup_info%SETUP_TYPE=problem_setup_initial_type
746  problem_setup_info%ACTION_TYPE=problem_setup_finish_action
747  !Finish the problem specific setup
748  CALL problem_setup(problem,problem_setup_info,err,error,*999)
749  !Finalise the problem setup information
750  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
751  !Finish the problem creation
752  problem%PROBLEM_FINISHED=.true.
753  ELSE
754  CALL flagerror("Problem is not associated.",err,error,*999)
755  ENDIF
756 
757  IF(diagnostics1) THEN
758  CALL write_string_value(diagnostic_output_type,"Number of problems = ",problems%NUMBER_OF_PROBLEMS,err,error,*999)
759  DO problem_idx=1,problems%NUMBER_OF_PROBLEMS
760  CALL write_string_value(diagnostic_output_type,"Problem number = ",problem_idx,err,error,*999)
761  CALL write_string_value(diagnostic_output_type," User number = ",problems%PROBLEMS(problem_idx)%PTR%USER_NUMBER, &
762  & err,error,*999)
763  CALL write_string_value(diagnostic_output_type," Global number = ",problems%PROBLEMS(problem_idx)%PTR%GLOBAL_NUMBER, &
764  & err,error,*999)
765  CALL write_string_vector(diagnostic_output_type,1,1,SIZE(problems%PROBLEMS(problem_idx)%PTR%SPECIFICATION,1),8,8, &
766  & problems%PROBLEMS(problem_idx)%PTR%SPECIFICATION,'(" Problem specification = ",8(X,I3))','(16X,8(X,I3))', &
767  & err,error,*999)
768  ENDDO !problem_idx
769  ENDIF
770 
771  exits("PROBLEM_CREATE_FINISH")
772  RETURN
773 999 errorsexits("PROBLEM_CREATE_FINISH",err,error)
774  RETURN 1
775 
776  END SUBROUTINE problem_create_finish
777 
778  !
779  !================================================================================================================================
780  !
781 
783  SUBROUTINE problem_create_start(USER_NUMBER,PROBLEM_SPECIFICATION,PROBLEM,ERR,ERROR,*)
784 
785  !Argument variables
786  INTEGER(INTG), INTENT(IN) :: user_number
787  INTEGER(INTG), INTENT(IN) :: problem_specification(:)
788  TYPE(problem_type), POINTER :: problem
789  INTEGER(INTG), INTENT(OUT) :: err
790  TYPE(varying_string), INTENT(OUT) :: error
791  !Local Variables
792  INTEGER(INTG) :: problem_idx
793  TYPE(problem_type), POINTER :: new_problem
794  TYPE(problem_ptr_type), POINTER :: new_problems(:)
795  TYPE(problem_setup_type) :: problem_setup_info
796  TYPE(varying_string) :: local_error
797 
798  NULLIFY(new_problem)
799  NULLIFY(new_problems)
800 
801  enters("PROBLEM_CREATE_START",err,error,*999)
802 
803  IF(ASSOCIATED(problem)) THEN
804  CALL flagerror("Problem is already associated.",err,error,*999)
805  ELSE
806  NULLIFY(problem)
807  CALL problem_user_number_find(user_number,problem,err,error,*999)
808  IF(ASSOCIATED(problem)) THEN
809  local_error="Problem number "//trim(number_to_vstring(user_number,"*",err,error))//" has already been created."
810  CALL flagerror(local_error,err,error,*999)
811  ELSE
812  !Allocate the new problem
813  ALLOCATE(new_problem,stat=err)
814  IF(err/=0) CALL flagerror("Could not allocate new problem.",err,error,*999)
815  !Initalise problem
816  CALL problem_initialise(new_problem,err,error,*999)
817  !Set default problem values
818  new_problem%USER_NUMBER=user_number
819  new_problem%GLOBAL_NUMBER=problems%NUMBER_OF_PROBLEMS+1
820  new_problem%PROBLEMS=>problems
821  !Set problem specification
822  CALL problem_specificationset(new_problem,problem_specification,err,error,*999)
823  !For compatibility with old code, set class, type and subtype
824  new_problem%PROBLEM_FINISHED=.false.
825  !Initialise the problem setup information
826  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
827  problem_setup_info%SETUP_TYPE=problem_setup_initial_type
828  problem_setup_info%ACTION_TYPE=problem_setup_start_action
829  !Start problem specific setup
830  CALL problem_setup(new_problem,problem_setup_info,err,error,*999)
831  !Finalise the problem setup information
832  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
833  !Add new problem into list of problems
834  ALLOCATE(new_problems(problems%NUMBER_OF_PROBLEMS+1),stat=err)
835  IF(err/=0) CALL flagerror("Could not allocate new problems.",err,error,*999)
836  DO problem_idx=1,problems%NUMBER_OF_PROBLEMS
837  new_problems(problem_idx)%PTR=>problems%PROBLEMS(problem_idx)%PTR
838  ENDDO !problem_idx
839  new_problems(problems%NUMBER_OF_PROBLEMS+1)%PTR=>new_problem
840  IF(ASSOCIATED(problems%PROBLEMS)) DEALLOCATE(problems%PROBLEMS)
841  problems%PROBLEMS=>new_problems
842  problems%NUMBER_OF_PROBLEMS=problems%NUMBER_OF_PROBLEMS+1
843  problem=>new_problem
844  ENDIF
845  ENDIF
846 
847  exits("PROBLEM_CREATE_START")
848  RETURN
849 999 errorsexits("PROBLEM_CREATE_START",err,error)
850  RETURN 1
851  END SUBROUTINE problem_create_start
852 
853  !
854  !================================================================================================================================
855  !
856 
858  SUBROUTINE problem_destroy(PROBLEM,ERR,ERROR,*)
859 
860  !Argument variables
861  TYPE(problem_type), POINTER :: problem
862  INTEGER(INTG), INTENT(OUT) :: err
863  TYPE(varying_string), INTENT(OUT) :: error
864  !Local Variables
865  INTEGER(INTG) :: problem_idx,problem_position
866  TYPE(problem_ptr_type), POINTER :: new_problems(:)
867 
868  NULLIFY(new_problems)
869 
870  enters("PROBLEM_DESTROY",err,error,*999)
871 
872  IF(ASSOCIATED(problem)) THEN
873  IF(ASSOCIATED(problems%PROBLEMS)) THEN
874 
875  problem_position=problem%GLOBAL_NUMBER
876 
877  !Destroy all the problem components
878  CALL problem_finalise(problem,err,error,*999)
879 
880  !Remove the problem from the list of problems
881  IF(problems%NUMBER_OF_PROBLEMS>1) THEN
882  ALLOCATE(new_problems(problems%NUMBER_OF_PROBLEMS-1),stat=err)
883  IF(err/=0) CALL flagerror("Could not allocate new problems.",err,error,*999)
884  DO problem_idx=1,problems%NUMBER_OF_PROBLEMS
885  IF(problem_idx<problem_position) THEN
886  new_problems(problem_idx)%PTR=>problems%PROBLEMS(problem_idx)%PTR
887  ELSE IF(problem_idx>problem_position) THEN
888  problems%PROBLEMS(problem_idx)%PTR%GLOBAL_NUMBER=problems%PROBLEMS(problem_idx)%PTR%GLOBAL_NUMBER-1
889  new_problems(problem_idx-1)%PTR=>problems%PROBLEMS(problem_idx)%PTR
890  ENDIF
891  ENDDO !problem_idx
892  DEALLOCATE(problems%PROBLEMS)
893  problems%PROBLEMS=>new_problems
894  problems%NUMBER_OF_PROBLEMS=problems%NUMBER_OF_PROBLEMS-1
895  ELSE
896  DEALLOCATE(problems%PROBLEMS)
897  problems%NUMBER_OF_PROBLEMS=0
898  ENDIF
899 
900  ELSE
901  CALL flagerror("Problem problems is not associated.",err,error,*999)
902  ENDIF
903  ELSE
904  CALL flagerror("Problem is not associated.",err,error,*998)
905  ENDIF
906 
907  exits("PROBLEM_DESTROY")
908  RETURN
909 999 IF(ASSOCIATED(new_problems)) DEALLOCATE(new_problems)
910 998 errorsexits("PROBLEM_DESTROY",err,error)
911  RETURN 1
912  END SUBROUTINE problem_destroy
913 
914  !
915  !================================================================================================================================
916  !
917 
919  SUBROUTINE problem_setup_finalise(PROBLEM_SETUP_INFO,ERR,ERROR,*)
920 
921  !Argument variables
922  TYPE(problem_setup_type), INTENT(OUT) :: problem_setup_info
923  INTEGER(INTG), INTENT(OUT) :: err
924  TYPE(varying_string), INTENT(OUT) :: error
925  !Local Variables
926 
927  enters("PROBLEM_SETUP_FINALISE",err,error,*999)
928 
929  problem_setup_info%SETUP_TYPE=0
930  problem_setup_info%ACTION_TYPE=0
931 
932  exits("PROBLEM_SETUP_FINALISE")
933  RETURN
934 999 errorsexits("PROBLEM_SETUP_FINALISE",err,error)
935  RETURN 1
936  END SUBROUTINE problem_setup_finalise
937 
938  !
939  !================================================================================================================================
940  !
941 
943  SUBROUTINE problem_setup_initialise(PROBLEM_SETUP_INFO,ERR,ERROR,*)
944 
945  !Argument variables
946  TYPE(problem_setup_type), INTENT(OUT) :: problem_setup_info
947  INTEGER(INTG), INTENT(OUT) :: err
948  TYPE(varying_string), INTENT(OUT) :: error
949  !Local Variables
950 
951  enters("PROBLEM_SETUP_INITIALISE",err,error,*999)
952 
953  problem_setup_info%SETUP_TYPE=0
954  problem_setup_info%ACTION_TYPE=0
955 
956  exits("PROBLEM_SETUP_INITIALISE")
957  RETURN
958 999 errorsexits("PROBLEM_SETUP_INITIALISE",err,error)
959  RETURN 1
960  END SUBROUTINE problem_setup_initialise
961 
962  !
963  !================================================================================================================================
964  !
965 
967  SUBROUTINE problem_finalise(PROBLEM,ERR,ERROR,*)
968 
969  !Argument variables
970  TYPE(problem_type), POINTER :: problem
971  INTEGER(INTG), INTENT(OUT) :: err
972  TYPE(varying_string), INTENT(OUT) :: error
973  !Local Variables
974 
975  enters("PROBLEM_FINALISE",err,error,*999)
976 
977  IF(ASSOCIATED(problem)) THEN
978  IF(ASSOCIATED(problem%CONTROL_LOOP)) CALL control_loop_destroy(problem%CONTROL_LOOP,err,error,*999)
979  IF(ALLOCATED(problem%SPECIFICATION)) DEALLOCATE(problem%SPECIFICATION)
980  DEALLOCATE(problem)
981  ENDIF
982 
983  exits("PROBLEM_FINALISE")
984  RETURN
985 999 errorsexits("PROBLEM_FINALISE",err,error)
986  RETURN 1
987  END SUBROUTINE problem_finalise
988 
989  !
990  !================================================================================================================================
991  !
992 
994  SUBROUTINE problem_initialise(PROBLEM,ERR,ERROR,*)
995 
996  !Argument variables
997  TYPE(problem_type), POINTER :: problem
998  INTEGER(INTG), INTENT(OUT) :: err
999  TYPE(varying_string), INTENT(OUT) :: error
1000  !Local Variables
1001 
1002  enters("PROBLEM_INITIALISE",err,error,*999)
1003 
1004  IF(ASSOCIATED(problem)) THEN
1005  problem%USER_NUMBER=0
1006  problem%GLOBAL_NUMBER=0
1007  problem%PROBLEM_FINISHED=.false.
1008  NULLIFY(problem%PROBLEMS)
1009  NULLIFY(problem%CONTROL_LOOP)
1010  ELSE
1011  CALL flagerror("Problem is not associated.",err,error,*999)
1012  ENDIF
1013 
1014  exits("PROBLEM_INITIALISE")
1015  RETURN
1016 999 errorsexits("PROBLEM_INITIALISE",err,error)
1017  RETURN 1
1018  END SUBROUTINE problem_initialise
1019 
1020  !
1021  !================================================================================================================================
1022  !
1023 
1025  SUBROUTINE problem_control_loop_create_finish(PROBLEM,ERR,ERROR,*)
1026 
1027  !Argument variables
1028  TYPE(problem_type), POINTER :: problem
1029  INTEGER(INTG), INTENT(OUT) :: err
1030  TYPE(varying_string), INTENT(OUT) :: error
1031  !Local Variables
1032  TYPE(problem_setup_type) :: problem_setup_info
1033 
1034  enters("PROBLEM_CONTROL_LOOP_CREATE_FINISH",err,error,*999)
1035 
1036  IF(ASSOCIATED(problem)) THEN
1037  IF(ASSOCIATED(problem%CONTROL_LOOP)) THEN
1038  IF(problem%CONTROL_LOOP%CONTROL_LOOP_FINISHED) THEN
1039  CALL flagerror("Problem control loop has already been finished.",err,error,*999)
1040  ELSE
1041  !Initialise the problem setup information
1042  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
1043  problem_setup_info%SETUP_TYPE=problem_setup_control_type
1044  problem_setup_info%ACTION_TYPE=problem_setup_finish_action
1045  !Finish problem specific startup
1046  CALL problem_setup(problem,problem_setup_info,err,error,*999)
1047  !Finalise the problem setup information
1048  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
1049  !Finish problem control creation
1050  problem%CONTROL_LOOP%CONTROL_LOOP_FINISHED=.true.
1051  ENDIF
1052  ELSE
1053  CALL flagerror("The problem control loop is not associated.",err,error,*999)
1054  ENDIF
1055  ELSE
1056  CALL flagerror("Problem is not associated.",err,error,*999)
1057  ENDIF
1058 
1059  exits("PROBLEM_CONTROL_LOOP_CREATE_FINISH")
1060  RETURN
1061 999 errorsexits("PROBLEM_CONTROL_LOOP_CREATE_FINISH",err,error)
1062  RETURN 1
1063  END SUBROUTINE problem_control_loop_create_finish
1064 
1065  !
1066  !================================================================================================================================
1067  !
1068 
1074  SUBROUTINE problem_control_loop_create_start(PROBLEM,ERR,ERROR,*)
1075 
1076  !Argument variables
1077  TYPE(problem_type), POINTER :: problem
1078  INTEGER(INTG), INTENT(OUT) :: err
1079  TYPE(varying_string), INTENT(OUT) :: error
1080  !Local Variables
1081  TYPE(problem_setup_type) :: problem_setup_info
1082 
1083  enters("PROBLEM_CONTROL_LOOP_CREATE_START",err,error,*999)
1084 
1085  IF(ASSOCIATED(problem)) THEN
1086  IF(ASSOCIATED(problem%CONTROL_LOOP)) THEN
1087  CALL flagerror("The problem control loop is already associated.",err,error,*999)
1088  ELSE
1089  !Initialise the problem setup information
1090  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
1091  problem_setup_info%SETUP_TYPE=problem_setup_control_type
1092  problem_setup_info%ACTION_TYPE=problem_setup_start_action
1093  !Start the problem specific control setup
1094  CALL problem_setup(problem,problem_setup_info,err,error,*999)
1095  !Finalise the problem setup information
1096  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
1097  ENDIF
1098  ELSE
1099  CALL flagerror("Problem is not associated.",err,error,*999)
1100  ENDIF
1101 
1102  exits("PROBLEM_CONTROL_LOOP_CREATE_START")
1103  RETURN
1104 999 errorsexits("PROBLEM_CONTROL_LOOP_CREATE_START",err,error)
1105  RETURN 1
1106  END SUBROUTINE problem_control_loop_create_start
1107 
1108  !
1109  !================================================================================================================================
1110  !
1111 
1113  SUBROUTINE problem_control_loop_destroy(PROBLEM,ERR,ERROR,*)
1114 
1115  !Argument variables
1116  TYPE(problem_type), POINTER :: problem
1117  INTEGER(INTG), INTENT(OUT) :: err
1118  TYPE(varying_string), INTENT(OUT) :: error
1119  !Local Variables
1120 
1121  enters("PROBLEM_CONTROL_LOOP_DESTROY",err,error,*999)
1122 
1123  IF(ASSOCIATED(problem)) THEN
1124  IF(ASSOCIATED(problem%CONTROL_LOOP)) THEN
1125  CALL control_loop_destroy(problem%CONTROL_LOOP,err,error,*999)
1126  ELSE
1127  CALL flagerror("Problem control loop is not associated.",err,error,*999)
1128  ENDIF
1129  ELSE
1130  CALL flagerror("Problem is not associated.",err,error,*999)
1131  ENDIF
1132 
1133  exits("PROBLEM_CONTROL_LOOP_DESTROY")
1134  RETURN
1135 999 errorsexits("PROBLEM_CONTROL_LOOP_DESTROY",err,error)
1136  RETURN 1
1137  END SUBROUTINE problem_control_loop_destroy
1138 
1139  !
1140  !================================================================================================================================
1141  !
1142 
1144  SUBROUTINE problem_control_loop_get_0(PROBLEM,CONTROL_LOOP_IDENTIFIER,CONTROL_LOOP,ERR,ERROR,*)
1145 
1146  !Argument variables
1147  TYPE(problem_type), POINTER :: problem
1148  INTEGER(INTG), INTENT(IN) :: control_loop_identifier
1149  TYPE(control_loop_type), POINTER :: control_loop
1150  INTEGER(INTG), INTENT(OUT) :: err
1151  TYPE(varying_string), INTENT(OUT) :: error
1152  !Local Variables
1153 
1154  enters("PROBLEM_CONTROL_LOOP_GET_0",err,error,*999)
1155 
1156  CALL problem_control_loop_get_1(problem,[control_loop_identifier],control_loop,err,error,*999)
1157 
1158  exits("PROBLEM_CONTROL_LOOP_GET_0")
1159  RETURN
1160 999 errorsexits("PROBLEM_CONTROL_LOOP_GET_0",err,error)
1161  RETURN 1
1162  END SUBROUTINE problem_control_loop_get_0
1163 
1164  !
1165  !================================================================================================================================
1166  !
1167 
1169  SUBROUTINE problem_control_loop_get_1(PROBLEM,CONTROL_LOOP_IDENTIFIER,CONTROL_LOOP,ERR,ERROR,*)
1170 
1171  !Argument variables
1172  TYPE(problem_type), POINTER :: problem
1173  INTEGER(INTG), INTENT(IN) :: control_loop_identifier(:)
1174  TYPE(control_loop_type), POINTER :: control_loop
1175  INTEGER(INTG), INTENT(OUT) :: err
1176  TYPE(varying_string), INTENT(OUT) :: error
1177  !Local Variables
1178  TYPE(control_loop_type), POINTER :: control_loop_root
1179 
1180  enters("PROBLEM_CONTROL_LOOP_GET_1",err,error,*999)
1181 
1182  IF(ASSOCIATED(problem)) THEN
1183  IF(ASSOCIATED(control_loop)) THEN
1184  CALL flagerror("Control loop is already associated.",err,error,*999)
1185  ELSE
1186  control_loop_root=>problem%CONTROL_LOOP
1187  IF(ASSOCIATED(control_loop_root)) THEN
1188  NULLIFY(control_loop)
1189  CALL control_loop_get(control_loop_root,control_loop_identifier,control_loop,err,error,*999)
1190  ELSE
1191  CALL flagerror("Problem control loop is not associated.",err,error,*999)
1192  ENDIF
1193  ENDIF
1194  ELSE
1195  CALL flagerror("Problem is not associated.",err,error,*999)
1196  ENDIF
1197 
1198  exits("PROBLEM_CONTROL_LOOP_GET_1")
1199  RETURN
1200 999 errorsexits("PROBLEM_CONTROL_LOOP_GET_1",err,error)
1201  RETURN 1
1202  END SUBROUTINE problem_control_loop_get_1
1203 
1204  !
1205  !================================================================================================================================
1206  !
1207 
1209  SUBROUTINE problem_setup(problem,problemSetupInfo,err,error,*)
1210 
1211  !Argument variables
1212  TYPE(problem_type), POINTER :: problem
1213  TYPE(problem_setup_type), INTENT(INOUT) :: problemsetupinfo
1214  INTEGER(INTG), INTENT(OUT) :: err
1215  TYPE(varying_string), INTENT(OUT) :: error
1216  !Local Variables
1217  TYPE(varying_string) :: localerror
1218 
1219  enters("Problem_Setup",err,error,*999)
1220 
1221  IF(ASSOCIATED(problem)) THEN
1222  IF(.NOT.ALLOCATED(problem%specification)) THEN
1223  CALL flagerror("Problem specification is not allocated.",err,error,*999)
1224  ELSE IF(SIZE(problem%specification,1)<1) THEN
1225  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
1226  ENDIF
1227  SELECT CASE(problem%specification(1))
1228  CASE(problem_elasticity_class)
1229  CALL elasticity_problem_setup(problem,problemsetupinfo,err,error,*999)
1230  CASE(problem_fluid_mechanics_class)
1231  CALL fluid_mechanics_problem_setup(problem,problemsetupinfo,err,error,*999)
1232  CASE(problem_bioelectrics_class)
1233  CALL bioelectric_problem_setup(problem,problemsetupinfo,err,error,*999)
1234  CASE(problem_electromagnetics_class)
1235  CALL flagerror("Not implemented.",err,error,*999)
1236  CASE(problem_classical_field_class)
1237  CALL classical_field_problem_setup(problem,problemsetupinfo,err,error,*999)
1238  CASE(problem_fitting_class)
1239  CALL fitting_problem_setup(problem,problemsetupinfo,err,error,*999)
1240  CASE(problem_modal_class)
1241  CALL flagerror("Not implemented.",err,error,*999)
1242  CASE(problem_multi_physics_class)
1243  CALL multi_physics_problem_setup(problem,problemsetupinfo,err,error,*999)
1244  CASE DEFAULT
1245  localerror="The first problem specification of "//trim(numbertovstring(problem%specification(1),"*",err,error))// &
1246  & " is not valid."
1247  CALL flagerror(localerror,err,error,*999)
1248  END SELECT
1249  ELSE
1250  CALL flagerror("Problem is not associated.",err,error,*999)
1251  ENDIF
1252 
1253  exits("Problem_Setup")
1254  RETURN
1255 999 errorsexits("Problem_Setup",err,error)
1256  RETURN 1
1257 
1258  END SUBROUTINE problem_setup
1259 
1260  !
1261  !================================================================================================================================
1262  !
1263 
1265  SUBROUTINE problem_solver_equations_get_0(PROBLEM,CONTROL_LOOP_IDENTIFIER,SOLVER_INDEX,SOLVER_EQUATIONS,ERR,ERROR,*)
1266 
1267  !Argument variables
1268  TYPE(problem_type), POINTER :: problem
1269  INTEGER(INTG), INTENT(IN) :: control_loop_identifier
1270  INTEGER(INTG), INTENT(IN) :: solver_index
1271  TYPE(solver_equations_type), POINTER :: solver_equations
1272  INTEGER(INTG), INTENT(OUT) :: err
1273  TYPE(varying_string), INTENT(OUT) :: error
1274  !Local Variables
1275 
1276  enters("PROBLEM_SOLVER_EQUATIONS_GET_0",err,error,*999)
1277 
1278  CALL problem_solver_equations_get_1(problem,[control_loop_identifier],solver_index,solver_equations,err,error,*999)
1279 
1280  exits("PROBLEM_SOLVER_EQUATIONS_GET_0")
1281  RETURN
1282 999 errorsexits("PROBLEM_SOLVER_EQUATIONS_GET_0",err,error)
1283  RETURN 1
1284  END SUBROUTINE problem_solver_equations_get_0
1285 
1286  !
1287  !================================================================================================================================
1288  !
1289 
1291  SUBROUTINE problem_solver_equations_get_1(PROBLEM,CONTROL_LOOP_IDENTIFIER,SOLVER_INDEX,SOLVER_EQUATIONS,ERR,ERROR,*)
1292 
1293  !Argument variables
1294  TYPE(problem_type), POINTER :: problem
1295  INTEGER(INTG), INTENT(IN) :: control_loop_identifier(:)
1296  INTEGER(INTG), INTENT(IN) :: solver_index
1297  TYPE(solver_equations_type), POINTER :: solver_equations
1298  INTEGER(INTG), INTENT(OUT) :: err
1299  TYPE(varying_string), INTENT(OUT) :: error
1300  !Local Variables
1301  TYPE(control_loop_type), POINTER :: control_loop,control_loop_root
1302  TYPE(solver_type), POINTER :: solver
1303  TYPE(solvers_type), POINTER :: solvers
1304  TYPE(varying_string) :: local_error
1305 
1306  enters("PROBLEM_SOLVER_EQUATIONS_GET_1",err,error,*999)
1307 
1308  IF(ASSOCIATED(problem)) THEN
1309  IF(ASSOCIATED(solver_equations)) THEN
1310  CALL flagerror("The solver equations is already associated.",err,error,*999)
1311  ELSE
1312  NULLIFY(solver_equations)
1313  control_loop_root=>problem%CONTROL_LOOP
1314  IF(ASSOCIATED(control_loop_root)) THEN
1315  NULLIFY(control_loop)
1316  CALL control_loop_get(control_loop_root,control_loop_identifier,control_loop,err,error,*999)
1317  solvers=>control_loop%SOLVERS
1318  IF(ASSOCIATED(solvers)) THEN
1319  IF(solver_index>0.AND.solver_index<=solvers%NUMBER_OF_SOLVERS) THEN
1320  solver=>solvers%SOLVERS(solver_index)%PTR
1321  IF(ASSOCIATED(solver)) THEN
1322  solver_equations=>solver%SOLVER_EQUATIONS
1323  IF(.NOT.ASSOCIATED(solver_equations)) CALL flagerror("Solver equations is not associated.",err,error,*999)
1324  ELSE
1325  CALL flagerror("Solver is not associated.",err,error,*999)
1326  ENDIF
1327  ELSE
1328  local_error="The specified solver index of "//trim(number_to_vstring(solver_index,"*",err,error))// &
1329  & " is invalid. The index must be > 0 and <= "// &
1330  & trim(number_to_vstring(solvers%NUMBER_OF_SOLVERS,"*",err,error))//"."
1331  CALL flagerror(local_error,err,error,*999)
1332  ENDIF
1333  ELSE
1334  CALL flagerror("Solvers is not associated.",err,error,*999)
1335  ENDIF
1336  ELSE
1337  CALL flagerror("Problem control loop is not associated.",err,error,*999)
1338  ENDIF
1339  ENDIF
1340  ELSE
1341  CALL flagerror("Problem is not associated.",err,error,*999)
1342  ENDIF
1343 
1344  exits("PROBLEM_SOLVER_EQUATIONS_GET_1")
1345  RETURN
1346 999 errorsexits("PROBLEM_SOLVER_EQUATIONS_GET_1",err,error)
1347  RETURN 1
1348  END SUBROUTINE problem_solver_equations_get_1
1349 
1350  !
1351  !================================================================================================================================
1352  !
1353 
1355  SUBROUTINE problem_solver_jacobian_evaluate(SOLVER,ERR,ERROR,*)
1356 
1357  !Argument variables
1358  TYPE(solver_type), POINTER :: solver, linking_solver
1359  INTEGER(INTG), INTENT(OUT) :: err
1360  TYPE(varying_string), INTENT(OUT) :: error
1361  !Local Variables
1362  INTEGER(INTG) :: equations_set_idx,solver_matrix_idx
1363  TYPE(equations_set_type), POINTER :: equations_set
1364  TYPE(solver_type), POINTER :: cellml_solver
1365  TYPE(newton_solver_type), POINTER :: newton_solver
1366  TYPE(solver_equations_type), POINTER :: solver_equations
1367  TYPE(solver_mapping_type), POINTER :: solver_mapping
1368  TYPE(solver_matrices_type), POINTER :: solver_matrices
1369  TYPE(solver_matrix_type), POINTER :: solver_matrix
1370  TYPE(varying_string) :: local_error
1371 
1372  enters("PROBLEM_SOLVER_JACOBIAN_EVALUATE",err,error,*999)
1373 
1374  IF(ASSOCIATED(solver)) THEN
1375  IF(solver%SOLVER_FINISHED) THEN
1376  solver_equations=>solver%SOLVER_EQUATIONS
1377  IF(ASSOCIATED(solver_equations)) THEN
1378  solver_mapping=>solver_equations%SOLVER_MAPPING
1379  IF(ASSOCIATED(solver_mapping)) THEN
1380  IF(solver%OUTPUT_TYPE>=solver_matrix_output) THEN
1381  solver_matrices=>solver_equations%SOLVER_MATRICES
1382  IF(ASSOCIATED(solver_matrices)) THEN
1383  CALL write_string(general_output_type,"",err,error,*999)
1384  CALL write_string(general_output_type,"Solver vector values:",err,error,*999)
1385  DO solver_matrix_idx=1,solver_matrices%NUMBER_OF_MATRICES
1386  solver_matrix=>solver_matrices%MATRICES(solver_matrix_idx)%PTR
1387  IF(ASSOCIATED(solver_matrix)) THEN
1388  CALL write_string_value(general_output_type,"Solver matrix : ",solver_matrix_idx,err,error,*999)
1389  CALL distributed_vector_output(general_output_type,solver_matrix%SOLVER_VECTOR,err,error,*999)
1390  ELSE
1391  local_error="Solver matrix is not associated for solver matrix index "// &
1392  & trim(number_to_vstring(solver_matrix_idx,"*",err,error))//"."
1393  CALL flagerror(local_error,err,error,*999)
1394  ENDIF
1395  ENDDO !solver_matrix_idx
1396  ELSE
1397  CALL flagerror("Solver equations solver matrices is not associated.",err,error,*999)
1398  ENDIF
1399  ENDIF
1400  IF(solver%SOLVE_TYPE==solver_nonlinear_type) THEN
1401  !Check if the nonlinear solver is linked to a dynamic solver
1402  linking_solver=>solver%LINKING_SOLVER
1403  IF(ASSOCIATED(linking_solver)) THEN
1404  IF(linking_solver%SOLVE_TYPE==solver_dynamic_type) THEN
1405  !Update the field values from the dynamic factor * current solver values AND add in mean predicted displacements/
1406  CALL solver_variables_dynamic_nonlinear_update(solver,err,error,*999)
1407  !check for a linked CellML solver
1408 !!TODO: This should be generalised for nonlinear solvers in general and not just Newton solvers.
1409  newton_solver=>solver%NONLINEAR_SOLVER%NEWTON_SOLVER
1410  IF(ASSOCIATED(newton_solver)) THEN
1411  cellml_solver=>newton_solver%CELLML_EVALUATOR_SOLVER
1412  IF(ASSOCIATED(cellml_solver)) THEN
1413  CALL solver_solve(cellml_solver,err,error,*999)
1414  ENDIF
1415  ELSE
1416  CALL flagerror("Nonlinear solver Newton solver is not associated.",err,error,*999)
1417  ENDIF
1418  !Calculate the Jacobian
1419  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
1420  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
1421  !Assemble the equations for dynamic problems
1422  CALL equations_set_jacobian_evaluate(equations_set,err,error,*999)
1423  ENDDO !equations_set_idx
1424  !Assemble the dynamic nonlinear solver matrices
1425  CALL solver_matrices_dynamic_assemble(solver,solver_matrices_jacobian_only,err,error,*999)
1426  ELSE
1427  CALL flagerror("Solver equations linking solver mapping is not dynamic.",err,error,*999)
1428  END IF
1429  ELSE
1430  !Otherwise perform as steady nonlinear
1431  !Copy the current solution vector to the dependent field
1432  CALL solver_variables_field_update(solver,err,error,*999)
1433  !check for a linked CellML solver
1434 !!TODO: This should be generalised for nonlinear solvers in general and not just Newton solvers.
1435  newton_solver=>solver%NONLINEAR_SOLVER%NEWTON_SOLVER
1436  IF(ASSOCIATED(newton_solver)) THEN
1437  cellml_solver=>newton_solver%CELLML_EVALUATOR_SOLVER
1438  IF(ASSOCIATED(cellml_solver)) THEN
1439  CALL solver_solve(cellml_solver,err,error,*999)
1440  ENDIF
1441  ELSE
1442  CALL flagerror("Nonlinear solver Newton solver is not associated.",err,error,*999)
1443  ENDIF
1444  !Calculate the Jacobian
1445  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
1446  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
1447  !Assemble the equations for linear problems
1448  CALL equations_set_jacobian_evaluate(equations_set,err,error,*999)
1449  ENDDO !equations_set_idx
1450  !Update interface matrices
1451 ! DO interfaceConditionIdx=1,SOLVER_MAPPING%NUMBER_OF_INTERFACE_CONDITIONS
1452 ! interfaceCondition=>SOLVER_MAPPING%INTERFACE_CONDITIONS(interfaceConditionIdx)%PTR
1453 ! !Assemble the interface condition for the Jacobian LHS
1454 ! CALL WRITE_STRING(GENERAL_OUTPUT_TYPE,"********************Jacobian evaluation******************",ERR,ERROR,*999)
1455 ! CALL INTERFACE_CONDITION_ASSEMBLE(interfaceCondition,err,error,*999)
1456 ! ENDDO
1457  !Assemble the static nonlinear solver matrices
1458  CALL solver_matrices_static_assemble(solver,solver_matrices_jacobian_only,err,error,*999)
1459  END IF
1460  ELSE
1461  CALL flagerror("Solver equations solver type is not associated.",err,error,*999)
1462  END IF
1463  ELSE
1464  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
1465  ENDIF
1466  ELSE
1467  CALL flagerror("Solver solver equations mapping is not associated.",err,error,*999)
1468  ENDIF
1469  ELSE
1470  CALL flagerror("Solver has not been finished.",err,error,*999)
1471  ENDIF
1472  ELSE
1473  CALL flagerror("Solver is not associated.",err,error,*999)
1474  ENDIF
1475 
1476  exits("PROBLEM_SOLVER_JACOBIAN_EVALUATE")
1477  RETURN
1478 999 errorsexits("PROBLEM_SOLVER_JACOBIAN_EVALUATE",err,error)
1479  RETURN 1
1480  END SUBROUTINE problem_solver_jacobian_evaluate
1481 
1482  !
1483  !================================================================================================================================
1484  !
1485 
1487  SUBROUTINE problem_solver_residual_evaluate(SOLVER,ERR,ERROR,*)
1488 
1489  !Argument variables
1490  TYPE(solver_type), POINTER :: solver
1491  INTEGER(INTG), INTENT(OUT) :: err
1492  TYPE(varying_string), INTENT(OUT) :: error
1493  !Local Variables
1494  INTEGER(INTG) :: equations_set_idx,solver_matrix_idx
1495  TYPE(equations_set_type), POINTER :: equations_set
1496  TYPE(solver_type), POINTER :: cellml_solver,linking_solver
1497  TYPE(solver_equations_type), POINTER :: solver_equations
1498  TYPE(solver_mapping_type), POINTER :: solver_mapping
1499  TYPE(solver_matrices_type), POINTER :: solver_matrices
1500  TYPE(solver_matrix_type), POINTER :: solver_matrix
1501 
1502  TYPE(varying_string) :: local_error
1503 
1504  NULLIFY(cellml_solver)
1505  NULLIFY(linking_solver)
1506 
1507  enters("PROBLEM_SOLVER_RESIDUAL_EVALUATE",err,error,*999)
1508 
1509  IF(ASSOCIATED(solver)) THEN
1510  IF(solver%SOLVER_FINISHED) THEN
1511  solver_equations=>solver%SOLVER_EQUATIONS
1512  IF(ASSOCIATED(solver_equations)) THEN
1513  solver_mapping=>solver_equations%SOLVER_MAPPING
1514  IF(ASSOCIATED(solver_mapping)) THEN
1515  IF(solver%OUTPUT_TYPE>=solver_matrix_output) THEN
1516  solver_matrices=>solver_equations%SOLVER_MATRICES
1517  IF(ASSOCIATED(solver_matrices)) THEN
1518  CALL write_string(general_output_type,"",err,error,*999)
1519  CALL write_string(general_output_type,"Solver vector values:",err,error,*999)
1520  DO solver_matrix_idx=1,solver_matrices%NUMBER_OF_MATRICES
1521  solver_matrix=>solver_matrices%MATRICES(solver_matrix_idx)%PTR
1522  IF(ASSOCIATED(solver_matrix)) THEN
1523  CALL write_string_value(general_output_type,"Solver matrix : ",solver_matrix_idx,err,error,*999)
1524  CALL distributed_vector_output(general_output_type,solver_matrix%SOLVER_VECTOR,err,error,*999)
1525  ELSE
1526  local_error="Solver matrix is not associated for solver matrix index "// &
1527  & trim(number_to_vstring(solver_matrix_idx,"*",err,error))//"."
1528  CALL flagerror(local_error,err,error,*999)
1529  ENDIF
1530  ENDDO !solver_matrix_idx
1531  ELSE
1532  CALL flagerror("Solver equations solver matrices is not associated.",err,error,*999)
1533  ENDIF
1534  ENDIF
1535  IF(solver%SOLVE_TYPE==solver_nonlinear_type) THEN
1536  !Check if the nonlinear solver is linked to a dynamic solver
1537  linking_solver=>solver%LINKING_SOLVER
1538  IF(ASSOCIATED(linking_solver)) THEN
1539  IF(linking_solver%SOLVE_TYPE==solver_dynamic_type) THEN
1540  !Update the field values from the dynamic factor*current solver values AND add in predicted displacements
1541  CALL solver_variables_dynamic_nonlinear_update(solver,err,error,*999)
1542  !Caculate the strain field for an CellML evaluator solver
1543  CALL problem_pre_residual_evaluate(solver,err,error,*999)
1544  !check for a linked CellML solver
1545 
1546 !!TODO: This should be generalised for nonlinear solvers in general and not just Newton solvers.
1547  SELECT CASE(solver%NONLINEAR_SOLVER%NONLINEAR_SOLVE_TYPE)
1548  CASE(solver_nonlinear_newton)
1549  cellml_solver=>solver%NONLINEAR_SOLVER%NEWTON_SOLVER%CELLML_EVALUATOR_SOLVER
1550  CASE(solver_nonlinear_quasi_newton)
1551  cellml_solver=>solver%NONLINEAR_SOLVER%QUASI_NEWTON_SOLVER%CELLML_EVALUATOR_SOLVER
1552  CASE DEFAULT
1553  local_error="Linked CellML solver is not implemented for nonlinear solver type " &
1554  & //trim(number_to_vstring(solver%NONLINEAR_SOLVER%NONLINEAR_SOLVE_TYPE,"*",err,error))//"."
1555  CALL flagerror(local_error,err,error,*999)
1556  END SELECT
1557  IF(ASSOCIATED(cellml_solver)) CALL solver_solve(cellml_solver,err,error,*999)
1558  !Calculate the residual for each element (M, C, K and g)
1559  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
1560  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
1561  SELECT CASE(equations_set%EQUATIONS%LINEARITY)
1562  CASE(equations_linear)
1563  !Assemble the equations for linear equations
1564  CALL equations_set_assemble(equations_set,err,error,*999)
1565  CASE(equations_nonlinear)
1566  !Evaluate the residual for nonlinear equations
1567  CALL equations_set_residual_evaluate(equations_set,err,error,*999)
1568  END SELECT
1569  ENDDO !equations_set_idx
1570  !Assemble the final solver residual.
1571  CALL solver_matrices_dynamic_assemble(solver,solver_matrices_rhs_residual_only,err,error,*999)
1572  ELSE
1573  CALL flagerror("Solver equations linking solver mapping is not dynamic.",err,error,*999)
1574  END IF
1575  ELSE
1576  !Perform as normal nonlinear solver
1577  !Copy the current solution vector to the dependent field
1578  CALL solver_variables_field_update(solver,err,error,*999)
1579  !Caculate the strain field for an CellML evaluator solver
1580  CALL problem_pre_residual_evaluate(solver,err,error,*999)
1581  !check for a linked CellML solver
1582 !!TODO: This should be generalised for nonlinear solvers in general and not just Newton solvers.
1583  SELECT CASE(solver%NONLINEAR_SOLVER%NONLINEAR_SOLVE_TYPE)
1584  CASE(solver_nonlinear_newton)
1585  cellml_solver=>solver%NONLINEAR_SOLVER%NEWTON_SOLVER%CELLML_EVALUATOR_SOLVER
1586  CASE(solver_nonlinear_quasi_newton)
1587  cellml_solver=>solver%NONLINEAR_SOLVER%QUASI_NEWTON_SOLVER%CELLML_EVALUATOR_SOLVER
1588  CASE DEFAULT
1589  local_error="Linked CellML solver is not implemented for nonlinear solver type " &
1590  & //trim(number_to_vstring(solver%NONLINEAR_SOLVER%NONLINEAR_SOLVE_TYPE,"*",err,error))//"."
1591  CALL flagerror(local_error,err,error,*999)
1592  END SELECT
1593  IF(ASSOCIATED(cellml_solver)) CALL solver_solve(cellml_solver,err,error,*999)
1594  !Make sure the equations sets are up to date
1595  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
1596  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
1597  SELECT CASE(equations_set%EQUATIONS%LINEARITY)
1598  CASE(equations_linear)
1599  !Assemble the equations for linear equations
1600  CALL equations_set_assemble(equations_set,err,error,*999)
1601  CASE(equations_nonlinear)
1602  !Evaluate the residual for nonlinear equations
1603  CALL equations_set_residual_evaluate(equations_set,err,error,*999)
1604  END SELECT
1605  ENDDO !equations_set_idx
1606  !Note that the linear interface matrices are not required to be updated since these matrices do not change
1607  !Update interface matrices
1608 ! DO interfaceConditionIdx=1,SOLVER_MAPPING%NUMBER_OF_INTERFACE_CONDITIONS
1609 ! interfaceCondition=>SOLVER_MAPPING%INTERFACE_CONDITIONS(interfaceConditionIdx)%PTR
1610 ! !Assemble the interface condition for the Jacobian LHS
1611 ! CALL WRITE_STRING(GENERAL_OUTPUT_TYPE,"********************Residual evaluation******************",ERR,ERROR,*999)
1612 ! CALL INTERFACE_CONDITION_ASSEMBLE(interfaceCondition,err,error,*999)
1613 ! ENDDO
1614  !Assemble the solver matrices
1615  CALL solver_matrices_static_assemble(solver,solver_matrices_rhs_residual_only,err,error,*999)
1616  END IF
1617  ELSE
1618  CALL flagerror("Solver equations solver type is not associated.",err,error,*999)
1619  END IF
1620  ELSE
1621  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
1622  ENDIF
1623  ELSE
1624  CALL flagerror("Solver solver equations mapping is not associated.",err,error,*999)
1625  ENDIF
1626  CALL problem_post_residual_evaluate(solver,err,error,*999)
1627  ELSE
1628  CALL flagerror("Solver has not been finished.",err,error,*999)
1629  ENDIF
1630  ELSE
1631  CALL flagerror("Solver is not associated.",err,error,*999)
1632  ENDIF
1633 
1634  exits("PROBLEM_SOLVER_RESIDUAL_EVALUATE")
1635  RETURN
1636 999 errorsexits("PROBLEM_SOLVER_RESIDUAL_EVALUATE",err,error)
1637  RETURN 1
1638 
1639  END SUBROUTINE problem_solver_residual_evaluate
1640 
1641  !
1642  !================================================================================================================================
1643  !
1644 
1646  SUBROUTINE problem_pre_residual_evaluate(SOLVER,ERR,ERROR,*)
1647 
1648  !Argument variables
1649  TYPE(solver_type), POINTER :: solver
1650  INTEGER(INTG), INTENT(OUT) :: err
1651  TYPE(varying_string), INTENT(OUT) :: error
1652  !Local Variables
1653  INTEGER(INTG) :: equations_set_idx
1654  TYPE(equations_set_type), POINTER :: equations_set
1655  TYPE(equations_type), POINTER :: equations
1656  TYPE(solver_equations_type), POINTER :: solver_equations
1657  TYPE(solver_mapping_type), POINTER :: solver_mapping
1658  TYPE(varying_string) :: local_error
1659 
1660  enters("PROBLEM_PRE_RESIDUAL_EVALUATE",err,error,*999)
1661 
1662  IF(ASSOCIATED(solver)) THEN
1663  IF(solver%SOLVER_FINISHED) THEN
1664  solver_equations=>solver%SOLVER_EQUATIONS
1665  IF(ASSOCIATED(solver_equations)) THEN
1666  solver_mapping=>solver_equations%SOLVER_MAPPING
1667  IF(ASSOCIATED(solver_mapping)) THEN
1668  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
1669  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
1670  IF(ASSOCIATED(equations_set)) THEN
1671  equations=>equations_set%EQUATIONS
1672  IF(ASSOCIATED(equations)) THEN
1673  IF(equations%EQUATIONS_FINISHED) THEN
1674  SELECT CASE(equations%LINEARITY)
1675  CASE(equations_linear)
1676  CALL flagerror("Can not pre-evaluate a residual for linear equations.",err,error,*999)
1677  CASE(equations_nonlinear)
1678  SELECT CASE(equations%TIME_DEPENDENCE)
1679  CASE(equations_static,equations_quasistatic,equations_first_order_dynamic) ! quasistatic handled like static
1680  SELECT CASE(equations_set%SOLUTION_METHOD)
1681  CASE(equations_set_fem_solution_method)
1682  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
1683  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
1684  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
1685  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
1686  ENDIF
1687  SELECT CASE(equations_set%specification(1))
1688  CASE(equations_set_elasticity_class)
1689  CALL elasticity_finiteelementpreresidualevaluate(equations_set,err,error,*999)
1690  CASE(equations_set_fluid_mechanics_class)
1691  CALL fluidmechanics_finiteelementpreresidualevaluate(equations_set,err,error,*999)
1692  CASE(equations_set_electromagnetics_class)
1693  !Pre residual evaluate not used
1694  CASE(equations_set_classical_field_class)
1695  !Pre residual evaluate not used
1696  CASE(equations_set_bioelectrics_class)
1697  !Pre residual evaluate not used
1698  CASE(equations_set_modal_class)
1699  !Pre residual evaluate not used
1700  CASE(equations_set_multi_physics_class)
1701  !Pre residual evaluate not used
1702  CASE DEFAULT
1703  local_error="The first equations set specification of "// &
1704  & trim(numbertovstring(equations_set%specification(1),"*",err,error))//" is not valid."
1705  CALL flagerror(local_error,err,error,*999)
1706  END SELECT !EQUATIONS_SET%SPECIFICATION(1)
1707  CASE(equations_set_nodal_solution_method)
1708  SELECT CASE(equations_set%SPECIFICATION(1))
1709  CASE(equations_set_fluid_mechanics_class)
1710  !Pre residual evaluate not used
1711  CASE DEFAULT
1712  local_error="The first equations set specification of "// &
1713  & trim(numbertovstring(equations_set%SPECIFICATION(1),"*",err,error))//" is not valid."
1714  CALL flag_error(local_error,err,error,*999)
1715  END SELECT !EQUATIONS_SET%SPECIFICATION(1)
1716  CASE(equations_set_bem_solution_method)
1717  CALL flagerror("Not implemented.",err,error,*999)
1718  CASE(equations_set_fd_solution_method)
1719  CALL flagerror("Not implemented.",err,error,*999)
1720  CASE(equations_set_fv_solution_method)
1721  CALL flagerror("Not implemented.",err,error,*999)
1722  CASE(equations_set_gfem_solution_method)
1723  CALL flagerror("Not implemented.",err,error,*999)
1724  CASE(equations_set_gfv_solution_method)
1725  CALL flagerror("Not implemented.",err,error,*999)
1726  CASE DEFAULT
1727  local_error="The equations set solution method of "// &
1728  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
1729  & " is invalid."
1730  CALL flagerror(local_error,err,error,*999)
1731  END SELECT !EQUATIONS_SET%SOLUTION_METHOD
1732  CASE(equations_second_order_dynamic)
1733  CALL flagerror("Not implemented.",err,error,*999)
1734  CASE(equations_time_stepping)
1735  CALL flagerror("Not implemented.",err,error,*999)
1736  CASE DEFAULT
1737  local_error="The equations set time dependence type of "// &
1738  & trim(number_to_vstring(equations%TIME_DEPENDENCE,"*",err,error))//" is invalid."
1739  CALL flagerror(local_error,err,error,*999)
1740  END SELECT
1741  CASE(equations_nonlinear_bcs)
1742  CALL flagerror("Not implemented.",err,error,*999)
1743  CASE DEFAULT
1744  local_error="The equations linearity of "// &
1745  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))//" is invalid."
1746  CALL flagerror(local_error,err,error,*999)
1747  END SELECT
1748  ELSE
1749  CALL flagerror("Equations have not been finished.",err,error,*999)
1750  ENDIF
1751  ELSE
1752  CALL flagerror("Equations set equations is not associated.",err,error,*999)
1753  ENDIF
1754  ELSE
1755  CALL flagerror("Equations set is not associated.",err,error,*999)
1756  ENDIF
1757  ENDDO !equations_set_idx
1758  ELSE
1759  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
1760  ENDIF
1761  ELSE
1762  CALL flagerror("Solver solver equations is not associated.",err,error,*999)
1763  ENDIF
1764  ELSE
1765  CALL flagerror("Solver has not been finished.",err,error,*999)
1766  ENDIF
1767  ELSE
1768  CALL flagerror("Solver is not associated.",err,error,*999)
1769  ENDIF
1770 
1771  exits("PROBLEM_PRE_RESIDUAL_EVALUATE")
1772  RETURN
1773 999 errorsexits("PROBLEM_PRE_RESIDUAL_EVALUATE",err,error)
1774  RETURN 1
1775 
1776  END SUBROUTINE problem_pre_residual_evaluate
1777 
1778  !
1779  !================================================================================================================================
1780  !
1781 
1783  SUBROUTINE problem_post_residual_evaluate(SOLVER,ERR,ERROR,*)
1784 
1785  !Argument variables
1786  TYPE(solver_type), POINTER :: solver
1787  INTEGER(INTG), INTENT(OUT) :: err
1788  TYPE(varying_string), INTENT(OUT) :: error
1789  !Local Variables
1790  INTEGER(INTG) :: equations_set_idx
1791  TYPE(equations_set_type), POINTER :: equations_set
1792  TYPE(equations_type), POINTER :: equations
1793  TYPE(solver_equations_type), POINTER :: solver_equations
1794  TYPE(solver_mapping_type), POINTER :: solver_mapping
1795  TYPE(varying_string) :: local_error
1796 
1797  enters("PROBLEM_POST_RESIDUAL_EVALUATE",err,error,*999)
1798 
1799  IF(ASSOCIATED(solver)) THEN
1800  IF(solver%SOLVER_FINISHED) THEN
1801  solver_equations=>solver%SOLVER_EQUATIONS
1802  IF(ASSOCIATED(solver_equations)) THEN
1803  solver_mapping=>solver_equations%SOLVER_MAPPING
1804  IF(ASSOCIATED(solver_mapping)) THEN
1805  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
1806  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
1807  IF(ASSOCIATED(equations_set)) THEN
1808  equations=>equations_set%EQUATIONS
1809  IF(ASSOCIATED(equations)) THEN
1810  IF(equations%EQUATIONS_FINISHED) THEN
1811  SELECT CASE(equations%LINEARITY)
1812  CASE(equations_linear)
1813  CALL flagerror("Can not post-evaluate a residual for linear equations.",err,error,*999)
1814  CASE(equations_nonlinear)
1815  SELECT CASE(equations%TIME_DEPENDENCE)
1816  CASE(equations_static,equations_quasistatic,equations_first_order_dynamic) ! quasistatic handled like static
1817  SELECT CASE(equations_set%SOLUTION_METHOD)
1818  CASE(equations_set_fem_solution_method)
1819  IF(.NOT.ALLOCATED(equations_set%SPECIFICATION)) THEN
1820  CALL flagerror("Equations set specification is not allocated.",err,error,*999)
1821  ELSE IF(SIZE(equations_set%SPECIFICATION,1)<1) THEN
1822  CALL flagerror("Equations set specification must have at least one entry.",err,error,*999)
1823  END IF
1824  SELECT CASE(equations_set%SPECIFICATION(1))
1825  CASE(equations_set_elasticity_class)
1826  CALL elasticity_finiteelementpostresidualevaluate(equations_set,err,error,*999)
1827  CASE(equations_set_fluid_mechanics_class)
1828  !Post residual evaluate not used
1829  CASE(equations_set_electromagnetics_class)
1830  !Post residual evaluate not used
1831  CASE(equations_set_classical_field_class)
1832  !Post residual evaluate not used
1833  CASE(equations_set_bioelectrics_class)
1834  !Post residual evaluate not used
1835  CASE(equations_set_modal_class)
1836  !Post residual evaluate not used
1837  CASE(equations_set_multi_physics_class)
1838  !Post residual evaluate not used
1839  CASE DEFAULT
1840  local_error="The first equations set specification of "// &
1841  & trim(numbertovstring(equations_set%SPECIFICATION(1),"*",err,error))//" is not valid."
1842  CALL flag_error(local_error,err,error,*999)
1843  END SELECT !EQUATIONS_SET%SPECIFICATION(1)
1844  CASE(equations_set_nodal_solution_method)
1845  SELECT CASE(equations_set%SPECIFICATION(1))
1846  CASE(equations_set_fluid_mechanics_class)
1847  !Post residual evaluate not used
1848  CASE DEFAULT
1849  local_error="The first equations set specification of "// &
1850  & trim(numbertovstring(equations_set%specification(1),"*",err,error))// &
1851  & " is not valid with the nodal solution method."
1852  CALL flag_error(local_error,err,error,*999)
1853  END SELECT !EQUATIONS_SET%SPECIFICATION(1)
1854  CASE(equations_set_bem_solution_method)
1855  CALL flagerror("Not implemented.",err,error,*999)
1856  CASE(equations_set_fd_solution_method)
1857  CALL flagerror("Not implemented.",err,error,*999)
1858  CASE(equations_set_fv_solution_method)
1859  CALL flagerror("Not implemented.",err,error,*999)
1860  CASE(equations_set_gfem_solution_method)
1861  CALL flagerror("Not implemented.",err,error,*999)
1862  CASE(equations_set_gfv_solution_method)
1863  CALL flagerror("Not implemented.",err,error,*999)
1864  CASE DEFAULT
1865  local_error="The equations set solution method of "// &
1866  & trim(number_to_vstring(equations_set%SOLUTION_METHOD,"*",err,error))// &
1867  & " is invalid."
1868  CALL flagerror(local_error,err,error,*999)
1869  END SELECT !EQUATIONS_SET%SOLUTION_METHOD
1870  CASE(equations_second_order_dynamic)
1871  CALL flagerror("Not implemented.",err,error,*999)
1872  CASE(equations_time_stepping)
1873  CALL flagerror("Not implemented.",err,error,*999)
1874  CASE DEFAULT
1875  local_error="The equations set time dependence type of "// &
1876  & trim(number_to_vstring(equations%TIME_DEPENDENCE,"*",err,error))//" is invalid."
1877  CALL flagerror(local_error,err,error,*999)
1878  END SELECT
1879  CASE(equations_nonlinear_bcs)
1880  CALL flagerror("Not implemented.",err,error,*999)
1881  CASE DEFAULT
1882  local_error="The equations linearity of "// &
1883  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))//" is invalid."
1884  CALL flagerror(local_error,err,error,*999)
1885  END SELECT
1886  ELSE
1887  CALL flagerror("Equations have not been finished.",err,error,*999)
1888  ENDIF
1889  ELSE
1890  CALL flagerror("Equations set equations is not associated.",err,error,*999)
1891  ENDIF
1892  ELSE
1893  CALL flagerror("Equations set is not associated.",err,error,*999)
1894  ENDIF
1895  ENDDO !equations_set_idx
1896  ELSE
1897  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
1898  ENDIF
1899  ELSE
1900  CALL flagerror("Solver solver equations is not associated.",err,error,*999)
1901  ENDIF
1902  ELSE
1903  CALL flagerror("Solver has not been finished.",err,error,*999)
1904  ENDIF
1905  ELSE
1906  CALL flagerror("Solver is not associated.",err,error,*999)
1907  ENDIF
1908 
1909  exits("PROBLEM_POST_RESIDUAL_EVALUATE")
1910  RETURN
1911 999 errorsexits("PROBLEM_POST_RESIDUAL_EVALUATE",err,error)
1912  RETURN 1
1913 
1914  END SUBROUTINE problem_post_residual_evaluate
1915 
1916  !
1917  !================================================================================================================================
1918  !
1919 
1921  SUBROUTINE problem_solvers_create_finish(PROBLEM,ERR,ERROR,*)
1922 
1923  !Argument variables
1924  TYPE(problem_type), POINTER :: problem
1925  INTEGER(INTG), INTENT(OUT) :: err
1926  TYPE(varying_string), INTENT(OUT) :: error
1927  !Local Variables
1928  TYPE(problem_setup_type) :: problem_setup_info
1929 
1930  enters("PROBLEM_SOLVERS_CREATE_FINISH",err,error,*999)
1931 
1932  IF(ASSOCIATED(problem)) THEN
1933  !Initialise the problem setup information
1934  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
1935  problem_setup_info%SETUP_TYPE=problem_setup_solvers_type
1936  problem_setup_info%ACTION_TYPE=problem_setup_finish_action
1937  !Finish the problem specific solvers setup.
1938  CALL problem_setup(problem,problem_setup_info,err,error,*999)
1939  !Finalise the problem setup information
1940  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
1941  ELSE
1942  CALL flagerror("Problem is not associated.",err,error,*999)
1943  ENDIF
1944 
1945  exits("PROBLEM_SOLVERS_CREATE_FINISH")
1946  RETURN
1947 999 errorsexits("PROBLEM_SOLVERS_CREATE_FINISH",err,error)
1948  RETURN 1
1949  END SUBROUTINE problem_solvers_create_finish
1950 
1951  !
1952  !================================================================================================================================
1953  !
1954 
1956  SUBROUTINE problem_solvers_create_start(PROBLEM,ERR,ERROR,*)
1957 
1958  !Argument variables
1959  TYPE(problem_type), POINTER :: problem
1960  INTEGER(INTG), INTENT(OUT) :: err
1961  TYPE(varying_string), INTENT(OUT) :: error
1962  !Local Variables
1963  TYPE(problem_setup_type) :: problem_setup_info
1964 
1965  enters("PROBLEM_SOLVERS_CREATE_START",err,error,*999)
1966 
1967  IF(ASSOCIATED(problem)) THEN
1968  !Initialise the problem setup information
1969  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
1970  problem_setup_info%SETUP_TYPE=problem_setup_solvers_type
1971  problem_setup_info%ACTION_TYPE=problem_setup_start_action
1972  !Start the problem specific solvers setup
1973  CALL problem_setup(problem,problem_setup_info,err,error,*999)
1974  !Finalise the problem setup information
1975  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
1976  ELSE
1977  CALL flagerror("Problem is not associated.",err,error,*999)
1978  ENDIF
1979 
1980  exits("PROBLEM_SOLVERS_CREATE_START")
1981  RETURN
1982 999 errorsexits("PROBLEM_SOLVERS_CREATE_START",err,error)
1983  RETURN 1
1984  END SUBROUTINE problem_solvers_create_start
1985 
1986  !
1987  !================================================================================================================================
1988  !
1989 
1991  SUBROUTINE problem_solve(PROBLEM,ERR,ERROR,*)
1992 
1993  !Argument variables
1994  TYPE(problem_type), POINTER :: problem
1995  INTEGER(INTG), INTENT(OUT) :: err
1996  TYPE(varying_string), INTENT(OUT) :: error
1997  !Local Variables
1998  TYPE(control_loop_type), POINTER :: control_loop
1999 
2000  enters("PROBLEM_SOLVE",err,error,*999)
2001 
2002  IF(ASSOCIATED(problem)) THEN
2003  IF(problem%PROBLEM_FINISHED) THEN
2004  control_loop=>problem%CONTROL_LOOP
2005  IF(ASSOCIATED(control_loop)) THEN
2006  CALL problem_control_loop_solve(control_loop,err,error,*999)
2007  ELSE
2008  CALL flagerror("Problem control loop is not associated.",err,error,*999)
2009  ENDIF
2010  ELSE
2011  CALL flagerror("Problem has not been finished.",err,error,*999)
2012  ENDIF
2013  ELSE
2014  CALL flagerror("Problem is not associated",err,error,*999)
2015  ENDIF
2016 
2017  exits("PROBLEM_SOLVE")
2018  RETURN
2019 999 errorsexits("PROBLEM_SOLVE",err,error)
2020  RETURN 1
2021  END SUBROUTINE problem_solve
2022 
2023  !
2024  !================================================================================================================================
2025  !
2026 
2028  SUBROUTINE problem_solver_load_increment_apply(SOLVER_EQUATIONS,ITERATION_NUMBER,MAXIMUM_NUMBER_OF_ITERATIONS,ERR,ERROR,*)
2029 
2030  !Argument variables
2031  TYPE(solver_equations_type), POINTER :: solver_equations
2032  INTEGER(INTG), INTENT(IN) :: iteration_number
2033  INTEGER(INTG), INTENT(IN) :: maximum_number_of_iterations
2034  INTEGER(INTG), INTENT(OUT) :: err
2035  TYPE(varying_string), INTENT(OUT) :: error
2036  !Local variables
2037  TYPE(solver_mapping_type), POINTER :: solver_mapping
2038  TYPE(equations_set_type), POINTER :: equations_set
2039  INTEGER(INTG) :: equations_set_idx
2040 
2041  enters("PROBLEM_SOLVER_LOAD_INCREMENT_APPLY",err,error,*999)
2042 
2043  IF(ASSOCIATED(solver_equations)) THEN
2044  solver_mapping=>solver_equations%SOLVER_MAPPING
2045  IF(ASSOCIATED(solver_mapping)) THEN
2046  !Make sure the equations sets are up to date
2047  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2048  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2049  CALL equations_set_load_increment_apply(equations_set,solver_equations%BOUNDARY_CONDITIONS,iteration_number, &
2050  & maximum_number_of_iterations,err,error,*999)
2051  ENDDO !equations_set_idx
2052  ELSE
2053  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
2054  ENDIF
2055  ELSE
2056  CALL flagerror("Solver equations is not associated.",err,error,*999)
2057  ENDIF
2058 
2059  exits("PROBLEM_SOLVER_LOAD_INCREMENT_APPLY")
2060  RETURN
2061 999 errorsexits("PROBLEM_SOLVER_LOAD_INCREMENT_APPLY",err,error)
2062  RETURN 1
2063 
2064  END SUBROUTINE problem_solver_load_increment_apply
2065 
2066  !
2067  !================================================================================================================================
2068  !
2069 
2071  SUBROUTINE problem_control_loop_pre_loop(CONTROL_LOOP,ERR,ERROR,*)
2072 
2073  !Argument variables
2074  TYPE(control_loop_type), POINTER :: control_loop
2075  INTEGER(INTG), INTENT(OUT) :: err
2076  TYPE(varying_string), INTENT(OUT) :: error
2077  !Local Variables
2078  TYPE(varying_string) :: local_error
2079 
2080  enters("PROBLEM_CONTROL_LOOP_PRE_LOOP",err,error,*999)
2081 
2082  IF(ASSOCIATED(control_loop)) THEN
2083  IF(ASSOCIATED(control_loop%PROBLEM)) THEN
2084  !For all time loops, update the previous values from the current values
2085  IF(control_loop%LOOP_TYPE==problem_control_time_loop_type) THEN
2086  CALL problem_control_loop_previous_values_update(control_loop,err,error,*999)
2087  ENDIF
2088  IF(.NOT.ALLOCATED(control_loop%PROBLEM%SPECIFICATION)) THEN
2089  CALL flagerror("Problem specification is not allocated.",err,error,*999)
2090  ELSE IF(SIZE(control_loop%PROBLEM%SPECIFICATION,1)<1) THEN
2091  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
2092  END IF
2093  SELECT CASE(control_loop%PROBLEM%SPECIFICATION(1))
2094  CASE(problem_elasticity_class)
2095  CALL elasticity_control_loop_pre_loop(control_loop,err,error,*999)
2096  CASE(problem_bioelectrics_class)
2097  !do nothing
2098  CASE(problem_fluid_mechanics_class)
2099  CALL fluid_mechanics_control_loop_pre_loop(control_loop,err,error,*999)
2100  CASE(problem_electromagnetics_class)
2101  !do nothing
2102  CASE(problem_classical_field_class)
2103  !do nothing
2104  CASE(problem_fitting_class)
2105  !do nothing
2106  CASE(problem_modal_class)
2107  !do nothing
2108  CASE(problem_multi_physics_class)
2109  CALL multi_physics_control_loop_pre_loop(control_loop,err,error,*999)
2110  CASE DEFAULT
2111  local_error="Problem class "//trim(number_to_vstring(control_loop%PROBLEM%SPECIFICATION(1),"*",err,error))//" &
2112  & is not valid."
2113  CALL flagerror(local_error,err,error,*999)
2114  END SELECT
2115  ELSE
2116  CALL flagerror("Problem is not associated.",err,error,*999)
2117  ENDIF
2118  ELSE
2119  CALL flagerror("Control loop is not associated.",err,error,*999)
2120  ENDIF
2121  exits("PROBLEM_CONTROL_LOOP_PRE_LOOP")
2122  RETURN
2123 999 errorsexits("PROBLEM_CONTROL_LOOP_PRE_LOOP",err,error)
2124  RETURN 1
2125  END SUBROUTINE problem_control_loop_pre_loop
2126 
2127  !
2128  !================================================================================================================================
2129  !
2130 
2132  SUBROUTINE problem_control_loop_post_loop(CONTROL_LOOP,ERR,ERROR,*)
2133 
2134  !Argument variables
2135  TYPE(control_loop_type), POINTER :: control_loop
2136  INTEGER(INTG), INTENT(OUT) :: err
2137  TYPE(varying_string), INTENT(OUT) :: error
2138  !Local Variables
2139  TYPE(varying_string) :: local_error
2140 
2141  enters("PROBLEM_CONTROL_LOOP_POST_LOOP",err,error,*999)
2142 
2143  IF(ASSOCIATED(control_loop)) THEN
2144  IF(ASSOCIATED(control_loop%PROBLEM)) THEN
2145  IF(.NOT.ALLOCATED(control_loop%PROBLEM%SPECIFICATION)) THEN
2146  CALL flagerror("Problem specification is not allocated.",err,error,*999)
2147  ELSE IF(SIZE(control_loop%PROBLEM%SPECIFICATION,1)<1) THEN
2148  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
2149  ENDIF
2150  SELECT CASE(control_loop%PROBLEM%SPECIFICATION(1))
2151  CASE(problem_elasticity_class)
2152  CALL elasticity_controllooppostloop(control_loop,err,error,*999)
2153  CASE(problem_bioelectrics_class)
2154  CALL bioelectric_control_loop_post_loop(control_loop,err,error,*999)
2155  CASE(problem_fluid_mechanics_class)
2156  CALL fluid_mechanics_control_loop_post_loop(control_loop,err,error,*999)
2157  CASE(problem_electromagnetics_class)
2158  !Do nothing
2159  CASE(problem_classical_field_class)
2160  IF(SIZE(control_loop%PROBLEM%SPECIFICATION,1)<2) THEN
2161  CALL flagerror("Problem specification must have at least two entries.",err,error,*999)
2162  ENDIF
2163  CALL classical_field_control_loop_post_loop(control_loop,err,error,*999)
2164  SELECT CASE(control_loop%PROBLEM%SPECIFICATION(2))
2165  CASE(problem_reaction_diffusion_equation_type)
2166  CALL reaction_diffusion_control_loop_post_loop(control_loop,err,error,*999)
2167  CASE DEFAULT
2168  !do nothing
2169  END SELECT
2170  CASE(problem_fitting_class)
2171  !Do nothing
2172  CASE(problem_modal_class)
2173  !Do nothing
2174  CASE(problem_multi_physics_class)
2175  CALL multi_physics_control_loop_post_loop(control_loop,err,error,*999)
2176  CASE DEFAULT
2177  local_error="The first problem specification of "// &
2178  & trim(numbertovstring(control_loop%problem%specification(1),"*",err,error))// &
2179  & " is not valid."
2180  CALL flagerror(local_error,err,error,*999)
2181  END SELECT
2182  ELSE
2183  CALL flagerror("Problem is not associated.",err,error,*999)
2184  ENDIF
2185  ELSE
2186  CALL flagerror("Control loop is not associated.",err,error,*999)
2187  ENDIF
2188 
2189  exits("PROBLEM_CONTROL_LOOP_POST_LOOP")
2190  RETURN
2191 999 errorsexits("PROBLEM_CONTROL_LOOP_POST_LOOP",err,error)
2192  RETURN 1
2193 
2194  END SUBROUTINE problem_control_loop_post_loop
2195 
2196  !
2197  !================================================================================================================================
2198  !
2199 
2201  SUBROUTINE problem_solver_pre_solve(SOLVER,ERR,ERROR,*)
2202 
2203  !Argument variables
2204  TYPE(solver_type), POINTER :: solver
2205  INTEGER(INTG), INTENT(OUT) :: err
2206  TYPE(varying_string), INTENT(OUT) :: error
2207  !Local Variables
2208  TYPE(control_loop_type), POINTER :: control_loop
2209  TYPE(problem_type), POINTER :: problem
2210  TYPE(solvers_type), POINTER :: solvers
2211  TYPE(varying_string) :: local_error
2212 
2213  enters("PROBLEM_SOLVER_PRE_SOLVE",err,error,*999)
2214 
2215  IF(ASSOCIATED(solver)) THEN
2216  solvers=>solver%SOLVERS
2217  IF(ASSOCIATED(solvers)) THEN
2218  control_loop=>solvers%CONTROL_LOOP
2219  IF(ASSOCIATED(control_loop)) THEN
2220  problem=>control_loop%PROBLEM
2221  IF(ASSOCIATED(problem)) THEN
2222  IF(.NOT.ALLOCATED(problem%SPECIFICATION)) THEN
2223  CALL flagerror("Problem specification is not allocated.",err,error,*999)
2224  ELSE IF(SIZE(problem%SPECIFICATION,1)<1) THEN
2225  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
2226  END IF
2227  SELECT CASE(problem%SPECIFICATION(1))
2228  CASE(problem_elasticity_class)
2229  CALL elasticity_pre_solve(control_loop,solver,err,error,*999)
2230  CASE(problem_bioelectrics_class)
2231  CALL bioelectric_pre_solve(solver,err,error,*999)
2232  CASE(problem_fluid_mechanics_class)
2233  CALL fluid_mechanics_pre_solve(control_loop,solver,err,error,*999)
2234  CASE(problem_electromagnetics_class)
2235  !Do nothing???
2236  CASE(problem_classical_field_class)
2237  CALL classical_field_pre_solve(control_loop,solver,err,error,*999)
2238  CASE(problem_fitting_class)
2239  CALL fitting_pre_solve(control_loop,solver,err,error,*999)
2240  CASE(problem_modal_class)
2241  !Do nothing???
2242  CASE(problem_multi_physics_class)
2243  CALL multi_physics_pre_solve(control_loop,solver,err,error,*999)
2244  CASE DEFAULT
2245  local_error="The problem class of "//trim(number_to_vstring(problem%SPECIFICATION(1),"*",err,error))//" &
2246  & is invalid."
2247  CALL flagerror(local_error,err,error,*999)
2248  END SELECT
2249  ELSE
2250  CALL flagerror("Control loop problem is not associated.",err,error,*999)
2251  ENDIF
2252  ELSE
2253  CALL flagerror("Solvers control loop is not associated.",err,error,*999)
2254  ENDIF
2255  ELSE
2256  CALL flagerror("Solver solvers is not associated.",err,error,*999)
2257  ENDIF
2258  ELSE
2259  CALL flagerror("Solver is not associated.",err,error,*999)
2260  ENDIF
2261 
2262  exits("PROBLEM_SOLVER_PRE_SOLVE")
2263  RETURN
2264 999 errorsexits("PROBLEM_SOLVER_PRE_SOLVE",err,error)
2265  RETURN 1
2266  END SUBROUTINE problem_solver_pre_solve
2267 
2268  !
2269  !================================================================================================================================
2270  !
2271 
2273  SUBROUTINE problem_solver_post_solve(SOLVER,ERR,ERROR,*)
2274 
2275  !Argument variables
2276  TYPE(solver_type), POINTER :: solver
2277  INTEGER(INTG), INTENT(OUT) :: err
2278  TYPE(varying_string), INTENT(OUT) :: error
2279  !Local Variables
2280  TYPE(control_loop_type), POINTER :: control_loop
2281  TYPE(problem_type), POINTER :: problem
2282  TYPE(solvers_type), POINTER :: solvers
2283  TYPE(varying_string) :: local_error
2284 
2285  enters("PROBLEM_SOLVER_POST_SOLVE",err,error,*999)
2286 
2287  IF(ASSOCIATED(solver)) THEN
2288  solvers=>solver%SOLVERS
2289  IF(ASSOCIATED(solvers)) THEN
2290  control_loop=>solvers%CONTROL_LOOP
2291  IF(ASSOCIATED(control_loop)) THEN
2292  problem=>control_loop%PROBLEM
2293  IF(ASSOCIATED(problem)) THEN
2294  IF(.NOT.ALLOCATED(problem%SPECIFICATION)) THEN
2295  CALL flagerror("Problem specification is not allocated.",err,error,*999)
2296  ELSE IF(SIZE(problem%SPECIFICATION,1)<1) THEN
2297  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
2298  END IF
2299  SELECT CASE(problem%SPECIFICATION(1))
2300  CASE(problem_elasticity_class)
2301  CALL elasticity_post_solve(control_loop,solver,err,error,*999)
2302  CASE(problem_bioelectrics_class)
2303  CALL bioelectric_post_solve(solver,err,error,*999)
2304  CASE(problem_fluid_mechanics_class)
2305  CALL fluid_mechanics_post_solve(control_loop,solver,err,error,*999)
2306  CASE(problem_electromagnetics_class)
2307  !Do nothing???
2308  CASE(problem_classical_field_class)
2309 
2310  CALL classical_field_post_solve(control_loop,solver,err,error,*999)
2311  CASE(problem_fitting_class)
2312  CALL fitting_post_solve(control_loop,solver,err,error,*999)
2313  CASE(problem_modal_class)
2314  !Do nothing???
2315  CASE(problem_multi_physics_class)
2316  CALL multi_physics_post_solve(control_loop,solver,err,error,*999)
2317  CASE DEFAULT
2318  local_error="The problem class of "//trim(number_to_vstring(control_loop%PROBLEM%SPECIFICATION(1),"*",err,error))//" &
2319  & is invalid."
2320  CALL flagerror(local_error,err,error,*999)
2321  END SELECT
2322  ELSE
2323  CALL flagerror("Control loop problem is not associated.",err,error,*999)
2324  ENDIF
2325  ELSE
2326  CALL flagerror("Solvers control loop is not associated.",err,error,*999)
2327  ENDIF
2328  ELSE
2329  CALL flagerror("Solver solvers is not associated.",err,error,*999)
2330  ENDIF
2331  ELSE
2332  CALL flagerror("Solver is not associated.",err,error,*999)
2333  ENDIF
2334 
2335  exits("PROBLEM_SOLVER_POST_SOLVE")
2336  RETURN
2337 999 errorsexits("PROBLEM_SOLVER_POST_SOLVE",err,error)
2338  RETURN 1
2339 
2340  END SUBROUTINE problem_solver_post_solve
2341 
2342  !
2343  !================================================================================================================================
2344  !
2345 
2347  SUBROUTINE problem_solver_equations_solve(SOLVER_EQUATIONS,ERR,ERROR,*)
2348 
2349  !Argument variables
2350  TYPE(solver_equations_type), POINTER :: solver_equations
2351  INTEGER(INTG), INTENT(OUT) :: err
2352  TYPE(varying_string), INTENT(OUT) :: error
2353  !Local Variables
2354  TYPE(varying_string) :: local_error
2355 
2356  enters("PROBLEM_SOLVER_EQUATIONS_SOLVE",err,error,*999)
2357 
2358  IF(ASSOCIATED(solver_equations)) THEN
2359  IF(solver_equations%SOLVER_EQUATIONS_FINISHED) THEN
2360  SELECT CASE(solver_equations%TIME_DEPENDENCE)
2361  CASE(solver_equations_static)
2362  SELECT CASE(solver_equations%LINEARITY)
2363  CASE(solver_equations_linear)
2364  CALL problem_solverequationsstaticlinearsolve(solver_equations,err,error,*999)
2365  CASE(solver_equations_nonlinear)
2366  CALL problem_solverequationsstaticnonlinearsolve(solver_equations,err,error,*999)
2367  CASE DEFAULT
2368  local_error="The solver equations linearity of "//trim(number_to_vstring(solver_equations%LINEARITY,"*",err,error))// &
2369  & " is invalid."
2370  CALL flagerror(local_error,err,error,*999)
2371  END SELECT
2372  CASE(solver_equations_quasistatic)
2373  SELECT CASE(solver_equations%LINEARITY)
2374  CASE(solver_equations_linear)
2375  CALL problem_solverequationsquasistaticlinearsolve(solver_equations,err,error,*999)
2376  CASE(solver_equations_nonlinear)
2377  CALL problem_solverequationsquasistaticnonlinearsolve(solver_equations,err,error,*999)
2378  CASE DEFAULT
2379  local_error="The solver equations linearity of "//trim(number_to_vstring(solver_equations%LINEARITY,"*",err,error))// &
2380  & " is invalid."
2381  CALL flagerror(local_error,err,error,*999)
2382  END SELECT
2383  CASE(solver_equations_first_order_dynamic,solver_equations_second_order_dynamic)
2384  SELECT CASE(solver_equations%LINEARITY)
2385  CASE(solver_equations_linear)
2386  CALL problem_solverequationsdynamiclinearsolve(solver_equations,err,error,*999)
2387  CASE(solver_equations_nonlinear)
2388  CALL problem_solverequationsdynamicnonlinearsolve(solver_equations,err,error,*999)
2389  CASE DEFAULT
2390  local_error="The solver equations linearity of "//trim(number_to_vstring(solver_equations%LINEARITY,"*",err,error))// &
2391  & " is invalid."
2392  CALL flagerror(local_error,err,error,*999)
2393  END SELECT
2394  CASE DEFAULT
2395  local_error="The solver equations time dependence type of "// &
2396  & trim(number_to_vstring(solver_equations%TIME_DEPENDENCE,"*",err,error))//" is invalid."
2397  CALL flagerror(local_error,err,error,*999)
2398  END SELECT
2399  ELSE
2400  CALL flagerror("Solver equations have not been finished.",err,error,*999)
2401  ENDIF
2402  ELSE
2403  CALL flagerror("Solver equations is not associated.",err,error,*999)
2404  ENDIF
2405 
2406  exits("PROBLEM_SOLVER_EQUATIONS_SOLVE")
2407  RETURN
2408 999 errorsexits("PROBLEM_SOLVER_EQUATIONS_SOLVE",err,error)
2409  RETURN 1
2410  END SUBROUTINE problem_solver_equations_solve
2411 
2412  !
2413  !================================================================================================================================
2414  !
2415 
2417  SUBROUTINE problem_solverequationsdynamiclinearsolve(SOLVER_EQUATIONS,ERR,ERROR,*)
2418 
2419  !Argument variables
2420  TYPE(solver_equations_type), POINTER :: solver_equations
2421  INTEGER(INTG), INTENT(OUT) :: err
2422  TYPE(varying_string), INTENT(OUT) :: error
2423  !Local Variables
2424  INTEGER(INTG) :: equations_set_idx,loop_idx
2425  REAL(DP) :: current_time,time_increment
2426  TYPE(control_loop_type), POINTER :: control_loop,control_time_loop
2427  TYPE(equations_set_type), POINTER :: equations_set
2428  TYPE(solver_type), POINTER :: solver
2429  TYPE(solver_mapping_type), POINTER :: solver_mapping
2430  TYPE(solvers_type), POINTER :: solvers
2431 
2432  enters("Problem_SolverEquationsDynamicLinearSolve",err,error,*999)
2433 
2434  IF(ASSOCIATED(solver_equations)) THEN
2435  solver=>solver_equations%SOLVER
2436  IF(ASSOCIATED(solver)) THEN
2437  solvers=>solver%SOLVERS
2438  IF(ASSOCIATED(solvers)) THEN
2439  control_loop=>solvers%CONTROL_LOOP
2440  IF(ASSOCIATED(control_loop)) THEN
2441  solver_mapping=>solver_equations%SOLVER_MAPPING
2442  IF(ASSOCIATED(solver_mapping)) THEN
2443  !Make sure the equations sets are up to date
2444  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2445  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2446  !Assemble the equations for linear problems
2447  CALL equations_set_assemble(equations_set,err,error,*999)
2448  ENDDO !equations_set_idx
2449  !Get current control loop times. The control loop may be a sub loop below a time loop, so iterate up
2450  !through loops checking for the time loop
2451  control_time_loop=>control_loop
2452  DO loop_idx=1,control_loop%CONTROL_LOOP_LEVEL
2453  IF(control_time_loop%LOOP_TYPE==problem_control_time_loop_type) THEN
2454  CALL control_loop_current_times_get(control_time_loop,current_time,time_increment,err,error,*999)
2455  EXIT
2456  ENDIF
2457  IF(ASSOCIATED(control_loop%PARENT_LOOP)) THEN
2458  control_time_loop=>control_time_loop%PARENT_LOOP
2459  ELSE
2460  CALL flagerror("Could not find a time control loop.",err,error,*999)
2461  ENDIF
2462  ENDDO
2463  !Set the solver time
2464  CALL solver_dynamic_times_set(solver,current_time,time_increment,err,error,*999)
2465  !Solve for the next time i.e., current time + time increment
2466  CALL solver_solve(solver,err,error,*999)
2467  !Back-substitute to find flux values for linear problems
2468  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2469  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2470  CALL equations_set_backsubstitute(equations_set,solver_equations%BOUNDARY_CONDITIONS,err,error,*999)
2471  ENDDO !equations_set_idx
2472  ELSE
2473  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
2474  ENDIF
2475  ELSE
2476  CALL flagerror("Solvers control loop is not associated.",err,error,*999)
2477  ENDIF
2478  ELSE
2479  CALL flagerror("Solver solvers is not associated.",err,error,*999)
2480  ENDIF
2481  ELSE
2482  CALL flagerror("Solver equations solver is not associated.",err,error,*999)
2483  ENDIF
2484  ELSE
2485  CALL flagerror("Solver equations is not associated.",err,error,*999)
2486  ENDIF
2487 
2488  exits("Problem_SolverEquationsDynamicLinearSolve")
2489  RETURN
2490 999 errorsexits("Problem_SolverEquationsDynamicLinearSolve",err,error)
2491  RETURN 1
2492 
2493  END SUBROUTINE problem_solverequationsdynamiclinearsolve
2494 
2495  !
2496  !================================================================================================================================
2497  !
2498 
2500  SUBROUTINE problem_solverequationsdynamicnonlinearsolve(SOLVER_EQUATIONS,ERR,ERROR,*)
2501 
2502  !Argument variables
2503  TYPE(solver_equations_type), POINTER :: solver_equations
2504  INTEGER(INTG), INTENT(OUT) :: err
2505  TYPE(varying_string), INTENT(OUT) :: error
2506  !Local Variables
2507  INTEGER(INTG) :: equations_set_idx,loop_idx,interface_condition_idx
2508  REAL(DP) :: current_time,time_increment
2509  TYPE(control_loop_type), POINTER :: control_loop,control_time_loop
2510  TYPE(equations_type), POINTER :: equations
2511  TYPE(equations_set_type), POINTER :: equations_set
2512  TYPE(interface_condition_type), POINTER :: interface_condition
2513  TYPE(solver_type), POINTER :: solver
2514  TYPE(dynamic_solver_type), POINTER :: dynamic_solver
2515  TYPE(solver_mapping_type), POINTER :: solver_mapping
2516  TYPE(solvers_type), POINTER :: solvers
2517  TYPE(varying_string) :: local_error
2518 
2519  enters("Problem_SolverEquationsDynamicNonlinearSolve",err,error,*999)
2520 
2521  IF(ASSOCIATED(solver_equations)) THEN
2522  solver=>solver_equations%SOLVER
2523  IF(ASSOCIATED(solver)) THEN
2524  dynamic_solver=>solver%DYNAMIC_SOLVER
2525  IF(ASSOCIATED(dynamic_solver)) THEN
2526  solvers=>solver%SOLVERS
2527  IF(ASSOCIATED(solver)) THEN
2528  control_loop=>solvers%CONTROL_LOOP
2529  IF(ASSOCIATED(control_loop)) THEN
2530  solver_mapping=>solver_equations%SOLVER_MAPPING
2531  IF(ASSOCIATED(solver_mapping)) THEN
2532  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2533  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2534  IF(dynamic_solver%RESTART.OR..NOT.dynamic_solver%SOLVER_INITIALISED) then!.OR.DYNAMIC_SOLVER%FSI) THEN
2535  !If we need to restart or we haven't initialised yet or we have an FSI scheme, make sure the equations sets are up to date
2536  equations=>equations_set%EQUATIONS
2537  IF(ASSOCIATED(equations)) THEN
2538  SELECT CASE(equations%LINEARITY)
2539  CASE(equations_linear)
2540  !Assemble the equations
2541  CALL equations_set_assemble(equations_set,err,error,*999)
2542  CASE(equations_nonlinear)
2543  !Evaluate the residuals
2544  CALL equations_set_residual_evaluate(equations_set,err,error,*999)
2545  CASE(equations_nonlinear_bcs)
2546  CALL flagerror("Not implemented.",err,error,*999)
2547  CASE DEFAULT
2548  local_error="The equations linearity type of "// &
2549  & trim(number_to_vstring(equations%LINEARITY,"*",err,error))// &
2550  & " is invalid."
2551  CALL flagerror(local_error,err,error,*999)
2552  END SELECT
2553  ELSE
2554  CALL flagerror("Equations set equations is not associated.",err,error,*999)
2555  ENDIF
2556  ENDIF
2557  ENDDO !equations_set_idx
2558  !Make sure the interface matrices are up to date
2559  DO interface_condition_idx=1,solver_mapping%NUMBER_OF_INTERFACE_CONDITIONS
2560  interface_condition=>solver_mapping%INTERFACE_CONDITIONS(interface_condition_idx)%PTR
2561  CALL interface_condition_assemble(interface_condition,err,error,*999)
2562  ENDDO !interface_condition_idx
2563  !Get current control loop times. The control loop may be a sub loop below a time loop, so iterate up
2564  !through loops checking for the time loop
2565  control_time_loop=>control_loop
2566  DO loop_idx=1,control_loop%CONTROL_LOOP_LEVEL
2567  IF(control_time_loop%LOOP_TYPE==problem_control_time_loop_type) THEN
2568  CALL control_loop_current_times_get(control_time_loop,current_time,time_increment,err,error,*999)
2569  EXIT
2570  ENDIF
2571  IF(ASSOCIATED(control_loop%PARENT_LOOP)) THEN
2572  control_time_loop=>control_time_loop%PARENT_LOOP
2573  ELSE
2574  CALL flagerror("Could not find a time control loop.",err,error,*999)
2575  ENDIF
2576  ENDDO
2577  !Set the solver time
2578  CALL solver_dynamic_times_set(solver,current_time,time_increment,err,error,*999)
2579  !Solve for the next time i.e., current time + time increment
2580  CALL solver_solve(solver,err,error,*999)
2581  ELSE
2582  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
2583  ENDIF
2584  ELSE
2585  CALL flagerror("Solvers control loop is not associated.",err,error,*999)
2586  ENDIF
2587  ELSE
2588  CALL flagerror("Solver solvers is not associated.",err,error,*999)
2589  ENDIF
2590  ELSE
2591  CALL flagerror("Solver dynamic solver is not associated.",err,error,*999)
2592  ENDIF
2593  ELSE
2594  CALL flagerror("Solver equations solver is not associated.",err,error,*999)
2595  ENDIF
2596  ELSE
2597  CALL flagerror("Solver equations is not associated.",err,error,*999)
2598  ENDIF
2599 
2600  exits("Problem_SolverEquationsDynamicNonlinearSolve")
2601  RETURN
2602 999 errors("Problem_SolverEquationsDynamicNonlinearSolve",err,error)
2603  exits("Problem_SolverEquationsDynamicNonlinearSolve")
2604  RETURN 1
2605 
2606  END SUBROUTINE problem_solverequationsdynamicnonlinearsolve
2607 
2608  !
2609  !================================================================================================================================
2610  !
2611 
2613  SUBROUTINE problem_solverequationsquasistaticlinearsolve(SOLVER_EQUATIONS,ERR,ERROR,*)
2614 
2615  !Argument variables
2616  TYPE(solver_equations_type), POINTER :: solver_equations
2617  INTEGER(INTG), INTENT(OUT) :: err
2618  TYPE(varying_string), INTENT(OUT) :: error
2619  !Local Variables
2620  INTEGER(INTG) :: equations_set_idx
2621 ! REAL(DP) :: CURRENT_TIME,TIME_INCREMENT
2622  TYPE(control_loop_type), POINTER :: control_loop
2623  TYPE(equations_set_type), POINTER :: equations_set
2624  TYPE(solver_type), POINTER :: solver
2625  TYPE(solver_mapping_type), POINTER :: solver_mapping
2626  TYPE(solvers_type), POINTER :: solvers
2627 
2628  enters("Problem_SolverEquationsQuasistaticLinearSolve",err,error,*999)
2629 
2630  IF(ASSOCIATED(solver_equations)) THEN
2631  solver=>solver_equations%SOLVER
2632  IF(ASSOCIATED(solver)) THEN
2633  solvers=>solver%SOLVERS
2634  IF(ASSOCIATED(solvers)) THEN
2635  control_loop=>solvers%CONTROL_LOOP
2636  IF(ASSOCIATED(control_loop)) THEN
2637  solver_mapping=>solver_equations%SOLVER_MAPPING
2638  IF(ASSOCIATED(solver_mapping)) THEN
2639  !Make sure the equations sets are up to date
2640  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2641  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2642  !CALL EQUATIONS_SET_FIXED_CONDITIONS_APPLY(EQUATIONS_SET,ERR,ERROR,*999)
2643  !Assemble the equations for linear problems
2644  CALL equations_set_assemble(equations_set,err,error,*999)
2645  ENDDO !equations_set_idx
2646 ! !Get current control loop times
2647 ! CALL CONTROL_LOOP_CURRENT_TIMES_GET(CONTROL_LOOP,CURRENT_TIME,TIME_INCREMENT,ERR,ERROR,*999)
2648  !Solve for the current time
2649  CALL solver_solve(solver,err,error,*999)
2650  !Back-substitute to find flux values for linear problems
2651  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2652  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2653  CALL equations_set_backsubstitute(equations_set,solver_equations%BOUNDARY_CONDITIONS,err,error,*999)
2654  ENDDO !equations_set_idx
2655  ELSE
2656  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
2657  ENDIF
2658  ELSE
2659  CALL flagerror("Solvers control loop is not associated.",err,error,*999)
2660  ENDIF
2661  ELSE
2662  CALL flagerror("Solver solvers is not associated.",err,error,*999)
2663  ENDIF
2664  ELSE
2665  CALL flagerror("Solver equations solver is not associated.",err,error,*999)
2666  ENDIF
2667  ELSE
2668  CALL flagerror("Solver equations is not associated.",err,error,*999)
2669  ENDIF
2670 
2671  exits("Problem_SolverEquationsQuasistaticLinearSolve")
2672  RETURN
2673 999 errors("Problem_SolverEquationsQuasistaticLinearSolve",err,error)
2674  exits("Problem_SolverEquationsQuasistaticLinearSolve")
2675  RETURN 1
2676 
2677  END SUBROUTINE problem_solverequationsquasistaticlinearsolve
2678 
2679  !
2680  !================================================================================================================================
2681  !
2682 
2684  SUBROUTINE problem_solverequationsquasistaticnonlinearsolve(SOLVER_EQUATIONS,ERR,ERROR,*)
2685 
2686  !Argument variables
2687  TYPE(solver_equations_type), POINTER :: solver_equations
2688  INTEGER(INTG), INTENT(OUT) :: err
2689  TYPE(varying_string), INTENT(OUT) :: error
2690  !Local Variables
2691  INTEGER(INTG) :: equations_set_idx
2692  TYPE(control_loop_type), POINTER :: control_loop
2693  TYPE(equations_set_type), POINTER :: equations_set
2694  TYPE(solver_type), POINTER :: solver
2695  TYPE(solver_mapping_type), POINTER :: solver_mapping
2696  TYPE(solvers_type), POINTER :: solvers
2697 
2698  enters("Problem_SolverEquationsQuasistaticNonlinearSolve",err,error,*999)
2699 
2700  IF(ASSOCIATED(solver_equations)) THEN
2701  solver=>solver_equations%SOLVER
2702  IF(ASSOCIATED(solver)) THEN
2703  solvers=>solver%SOLVERS
2704  IF(ASSOCIATED(solvers)) THEN
2705  control_loop=>solvers%CONTROL_LOOP
2706  IF(ASSOCIATED(control_loop)) THEN
2707  solver_mapping=>solver_equations%SOLVER_MAPPING
2708  IF(ASSOCIATED(solver_mapping)) THEN
2709  !Make sure the equations sets are up to date
2710  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2711  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2712  !CALL EQUATIONS_SET_FIXED_CONDITIONS_APPLY(EQUATIONS_SET,ERR,ERROR,*999)
2713  !Assemble the equations for linear problems
2714  CALL equations_set_assemble(equations_set,err,error,*999)
2715  ENDDO !equations_set_idx
2716  ! sander - this gives an error, and current time seems to be updated without it
2717  !Get current control loop times
2718  !CALL CONTROL_LOOP_CURRENT_TIMES_GET(CONTROL_LOOP,CURRENT_TIME,TIME_INCREMENT,ERR,ERROR,*999)
2719  !Set the solver time
2720  !CALL SOLVER_DYNAMIC_TIMES_SET(SOLVER,CURRENT_TIME,TIME_INCREMENT,ERR,ERROR,*999)
2721  !Solve for the next time i.e., current time + time increment
2722  CALL solver_solve(solver,err,error,*999)
2723  ELSE
2724  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
2725  ENDIF
2726  ELSE
2727  CALL flagerror("Solvers control loop is not associated.",err,error,*999)
2728  ENDIF
2729  ELSE
2730  CALL flagerror("Solver solvers is not associated.",err,error,*999)
2731  ENDIF
2732  ELSE
2733  CALL flagerror("Solver equations solver is not associated.",err,error,*999)
2734  ENDIF
2735  ELSE
2736  CALL flagerror("Solver equations is not associated.",err,error,*999)
2737  ENDIF
2738 
2739  exits("Problem_SolverEquationsQuasistaticNonlinearSolve")
2740  RETURN
2741 999 errors("Problem_SolverEquationsQuasistaticNonlinearSolve",err,error)
2742  exits("Problem_SolverEquationsQuasistaticNonlinearSolve")
2743  RETURN 1
2744 
2745  END SUBROUTINE problem_solverequationsquasistaticnonlinearsolve
2746 
2747  !
2748  !================================================================================================================================
2749  !
2750 
2752  SUBROUTINE problem_solverequationsstaticlinearsolve(SOLVER_EQUATIONS,ERR,ERROR,*)
2753 
2754  !Argument variables
2755  TYPE(solver_equations_type), POINTER :: solver_equations
2756  INTEGER(INTG), INTENT(OUT) :: err
2757  TYPE(varying_string), INTENT(OUT) :: error
2758  !Local Variables
2759  INTEGER(INTG) :: equations_set_idx,interface_condition_idx
2760  TYPE(equations_set_type), POINTER :: equations_set
2761  TYPE(interface_condition_type), POINTER :: interface_condition
2762  TYPE(solver_type), POINTER :: solver
2763  TYPE(solver_mapping_type), POINTER :: solver_mapping
2764 
2765 #ifdef TAUPROF
2766  CHARACTER(12) :: cvar
2767  INTEGER :: phase(2) = [ 0, 0 ]
2768  SAVE phase
2769 #endif
2770 
2771  enters("Problem_SolverEquationsStaticLinearSolve",err,error,*999)
2772 
2773  IF(ASSOCIATED(solver_equations)) THEN
2774  solver=>solver_equations%SOLVER
2775  IF(ASSOCIATED(solver)) THEN
2776  solver_mapping=>solver_equations%SOLVER_MAPPING
2777  IF(ASSOCIATED(solver_mapping)) THEN
2778  !Make sure the equations sets are up to date
2779  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2780 #ifdef TAUPROF
2781  WRITE (cvar,'(a8,i2)') 'Assemble',equations_set_idx
2782  CALL tau_phase_create_dynamic(phase,cvar)
2783  CALL tau_phase_start(phase)
2784 #endif
2785  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2786  !CALL EQUATIONS_SET_FIXED_CONDITIONS_APPLY(EQUATIONS_SET,ERR,ERROR,*999)
2787  !Assemble the equations for linear problems
2788  CALL equations_set_assemble(equations_set,err,error,*999)
2789 #ifdef TAUPROF
2790  CALL tau_phase_stop(phase)
2791 #endif
2792  ENDDO !equations_set_idx
2793  !Make sure the interface matrices are up to date
2794  DO interface_condition_idx=1,solver_mapping%NUMBER_OF_INTERFACE_CONDITIONS
2795 #ifdef TAUPROF
2796  WRITE (cvar,'(a8,i2)') 'Interface',interface_condition_idx
2797  CALL tau_phase_create_dynamic(phase,cvar)
2798  CALL tau_phase_start(phase)
2799 #endif
2800  interface_condition=>solver_mapping%INTERFACE_CONDITIONS(interface_condition_idx)%PTR
2801  CALL interface_condition_assemble(interface_condition,err,error,*999)
2802 #ifdef TAUPROF
2803  CALL tau_phase_stop(phase)
2804 #endif
2805  ENDDO !interface_condition_idx
2806 
2807  !Solve
2808  CALL solver_solve(solver,err,error,*999)
2809 
2810 #ifdef TAUPROF
2811  CALL tau_static_phase_start('EQUATIONS_SET_BACKSUBSTITUTE()')
2812 #endif
2813  !Back-substitute to find flux values for linear problems
2814  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2815  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2816  CALL equations_set_backsubstitute(equations_set,solver_equations%BOUNDARY_CONDITIONS,err,error,*999)
2817  ENDDO !equations_set_idx
2818 #ifdef TAUPROF
2819  CALL tau_static_phase_stop('EQUATIONS_SET_BACKSUBSTITUTE()')
2820 #endif
2821  ELSE
2822  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
2823  ENDIF
2824  ELSE
2825  CALL flagerror("Solver equations solver is not associated.",err,error,*999)
2826  ENDIF
2827  ELSE
2828  CALL flagerror("Solver equations is not associated.",err,error,*999)
2829  ENDIF
2830 
2831  exits("Problem_SolverEquationsStaticLinearSolve")
2832  RETURN
2833 999 errorsexits("Problem_SolverEquationsStaticLinearSolve",err,error)
2834  RETURN 1
2835 
2836  END SUBROUTINE problem_solverequationsstaticlinearsolve
2837 
2838  !
2839  !================================================================================================================================
2840  !
2841 
2843  SUBROUTINE problem_solverequationsstaticnonlinearsolve(SOLVER_EQUATIONS,ERR,ERROR,*)
2844 
2845  !Argument variables
2846  TYPE(solver_equations_type), POINTER :: solver_equations
2847  INTEGER(INTG), INTENT(OUT) :: err
2848  TYPE(varying_string), INTENT(OUT) :: error
2849  !Local Variables
2850  INTEGER(INTG) :: equations_set_idx,interface_condition_idx
2851  TYPE(equations_set_type), POINTER :: equations_set
2852  TYPE(equations_type), POINTER :: equations
2853  TYPE(interface_condition_type), POINTER :: interface_condition
2854  TYPE(solver_type), POINTER :: solver
2855  TYPE(solver_mapping_type), POINTER :: solver_mapping
2856 
2857 #ifdef TAUPROF
2858  CHARACTER(12) :: cvar
2859  INTEGER :: phase(2) = [ 0, 0 ]
2860  SAVE phase
2861 #endif
2862  enters("Problem_SolverEquationsStaticNonlinearSolve",err,error,*999)
2863 
2864  IF(ASSOCIATED(solver_equations)) THEN
2865  solver=>solver_equations%SOLVER
2866  IF(ASSOCIATED(solver)) THEN
2867  solver_mapping=>solver_equations%SOLVER_MAPPING
2868  IF(ASSOCIATED(solver_mapping)) THEN
2869  !Apply boundary conditition
2870  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2871  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2872  !Assemble the equations set
2873  CALL equations_set_assemble(equations_set,err,error,*999)
2874  ENDDO !equations_set_idx
2875  !Make sure the interface matrices are up to date
2876  DO interface_condition_idx=1,solver_mapping%NUMBER_OF_INTERFACE_CONDITIONS
2877 #ifdef TAUPROF
2878  WRITE (cvar,'(a8,i2)') 'Interface',interface_condition_idx
2879  CALL tau_phase_create_dynamic(phase,cvar)
2880  CALL tau_phase_start(phase)
2881 #endif
2882  interface_condition=>solver_mapping%INTERFACE_CONDITIONS(interface_condition_idx)%PTR
2883  CALL interface_condition_assemble(interface_condition,err,error,*999)
2884 #ifdef TAUPROF
2885  CALL tau_phase_stop(phase)
2886 #endif
2887  ENDDO !interface_condition_idx
2888  !Solve
2889  CALL solver_solve(solver,err,error,*999)
2890  !Update the rhs field variable with residuals or backsubstitute for any linear
2891  !equations sets
2892  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
2893  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
2894  equations=>equations_set%EQUATIONS
2895  IF(ASSOCIATED(equations)) THEN
2896  SELECT CASE(equations%LINEARITY)
2897  CASE(equations_linear,equations_nonlinear_bcs)
2898  CALL equations_set_backsubstitute(equations_set,solver_equations%BOUNDARY_CONDITIONS,err,error,*999)
2899  CASE(equations_nonlinear)
2900  CALL equations_set_nonlinear_rhs_update(equations_set,solver_equations%BOUNDARY_CONDITIONS,err,error,*999)
2901  CASE DEFAULT
2902  CALL flagerror("Invalid linearity for equations set equations",err,error,*999)
2903  END SELECT
2904  ELSE
2905  CALL flagerror("Equations set equations is not associated.",err,error,*999)
2906  ENDIF
2907  ENDDO !equations_set_idx
2908  ELSE
2909  CALL flagerror("Solver equations solver mapping not associated.",err,error,*999)
2910  ENDIF
2911  ELSE
2912  CALL flagerror("Solver equations solver is not associated.",err,error,*999)
2913  ENDIF
2914  ELSE
2915  CALL flagerror("Solver equations is not associated.",err,error,*999)
2916  ENDIF
2917 
2918  exits("Problem_SolverEquationsStaticNonlinearSolve")
2919  RETURN
2920 999 errorsexits("Problem_SolverEquationsStaticNonlinearSolve",err,error)
2921  RETURN 1
2922 
2923  END SUBROUTINE problem_solverequationsstaticnonlinearsolve
2924 
2925  !
2926  !================================================================================================================================
2927  !
2928 
2929 
2931  SUBROUTINE problem_solver_solve(SOLVER,ERR,ERROR,*)
2932 
2933  !Argument variables
2934  TYPE(solver_type), POINTER :: solver
2935  INTEGER(INTG), INTENT(OUT) :: err
2936  TYPE(varying_string), INTENT(OUT) :: error
2937  !Local Variables
2938 
2939  enters("PROBLEM_SOLVER_SOLVE",err,error,*999)
2940 
2941  IF(ASSOCIATED(solver)) THEN
2942 
2943  IF(solver%OUTPUT_TYPE>=solver_progress_output) THEN
2944  CALL write_string(general_output_type,"",err,error,*999)
2945  CALL write_string_value(general_output_type,"Solver: ",solver%LABEL,err,error,*999)
2946  CALL write_string_value(general_output_type," Solver index = ",solver%GLOBAL_NUMBER,err,error,*999)
2947  ENDIF
2948 
2949 #ifdef TAUPROF
2950  CALL tau_static_phase_start('Pre solve')
2951 #endif
2952  CALL problem_solver_pre_solve(solver,err,error,*999)
2953 #ifdef TAUPROF
2954  CALL tau_static_phase_stop('Pre solve')
2955 
2956  CALL tau_static_phase_start('Solve')
2957 #endif
2958 
2959  IF(ASSOCIATED(solver%SOLVER_EQUATIONS)) THEN
2960  !A solver with solver equations.
2961  CALL problem_solver_equations_solve(solver%SOLVER_EQUATIONS,err,error,*999)
2962  ELSE
2963  !Check for other equations.
2964  IF(ASSOCIATED(solver%CELLML_EQUATIONS)) THEN
2965  !A solver with CellML equations.
2966  CALL problem_cellml_equations_solve(solver%CELLML_EQUATIONS,err,error,*999)
2967  ELSEIF(solver%SOLVE_TYPE==solver_geometric_transformation_type) THEN
2968  CALL problem_solvergeometrictransformationsolve(solver%geometricTransformationSolver,err,error,*999)
2969  ELSE
2970  CALL flagerror("Solver does not have any equations associated.",err,error,*999)
2971  ENDIF
2972  ENDIF
2973 
2974 #ifdef TAUPROF
2975  CALL tau_static_phase_stop('Solve')
2976 
2977  CALL tau_static_phase_start('Post solve')
2978 #endif
2979  CALL problem_solver_post_solve(solver,err,error,*999)
2980 #ifdef TAUPROF
2981  CALL tau_static_phase_stop('Post solve')
2982 #endif
2983 
2984  ELSE
2985  CALL flagerror("Solver is not associated.",err,error,*999)
2986  ENDIF
2987 
2988  exits("PROBLEM_SOLVER_SOLVE")
2989  RETURN
2990 999 errorsexits("PROBLEM_SOLVER_SOLVE",err,error)
2991  RETURN 1
2992 
2993  END SUBROUTINE problem_solver_solve
2994 
2995  !
2996  !================================================================================================================================
2997  !
2998 
3000  SUBROUTINE problem_solvers_destroy(PROBLEM,ERR,ERROR,*)
3001 
3002  !Argument variables
3003  TYPE(problem_type), POINTER :: problem
3004  INTEGER(INTG), INTENT(OUT) :: err
3005  TYPE(varying_string), INTENT(OUT) :: error
3006  !Local Variables
3007 
3008  enters("PROBLEM_SOLVERS_DESTROY",err,error,*999)
3009 
3010  IF(ASSOCIATED(problem)) THEN
3011  IF(ASSOCIATED(problem%CONTROL_LOOP)) THEN
3012  CALL control_loop_solvers_destroy(problem%CONTROL_LOOP,err,error,*999)
3013  ELSE
3014  CALL flagerror("Problem control loop is not associated.",err,error,*999)
3015  ENDIF
3016  ELSE
3017  CALL flagerror("Problem is not associated.",err,error,*999)
3018  ENDIF
3019 
3020  exits("PROBLEM_SOLVERS_DESTROY")
3021  RETURN
3022 999 errorsexits("PROBLEM_SOLVERS_DESTROY",err,error)
3023  RETURN 1
3024  END SUBROUTINE problem_solvers_destroy
3025 
3026  !
3027  !================================================================================================================================
3028  !
3029 
3031  SUBROUTINE problem_solverequationsboundaryconditionsanalytic(SOLVER_EQUATIONS,ERR,ERROR,*)
3032 
3033  !Argument variables
3034  TYPE(solver_equations_type), POINTER :: solver_equations
3035  INTEGER(INTG), INTENT(OUT) :: err
3036  TYPE(varying_string), INTENT(OUT) :: error
3037  !Local Variables
3038  INTEGER(INTG) :: equations_set_idx
3039  TYPE(boundary_conditions_type), POINTER :: boundary_conditions
3040  TYPE(solver_mapping_type), POINTER :: solver_mapping
3041  TYPE(equations_set_type), POINTER :: equations_set
3042 
3043  enters("Problem_SolverEquationsBoundaryConditionsAnalytic",err,error,*999)
3044 
3045  IF(ASSOCIATED(solver_equations)) THEN
3046  IF(solver_equations%SOLVER_EQUATIONS_FINISHED) THEN
3047  boundary_conditions=>solver_equations%BOUNDARY_CONDITIONS
3048  IF(ASSOCIATED(boundary_conditions)) THEN
3049  solver_mapping=>solver_equations%SOLVER_MAPPING
3050  IF(ASSOCIATED(solver_mapping)) THEN
3051  DO equations_set_idx=1,solver_mapping%NUMBER_OF_EQUATIONS_SETS
3052  equations_set=>solver_mapping%EQUATIONS_SETS(equations_set_idx)%PTR
3053  IF(ASSOCIATED(equations_set)) THEN
3054  CALL equations_set_boundary_conditions_analytic(equations_set,boundary_conditions,err,error,*999)
3055  ELSE
3056  CALL flagerror("Equations set is not associated for index "//trim(number_to_vstring(equations_set_idx,"*", &
3057  & err,error))//".",err,error,*999)
3058  ENDIF
3059  ENDDO
3060  ELSE
3061  CALL flagerror("Solver equations solver mapping is not associated.",err,error,*999)
3062  ENDIF
3063  ELSE
3064  CALL flagerror("Solver equations boundary conditions are not associated.",err,error,*999)
3065  ENDIF
3066  ELSE
3067  CALL flagerror("Solver equations has not been finished.",err,error,*999)
3068  ENDIF
3069  ELSE
3070  CALL flagerror("Solver equations is not associated.",err,error,*999)
3071  ENDIF
3072 
3073  exits("Problem_SolverEquationsBoundaryConditionsAnalytic")
3074  RETURN
3075 999 errors("Problem_SolverEquationsBoundaryConditionsAnalytic",err,error)
3076  exits("Problem_SolverEquationsBoundaryConditionsAnalytic")
3077  RETURN 1
3078 
3079  END SUBROUTINE problem_solverequationsboundaryconditionsanalytic
3080 
3081  !
3082  !================================================================================================================================
3083  !
3084 
3086  SUBROUTINE problem_solver_equations_create_finish(PROBLEM,ERR,ERROR,*)
3087 
3088  !Argument variables
3089  TYPE(problem_type), POINTER :: problem
3090  INTEGER(INTG), INTENT(OUT) :: err
3091  TYPE(varying_string), INTENT(OUT) :: error
3092  !Local Variables
3093  TYPE(problem_setup_type) :: problem_setup_info
3094 
3095  enters("PROBLEM_SOLVER_EQUATIONS_CREATE_FINISH",err,error,*999)
3096 
3097  IF(ASSOCIATED(problem)) THEN
3098  !Initialise the problem setup information
3099  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
3100  problem_setup_info%SETUP_TYPE=problem_setup_solver_equations_type
3101  problem_setup_info%ACTION_TYPE=problem_setup_finish_action
3102  !Finish problem specific startup
3103  CALL problem_setup(problem,problem_setup_info,err,error,*999)
3104  !Finalise the problem setup information
3105  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
3106  ELSE
3107  CALL flagerror("Problem is not associated.",err,error,*999)
3108  ENDIF
3109 
3110  exits("PROBLEM_SOLVER_EQUATIONS_CREATE_FINISH")
3111  RETURN
3112 999 errorsexits("PROBLEM_SOLVER_EQUATIONS_CREATE_FINISH",err,error)
3113  RETURN 1
3114  END SUBROUTINE problem_solver_equations_create_finish
3115 
3116  !
3117  !================================================================================================================================
3118  !
3119 
3125  SUBROUTINE problem_solver_equations_create_start(PROBLEM,ERR,ERROR,*)
3126 
3127  !Argument variablesg
3128  TYPE(problem_type), POINTER :: problem
3129  INTEGER(INTG), INTENT(OUT) :: err
3130  TYPE(varying_string), INTENT(OUT) :: error
3131  !Local Variables
3132  TYPE(problem_setup_type) :: problem_setup_info
3133 
3134  enters("PROBLEM_SOLVER_EQUATIONS_CREATE_START",err,error,*999)
3135 
3136  IF(ASSOCIATED(problem)) THEN
3137  !Initialise the problem setup information
3138  CALL problem_setup_initialise(problem_setup_info,err,error,*999)
3139  problem_setup_info%SETUP_TYPE=problem_setup_solver_equations_type
3140  problem_setup_info%ACTION_TYPE=problem_setup_start_action
3141  !Start the problem specific control setup
3142  CALL problem_setup(problem,problem_setup_info,err,error,*999)
3143  !Finalise the problem setup information
3144  CALL problem_setup_finalise(problem_setup_info,err,error,*999)
3145  ELSE
3146  CALL flagerror("Problem is not associated.",err,error,*999)
3147  ENDIF
3148 
3149  exits("PROBLEM_SOLVER_EQUATIONS_CREATE_START")
3150  RETURN
3151 999 errorsexits("PROBLEM_SOLVER_EQUATIONS_CREATE_START",err,error)
3152  RETURN 1
3153  END SUBROUTINE problem_solver_equations_create_start
3154 
3155  !
3156  !================================================================================================================================
3157  !
3158 
3159  !!TODO: this should be removed - just call the solver equations destroy directly???
3160 
3162  SUBROUTINE problem_solver_equations_destroy(PROBLEM,ERR,ERROR,*)
3163 
3164  !Argument variables
3165  TYPE(problem_type), POINTER :: problem
3166  INTEGER(INTG), INTENT(OUT) :: err
3167  TYPE(varying_string), INTENT(OUT) :: error
3168  !Local Variables
3169  TYPE(control_loop_type), POINTER :: control_loop
3170 
3171  enters("PROBLEM_SOLVER_EQUATIONS_DESTROY",err,error,*999)
3172 
3173  IF(ASSOCIATED(problem)) THEN
3174  control_loop=>problem%CONTROL_LOOP
3175  IF(ASSOCIATED(control_loop)) THEN
3176  CALL control_loop_solver_equations_destroy(control_loop,err,error,*999)
3177  ELSE
3178  CALL flagerror("Problem control loop is not associated.",err,error,*999)
3179  ENDIF
3180  ELSE
3181  CALL flagerror("Problem is not associated.",err,error,*999)
3182  ENDIF
3183 
3184  exits("PROBLEM_SOLVER_EQUATIONS_DESTROY")
3185  RETURN
3186 999 errorsexits("PROBLEM_SOLVER_EQUATIONS_DESTROY",err,error)
3187  RETURN 1
3188  END SUBROUTINE problem_solver_equations_destroy
3189 
3190  !
3191  !================================================================================================================================
3192  !
3193 
3195  SUBROUTINE problem_solvergeometrictransformationsolve(geometricTransformationSolver,err,error,*) !\todo: Add rotation operations.
3196 
3197  !Argument variables
3198  TYPE(geometrictransformationsolvertype), POINTER :: geometrictransformationsolver
3199  INTEGER(INTG), INTENT(OUT) :: err
3200  TYPE(varying_string), INTENT(OUT) :: error
3201  !Local Variables
3202  TYPE(field_variable_type), POINTER :: fieldvariable
3203  TYPE(solver_type), POINTER :: solver
3204  TYPE(solvers_type), POINTER :: solvers
3205  TYPE(control_loop_type), POINTER :: controlloop
3206  TYPE(control_loop_load_increment_type), POINTER :: loadincrementloop
3207  TYPE(control_loop_simple_type), POINTER :: simpleloop
3208  TYPE(control_loop_fixed_type), POINTER :: fixedloop
3209  TYPE(control_loop_while_type), POINTER :: whileloop
3210  INTEGER(INTG) :: componentidx,versionidx,derivativeidx,nodeidx,nogeomcomp
3211  INTEGER(INTG) :: localnodenumber,usernodenumber,incrementidx,iterationnumber
3212  REAL(DP) :: nodalparameters(3),nodalparameterstrans(3),transformationmatrix(4,4)
3213  TYPE(domain_type), POINTER :: domain
3214  TYPE(domain_nodes_type), POINTER :: domainnodes
3215  LOGICAL :: transformbc=.false.,samebases=.true.
3216 
3217  enters("Problem_SolverGeometricTransformationSolve",err,error,*999)
3218 
3219  IF(ASSOCIATED(geometrictransformationsolver)) THEN
3220  IF(ASSOCIATED(geometrictransformationsolver%field)) THEN
3221  fieldvariable=>geometrictransformationsolver%field%VARIABLE_TYPE_MAP(geometrictransformationsolver%fieldVariableType)%PTR
3222  IF(ASSOCIATED(fieldvariable%PARAMETER_SETS%SET_TYPE(field_boundary_conditions_set_type)%PTR)) transformbc=.true. !if the BC is defined on the field variable to be transformed
3223  nogeomcomp=SIZE(geometrictransformationsolver%transformationMatrices,1)-1 ! Number of geometric components
3224  !**********************************************************************************************************************
3225  !Determine iteration/load increment number
3226  IF(geometrictransformationsolver%numberOfIncrements>1) THEN
3227  solver=>geometrictransformationsolver%solver
3228  IF(ASSOCIATED(solver)) THEN
3229  solvers=>solver%SOLVERS
3230  IF(ASSOCIATED(solvers)) THEN
3231  controlloop=>solvers%CONTROL_LOOP
3232  IF(ASSOCIATED(controlloop)) THEN
3233  SELECT CASE(controlloop%LOOP_TYPE)
3234  CASE(problem_control_simple_type)
3235  simpleloop=>controlloop%SIMPLE_LOOP
3236  IF(ASSOCIATED(simpleloop)) THEN
3237  iterationnumber=1
3238  ELSE
3239  CALL flagerror("Simple loop is not associated.",err,error,*999)
3240  ENDIF
3241  CASE(problem_control_fixed_loop_type)
3242  fixedloop=>controlloop%FIXED_LOOP
3243  IF(ASSOCIATED(fixedloop)) THEN
3244  iterationnumber=fixedloop%ITERATION_NUMBER
3245  ELSE
3246  CALL flagerror("Fixed loop is not associated.",err,error,*999)
3247  ENDIF
3248  CASE(problem_control_time_loop_type)
3249  CALL flagerror("Geometric transformation for time loop is not implemented.",err,error,*999)
3250  CASE(problem_control_while_loop_type)
3251  whileloop=>controlloop%WHILE_LOOP
3252  IF(ASSOCIATED(whileloop)) THEN
3253  iterationnumber=whileloop%ITERATION_NUMBER
3254  ELSE
3255  CALL flagerror("Simple loop is not associated.",err,error,*999)
3256  ENDIF
3257  CASE(problem_control_load_increment_loop_type)
3258  loadincrementloop=>controlloop%LOAD_INCREMENT_LOOP
3259  IF(ASSOCIATED(loadincrementloop)) THEN
3260  iterationnumber=loadincrementloop%ITERATION_NUMBER
3261  ELSE
3262  CALL flagerror("Load increment loop is not associated.",err,error,*999)
3263  ENDIF
3264  END SELECT
3265  IF(iterationnumber>geometrictransformationsolver%numberOfIncrements) THEN
3266  !If load increment is not specified for that iteration, loop around
3267  incrementidx=mod(iterationnumber-1,geometrictransformationsolver%numberOfIncrements)+1
3268  ELSE
3269  incrementidx=iterationnumber !If load increment is specified for that iteration, use that load increment
3270  ENDIF
3271  ELSE
3272  CALL flagerror("Control loop is not associated.",err,error,*999)
3273  ENDIF
3274  ELSE
3275  CALL flagerror("Solvers is not associated.",err,error,*999)
3276  ENDIF
3277  ELSE
3278  CALL flagerror("Solver is not associated.",err,error,*999)
3279  ENDIF
3280  ELSE
3281  incrementidx=1
3282  ENDIF
3283  !Determine the transformation matrix to use
3284  IF(geometrictransformationsolver%arbitraryPath .OR. geometrictransformationsolver%numberOfIncrements==1) THEN
3285  transformationmatrix(1:nogeomcomp+1,1:nogeomcomp+1)=geometrictransformationsolver%transformationMatrices &
3286  & (1:nogeomcomp+1,1:nogeomcomp+1,incrementidx)
3287  ELSE !If need to scale transformation matrix (i.e. transformation applied through several load increment.)
3288  IF(incrementidx==1) THEN ! 1st load increment, rotation is applied
3289  transformationmatrix(1:nogeomcomp,1:nogeomcomp)=geometrictransformationsolver%transformationMatrices &
3290  & (1:nogeomcomp,1:nogeomcomp,1)
3291  ELSE !No rotation operation in any other load increments
3292  DO componentidx=1,nogeomcomp
3293  transformationmatrix(componentidx,componentidx)=1.0_dp
3294  ENDDO !componentIdx
3295  ENDIF
3296  !Translation is scaled for every load increment
3297  IF(ALLOCATED(geometrictransformationsolver%scalings)) THEN
3298  transformationmatrix(1:nogeomcomp,nogeomcomp+1)=geometrictransformationsolver%transformationMatrices &
3299  & (1:nogeomcomp,nogeomcomp+1,1)*geometrictransformationsolver%scalings(incrementidx)
3300  ELSE !if no scaling just take 1/numberOfIncrements as scaling
3301  transformationmatrix(1:nogeomcomp,nogeomcomp+1)=geometrictransformationsolver%transformationMatrices &
3302  & (1:nogeomcomp,nogeomcomp+1,1)/geometrictransformationsolver%numberOfIncrements
3303  ENDIF
3304  ENDIF
3305  !**********************************************************************************************************************
3306  ! Transform the field
3307  ! Determine if the all components have the same mesh components/ bases
3308  DO componentidx=1,nogeomcomp-1
3309  IF(fieldvariable%COMPONENTS(componentidx)%MESH_COMPONENT_NUMBER/= &
3310  & fieldvariable%COMPONENTS(componentidx+1)%MESH_COMPONENT_NUMBER) samebases=.false.
3311  ENDDO
3312  IF(samebases) THEN
3313  domain=>fieldvariable%COMPONENTS(1)%DOMAIN !Use the 1st component domain since they are the same for all components
3314  IF(ASSOCIATED(domain)) THEN
3315  domainnodes=>domain%TOPOLOGY%NODES
3316  DO nodeidx=1,domainnodes%NUMBER_OF_NODES
3317  localnodenumber=domainnodes%NODES(nodeidx)%LOCAL_NUMBER
3318  usernodenumber=domainnodes%NODES(nodeidx)%USER_NUMBER
3319  DO derivativeidx=1,domainnodes%NODES(nodeidx)%NUMBER_OF_DERIVATIVES
3320  DO versionidx=1,domainnodes%NODES(nodeidx)%DERIVATIVES(derivativeidx)%numberOfVersions
3321  DO componentidx=1,nogeomcomp !Get all component for a nodal derivative
3322  CALL field_parameter_set_get_node(geometrictransformationsolver%field,geometrictransformationsolver% &
3323  & fieldvariabletype,field_values_set_type,versionidx,derivativeidx,usernodenumber,componentidx, &
3324  & nodalparameters(componentidx),err,error,*999)
3325  ENDDO !componentIdx
3326  !Rotate the nodal parameters
3327  usernodenumber=domainnodes%NODES(nodeidx)%USER_NUMBER
3328  nodalparameterstrans(1:nogeomcomp)=matmul(transformationmatrix(1:nogeomcomp,1:nogeomcomp), &
3329  & nodalparameters(1:nogeomcomp))
3330  DO componentidx=1,nogeomcomp !Update all component for a nodal derivative
3331  CALL field_parameter_set_update_node(geometrictransformationsolver%field,geometrictransformationsolver% &
3332  & fieldvariabletype,field_values_set_type,versionidx,derivativeidx,usernodenumber,componentidx, &
3333  & nodalparameterstrans(componentidx),err,error,*999)
3334  IF(derivativeidx==1) THEN ! Translate nodal coordinate
3335  CALL field_parameter_set_add_node(geometrictransformationsolver%field,geometrictransformationsolver% &
3336  & fieldvariabletype,field_values_set_type,versionidx,derivativeidx,usernodenumber,componentidx, &
3337  & transformationmatrix(componentidx,1+nogeomcomp),err,error,*999)
3338  ENDIF !derivativeIdx==1
3339  IF(transformbc) THEN
3340  CALL field_parameter_set_update_node(geometrictransformationsolver%field,geometrictransformationsolver% &
3341  & fieldvariabletype,field_boundary_conditions_set_type,versionidx,derivativeidx,usernodenumber, &
3342  & componentidx,nodalparameterstrans(componentidx),err,error,*999)
3343  IF(derivativeidx==1) THEN ! Translate nodal coordinate for BC
3344  CALL field_parameter_set_add_node(geometrictransformationsolver%field,geometrictransformationsolver% &
3345  & fieldvariabletype,field_boundary_conditions_set_type,versionidx,derivativeidx,usernodenumber, &
3346  & componentidx,transformationmatrix(componentidx,1+nogeomcomp),err,error,*999)
3347  ENDIF !derivativeIdx==1
3348  ENDIF !transformBC
3349  ENDDO !componentIdx
3350  ENDDO !versionIdx
3351  ENDDO !derivativeIdx
3352  ENDDO !nodeIdx
3353  ELSE
3354  CALL flagerror("Domain is not associated.",err,error,*999)
3355  ENDIF
3356  ELSE
3357  CALL flagerror("Transformation for different component bases not implemented.",err,error,*999)
3358  ENDIF
3359  ELSE
3360  CALL flagerror("The field of geometric transformation solver is not associated.",err,error,*999)
3361  ENDIF
3362  ELSE
3363  CALL flagerror("Geometric transformation solver is not associated.",err,error,*999)
3364  ENDIF
3365 
3366  exits("Problem_SolverGeometricTransformationSolve")
3367  RETURN
3368 999 errorsexits("Problem_SolverGeometricTransformationSolve",err,error)
3369  RETURN 1
3370  END SUBROUTINE problem_solvergeometrictransformationsolve
3371 
3372  !
3373  !================================================================================================================================
3374  !
3375 
3377  SUBROUTINE problem_solver_get_0(PROBLEM,CONTROL_LOOP_IDENTIFIER,SOLVER_INDEX,SOLVER,ERR,ERROR,*)
3378 
3379  !Argument variables
3380  TYPE(problem_type), POINTER :: problem
3381  INTEGER(INTG), INTENT(IN) :: control_loop_identifier
3382  INTEGER(INTG), INTENT(IN) :: solver_index
3383  TYPE(solver_type), POINTER :: solver
3384  INTEGER(INTG), INTENT(OUT) :: err
3385  TYPE(varying_string), INTENT(OUT) :: error
3386  !Local Variables
3387 
3388  enters("PROBLEM_SOLVER_GET_0",err,error,*999)
3389 
3390  CALL problem_solver_get_1(problem,[control_loop_identifier],solver_index,solver,err,error,*999)
3391 
3392  exits("PROBLEM_SOLVER_GET_0")
3393  RETURN
3394 999 errorsexits("PROBLEM_SOLVER_GET_0",err,error)
3395  RETURN 1
3396  END SUBROUTINE problem_solver_get_0
3397 
3398  !
3399  !================================================================================================================================
3400  !
3401 
3403  SUBROUTINE problem_solver_get_1(PROBLEM,CONTROL_LOOP_IDENTIFIER,SOLVER_INDEX,SOLVER,ERR,ERROR,*)
3404 
3405  !Argument variables
3406  TYPE(problem_type), POINTER :: problem
3407  INTEGER(INTG), INTENT(IN) :: control_loop_identifier(:)
3408  INTEGER(INTG), INTENT(IN) :: solver_index
3409  TYPE(solver_type), POINTER :: solver
3410  INTEGER(INTG), INTENT(OUT) :: err
3411  TYPE(varying_string), INTENT(OUT) :: error
3412  !Local Variables
3413  TYPE(control_loop_type), POINTER :: control_loop,control_loop_root
3414  TYPE(solvers_type), POINTER :: solvers
3415  TYPE(varying_string) :: local_error
3416 
3417  enters("PROBLEM_SOLVER_GET_1",err,error,*998)
3418 
3419  IF(ASSOCIATED(problem)) THEN
3420  IF(ASSOCIATED(solver)) THEN
3421  CALL flagerror("Solver is already associated.",err,error,*998)
3422  ELSE
3423  control_loop_root=>problem%CONTROL_LOOP
3424  IF(ASSOCIATED(control_loop_root)) THEN
3425  NULLIFY(control_loop)
3426  CALL control_loop_get(control_loop_root,control_loop_identifier,control_loop,err,error,*999)
3427  solvers=>control_loop%SOLVERS
3428  IF(ASSOCIATED(solvers)) THEN
3429  IF(solver_index>0.AND.solver_index<=solvers%NUMBER_OF_SOLVERS) THEN
3430  solver=>solvers%SOLVERS(solver_index)%PTR
3431  IF(.NOT.ASSOCIATED(solver)) CALL flagerror("Solvers solver is not associated.",err,error,*999)
3432  ELSE
3433  local_error="The specified solver index of "//trim(number_to_vstring(solver_index,"*",err,error))// &
3434  & " is invalid. The index must be > 0 and <= "// &
3435  & trim(number_to_vstring(solvers%NUMBER_OF_SOLVERS,"*",err,error))//"."
3436  CALL flagerror(local_error,err,error,*999)
3437  ENDIF
3438  ELSE
3439  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
3440  ENDIF
3441  ELSE
3442  CALL flagerror("Problem control loop is not associated.",err,error,*999)
3443  ENDIF
3444  ENDIF
3445  ELSE
3446  CALL flagerror("Problem is not associated.",err,error,*998)
3447  ENDIF
3448 
3449  exits("PROBLEM_SOLVER_GET_1")
3450  RETURN
3451 999 NULLIFY(solver)
3452 998 errorsexits("PROBLEM_SOLVER_GET_1",err,error)
3453  RETURN 1
3454  END SUBROUTINE problem_solver_get_1
3455 
3456  !
3457  !================================================================================================================================
3458  !
3459 
3461  SUBROUTINE problem_solvernonlinearmonitor(solver,iterationNumber,residualNorm,err,error,*)
3462 
3463  !Argument variables
3464  TYPE(solver_type), POINTER :: solver
3465  INTEGER(INTG), INTENT(IN) :: iterationnumber
3466  REAL(DP), INTENT(IN) :: residualnorm
3467  INTEGER(INTG), INTENT(OUT) :: err
3468  TYPE(varying_string), INTENT(OUT) :: error
3469  !Local Variables
3470  INTEGER(INTG) :: interfaceconditionidx
3471  TYPE(solvers_type), POINTER :: solvers
3472  TYPE(control_loop_type), POINTER :: controlloop
3473  TYPE(problem_type), POINTER :: problem
3474  TYPE(nonlinear_solver_type), POINTER :: nonlinearsolver
3475  TYPE(solver_equations_type), POINTER :: solverequations
3476  TYPE(solver_mapping_type), POINTER :: solvermapping
3477  TYPE(interface_condition_type), POINTER :: interfacecondition
3478  TYPE(interface_type), POINTER :: interface
3479  LOGICAL :: reproject
3480  TYPE(varying_string) :: localerror
3481 
3482  enters("Problem_SolverNonlinearMonitor",err,error,*998)
3483 
3484  IF(ASSOCIATED(solver)) THEN
3485  solvers=>solver%SOLVERS
3486  IF(ASSOCIATED(solvers)) THEN
3487  controlloop=>solvers%CONTROL_LOOP
3488  IF(ASSOCIATED(controlloop)) THEN
3489  problem=>controlloop%PROBLEM
3490  IF(ASSOCIATED(problem)) THEN
3491  IF(.NOT.ALLOCATED(problem%specification)) THEN
3492  CALL flagerror("Problem specification is not allocated.",err,error,*999)
3493  ELSE IF(SIZE(problem%specification,1)<1) THEN
3494  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
3495  END IF
3496  SELECT CASE(problem%SPECIFICATION(1))
3497  CASE(problem_elasticity_class)
3498  IF(SIZE(problem%specification,1)/=3) THEN
3499  CALL flagerror("Problem specification must have three entries for an elasticity problem.",err,error,*999)
3500  END IF
3501  SELECT CASE(problem%SPECIFICATION(2))
3502  CASE(problem_linear_elasticity_type,problem_finite_elasticity_type)
3503  !Output meshes at iterations
3504  IF(solver%SOLVE_TYPE==solver_nonlinear_type) THEN
3505  nonlinearsolver=>solver%NONLINEAR_SOLVER
3506  IF(ASSOCIATED(nonlinearsolver)) THEN
3507  CALL problem_solvernewtonfieldsoutput(solver,iterationnumber,err,error,*999)
3508  ENDIF
3509  ENDIF
3510  CASE(problem_linear_elasticity_contact_type,problem_finite_elasticity_contact_type)
3511  SELECT CASE(problem%SPECIFICATION(3))
3512  CASE(problem_le_contact_transform_subtype,problem_fe_contact_transform_subtype) !Reproject at iteration 0 before the nonlinear solve to update xi location since the field is transformed.
3513  IF(iterationnumber==0) THEN
3514  reproject=.true.
3515  ELSE
3516  reproject=.false.
3517  ENDIF
3518  CASE(problem_le_contact_transform_reproject_subtype,problem_le_contact_reproject_subtype, &
3519  & problem_fe_contact_transform_reproject_subtype,problem_fe_contact_reproject_subtype)
3520  reproject=.true.
3521  CASE DEFAULT
3522  localerror="The problem subtype of "//trim(number_to_vstring(problem%SPECIFICATION(3),"*",err,error))//" &
3523  & is invalid."
3524  CALL flagerror(localerror,err,error,*999)
3525  END SELECT
3526  IF(reproject) THEN
3527  solverequations=>solver%SOLVER_EQUATIONS
3528  IF(ASSOCIATED(solverequations)) THEN
3529  solvermapping=>solverequations%SOLVER_MAPPING
3530  IF(ASSOCIATED(solvermapping)) THEN
3531  DO interfaceconditionidx=1,solvermapping%NUMBER_OF_INTERFACE_CONDITIONS
3532  interfacecondition=>solvermapping%INTERFACE_CONDITIONS(interfaceconditionidx)%PTR
3533  IF(ASSOCIATED(interfacecondition)) THEN
3534  IF(interfacecondition%OPERATOR==interface_condition_fls_contact_reproject_operator .OR. &
3535  & interfacecondition%OPERATOR==interface_condition_fls_contact_operator) THEN !Only reproject for contact operator
3536  IF(interfacecondition%integrationType==interface_condition_data_points_integration) THEN !Only reproject for data point interpolated field
3537  interface=>interfacecondition%INTERFACE
3538  IF(ASSOCIATED(interface)) THEN
3539  CALL write_string(general_output_type,"**************** Reproject! ****************",err,error,*999)
3540  CALL interfacepointsconnectivity_datareprojection(interface,interfacecondition,err,error,*999)
3541  CALL interface_condition_assemble(interfacecondition,err,error,*999)
3542  ELSE
3543  CALL flagerror("Interface is not associated for nonlinear solver equations mapping.", &
3544  & err,error,*999)
3545  ENDIF
3546  ENDIF
3547  ENDIF
3548  ELSE
3549  CALL flagerror("Interface condition is not associated for nonlinear solver equations mapping.", &
3550  & err,error,*999)
3551  ENDIF
3552  ENDDO !interfaceConditionIdx
3553  ELSE
3554  CALL flagerror("Nonlinear solver equations mapping is not associated.",err,error,*999)
3555  ENDIF
3556  ELSE
3557  CALL flagerror("Nonlinear solver equations is not associated.",err,error,*999)
3558  ENDIF
3559  ENDIF !Reproject
3560  !Output meshes at iterations
3561  IF(solver%SOLVE_TYPE==solver_nonlinear_type) THEN
3562  nonlinearsolver=>solver%NONLINEAR_SOLVER
3563  IF(ASSOCIATED(nonlinearsolver)) THEN
3564  CALL problem_solvernewtonfieldsoutput(solver,iterationnumber,err,error,*999)
3565  ENDIF
3566  ENDIF
3567  CASE DEFAULT
3568  localerror="The problem type of "//trim(number_to_vstring(problem%SPECIFICATION(2),"*",err,error))//" &
3569  & is invalid."
3570  CALL flagerror(localerror,err,error,*999)
3571  END SELECT
3572  CASE(problem_bioelectrics_class,problem_fluid_mechanics_class,problem_electromagnetics_class, &
3573  & problem_classical_field_class,problem_fitting_class,problem_modal_class,problem_multi_physics_class)
3574  !Do nothing???
3575  CASE DEFAULT
3576  localerror="The problem class of "//trim(number_to_vstring(problem%SPECIFICATION(1),"*",err,error))//" &
3577  & is invalid."
3578  CALL flagerror(localerror,err,error,*999)
3579  END SELECT
3580  ELSE
3581  CALL flagerror("Problem is not associated.",err,error,*999)
3582  ENDIF
3583  ELSE
3584  CALL flagerror("Problem control loop is not associated.",err,error,*999)
3585  ENDIF
3586  ENDIF
3587  !Nonlinear solve monitor--progress output if required
3588  IF(solver%SOLVE_TYPE==solver_nonlinear_type) THEN
3589  nonlinearsolver=>solver%NONLINEAR_SOLVER
3590  IF(ASSOCIATED(nonlinearsolver)) THEN
3591  CALL solver_nonlinear_monitor(nonlinearsolver,iterationnumber,residualnorm,err,error,*999)
3592  ELSE
3593  CALL flagerror("Nonlinear solver is not associated.",err,error,*999)
3594  ENDIF
3595  ELSE
3596  localerror="Invalid solve type. The solve type of "//trim(number_to_vstring(solver%SOLVE_TYPE,"*",err,error))// &
3597  & " does not correspond to a nonlinear solver."
3598  CALL flagerror(localerror,err,error,*999)
3599  ENDIF
3600  ELSE
3601  CALL flagerror("Solver is not associated.",err,error,*999)
3602  ENDIF
3603 
3604  exits("Problem_SolverNonlinearMonitor")
3605  RETURN
3606 999 NULLIFY(solver)
3607 998 errorsexits("Problem_SolverNonlinearMonitor",err,error)
3608  RETURN 1
3609  END SUBROUTINE problem_solvernonlinearmonitor
3610 
3611  !
3612  !================================================================================================================================
3613  !
3614 
3616  SUBROUTINE problem_solvernewtonfieldsoutput(solver,iterationNumber,err,error,*)
3617 
3618  !Argument variables
3619  TYPE(solver_type), POINTER :: solver
3620  INTEGER(INTG), INTENT(IN) :: iterationnumber
3621  INTEGER(INTG), INTENT(OUT) :: err
3622  TYPE(varying_string), INTENT(OUT) :: error
3623  !Local Variables
3624  INTEGER(INTG) :: equationssetidx,load_step
3625  LOGICAL :: direxists
3626  TYPE(region_type), POINTER :: region
3627  TYPE(solver_mapping_type), POINTER :: solvermapping
3628  TYPE(fields_type), POINTER :: fields
3629  TYPE(varying_string) :: filename,method,directory
3630 
3631  INTEGER(INTG) :: interfaceconditionidx, interfaceelementnumber, datapointidx, globaldatapointnumber, coupledmeshelementnumber, &
3632  & coupledMeshFaceLineNumber, coupledMeshIdx,component
3633  TYPE(interface_type), POINTER :: interface
3634  TYPE(interface_condition_type), POINTER :: interfacecondition
3635  TYPE(interfacepointsconnectivitytype), POINTER :: pointsconnectivity
3636  TYPE(field_type), POINTER :: coupledmeshdependentfield
3637  TYPE(field_interpolation_parameters_ptr_type), POINTER :: interpolationparameters(:)
3638  TYPE(field_interpolated_point_ptr_type), POINTER :: interpolatedpoints(:)
3639  TYPE(field_interpolated_point_type), POINTER :: interpolatedpoint
3640  TYPE(decompositionelementdatapointstype), POINTER :: decompositionelementdata
3641  TYPE(data_points_type), POINTER :: interfacedatapoints
3642  TYPE(data_projection_type), POINTER :: dataprojection
3643 
3644  TYPE(problem_type), POINTER :: problem
3645 
3646  INTEGER(INTG) :: iunit
3647  CHARACTER(LEN=100) :: filenameoutput,groupname
3648 
3649  TYPE(varying_string) :: filetocheck,localerror
3650  LOGICAL :: fileexists
3651  INTEGER(INTG) :: firstiterationnumber, solve_call, max_solve_calls
3652 
3653  enters("Problem_SolverNewtonFieldsOutput",err,error,*999)
3654 
3655  IF(ASSOCIATED(solver%SOLVER_EQUATIONS))THEN
3656  solvermapping=>solver%SOLVER_EQUATIONS%SOLVER_MAPPING
3657  problem=>solver%SOLVERS%CONTROL_LOOP%PROBLEM
3658 
3659  IF(.NOT.ALLOCATED(problem%SPECIFICATION)) THEN
3660  CALL flagerror("Problem specification is not allocated.",err,error,*999)
3661  ELSE IF(SIZE(problem%SPECIFICATION,1)<1) THEN
3662  CALL flagerror("Problem specification must have at least one entry.",err,error,*999)
3663  END IF
3664  SELECT CASE(problem%SPECIFICATION(1))
3665  CASE(problem_elasticity_class)
3666  IF(SIZE(problem%specification,1)/=3) THEN
3667  CALL flagerror("Problem specification must have three entries for an elasticity problem.",err,error,*999)
3668  END IF
3669  SELECT CASE(problem%SPECIFICATION(2))
3670  CASE(problem_linear_elasticity_type,problem_finite_elasticity_type,problem_linear_elasticity_contact_type, &
3671  & problem_finite_elasticity_contact_type)
3672 
3673  IF(diagnostics1) THEN
3674  directory="results_iter/"
3675  INQUIRE(file=char(directory),exist=direxists)
3676  IF(.NOT.direxists) THEN
3677  CALL system(char("mkdir "//directory))
3678  ENDIF
3679 
3680  ! Find how many times the problem solve command has been issued.
3681  max_solve_calls=100
3682  coupledmeshidx=1
3683  load_step=1
3684  firstiterationnumber=0
3685  DO solve_call=1,max_solve_calls
3686  filetocheck=directory// &
3687  & "mesh"//trim(number_to_vstring(coupledmeshidx,"*",err,error))// &
3688  & "_solveCall"//trim(number_to_vstring(solve_call,"*",err,error))// &
3689  & "_load"//trim(number_to_vstring(load_step,"*",err,error))// &
3690  & "_iter"//trim(number_to_vstring(firstiterationnumber,"*",err,error))//".part0.exnode"
3691  INQUIRE(file=char(filetocheck),exist=fileexists)
3692  IF(.NOT.fileexists) THEN
3693  EXIT
3694  ENDIF
3695  ENDDO
3696 
3697  load_step=solver%SOLVERS%CONTROL_LOOP%LOAD_INCREMENT_LOOP%ITERATION_NUMBER
3698 
3699  IF((iterationnumber > 0).OR.(load_step > 1))THEN
3700  solve_call = solve_call - 1
3701  ENDIF
3702 
3703  WRITE(*,'(1X,''SolveCall: '',I4)') solve_call
3704  WRITE(*,'(1X,'' LoadStep: '',I4)') load_step
3705  WRITE(*,'(1X,'' Iteration: '',I4)') iterationnumber
3706 
3707  DO equationssetidx=1,solvermapping%NUMBER_OF_EQUATIONS_SETS
3708  region=>solvermapping%EQUATIONS_SETS(equationssetidx)%PTR%REGION
3709  IF(ASSOCIATED(region))THEN
3710  NULLIFY(fields)
3711  fields=>region%FIELDS
3712  filename=directory//"mesh"//trim(number_to_vstring(equationssetidx,"*",err,error))// &
3713  & "_solveCall"//trim(number_to_vstring(solve_call,"*",err,error))// &
3714  & "_load"//trim(number_to_vstring(load_step,"*",err,error))// &
3715  & "_iter"//trim(number_to_vstring(iterationnumber,"*",err,error))
3716  method="FORTRAN"
3717  CALL field_io_elements_export(fields,filename,method,err,error,*999)
3718  CALL field_io_nodes_export(fields,filename,method,err,error,*999)
3719  ELSE
3720  CALL flagerror("Region is not associated.",err,error,*999)
3721  ENDIF
3722  ENDDO
3723  ENDIF
3724 
3725  CASE DEFAULT
3726  localerror="The problem type of "//trim(number_to_vstring(problem%SPECIFICATION(2),"*",err,error))//" &
3727  & is invalid."
3728  CALL flagerror(localerror,err,error,*999)
3729  END SELECT
3730  CASE(problem_bioelectrics_class,problem_fluid_mechanics_class,problem_electromagnetics_class, &
3731  & problem_classical_field_class,problem_fitting_class,problem_modal_class,problem_multi_physics_class)
3732  !Do nothing???
3733  CASE DEFAULT
3734  localerror="The problem class of "//trim(number_to_vstring(problem%SPECIFICATION(1),"*",err,error))//" &
3735  & is invalid."
3736  CALL flagerror(localerror,err,error,*999)
3737  END SELECT
3738 
3739  SELECT CASE(problem%SPECIFICATION(1))
3740  CASE(problem_elasticity_class)
3741  SELECT CASE(problem%SPECIFICATION(2))
3742  CASE(problem_linear_elasticity_type,problem_finite_elasticity_type)
3743  ! Pass
3744  CASE(problem_linear_elasticity_contact_type,problem_finite_elasticity_contact_type)
3745 
3746  IF(diagnostics1) THEN
3747  iunit = 300
3748  DO interfaceconditionidx=1,solvermapping%NUMBER_OF_INTERFACE_CONDITIONS
3749  interfacecondition=>solvermapping%INTERFACE_CONDITIONS(interfaceconditionidx)%PTR
3750  interface=>solvermapping%INTERFACE_CONDITIONS(interfaceconditionidx)%PTR%interface
3751  pointsconnectivity=>interface%pointsConnectivity
3752  interfacedatapoints=>interface%DATA_POINTS
3753  IF(ASSOCIATED(pointsconnectivity)) THEN
3754  DO coupledmeshidx=1,interface%NUMBER_OF_COUPLED_MESHES
3755  filenameoutput=directory//"PointsConnectivity"//trim(number_to_vstring(coupledmeshidx,"*",err,error))// &
3756  & "_solveCall"//trim(number_to_vstring(solve_call,"*",err,error))// &
3757  & "_load"//trim(number_to_vstring(load_step,"*",err,error))// &
3758  & "_iter"//trim(number_to_vstring(iterationnumber,"*",err,error))//".exdata"
3759  OPEN(unit=iunit,file=filenameoutput,status="UNKNOWN",action="WRITE",iostat=err)
3760  groupname="PointsConnectivity"//trim(number_to_vstring(coupledmeshidx,"*",err,error))
3761  WRITE(iunit,'( '' Group name: '',A)') groupname
3762  WRITE(iunit,'(1X,''#Fields=4'')')
3763  WRITE(iunit,'(1X,''1) coordinates, coordinate, rectangular cartesian, #Components=3'')')
3764  WRITE(iunit,'(1X,'' x. Value index= 1, #Derivatives=0'')')
3765  WRITE(iunit,'(1X,'' y. Value index= 2, #Derivatives=0'')')
3766  WRITE(iunit,'(1X,'' z. Value index= 3, #Derivatives=0'')')
3767  WRITE(iunit,'(1X,''2) error, field, rectangular cartesian, #Components=3'')')
3768  WRITE(iunit,'(1X,'' x. Value index= 4, #Derivatives=0'')')
3769  WRITE(iunit,'(1X,'' y. Value index= 5, #Derivatives=0'')')
3770  WRITE(iunit,'(1X,'' z. Value index= 6, #Derivatives=0'')')
3771  WRITE(iunit,'(1X,''3) projectedCoordinate, field, rectangular cartesian, #Components=3'')')
3772  WRITE(iunit,'(1X,'' x. Value index= 7, #Derivatives=0'')')
3773  WRITE(iunit,'(1X,'' y. Value index= 8, #Derivatives=0'')')
3774  WRITE(iunit,'(1X,'' z. Value index= 9, #Derivatives=0'')')
3775  WRITE(iunit,'(1X,''4) exitTag, field, rectangular cartesian, #Components=1'')')
3776  WRITE(iunit,'(1X,'' tag. Value index= 10, #Derivatives=0'')')
3777  coupledmeshdependentfield=>interfacecondition%DEPENDENT%EQUATIONS_SETS(coupledmeshidx)%PTR% &
3778  & dependent%DEPENDENT_FIELD
3779  NULLIFY(interpolationparameters)
3780  CALL field_interpolation_parameters_initialise(coupledmeshdependentfield,interpolationparameters,err,error, &
3781  & *999,field_geometric_components_type)
3782  NULLIFY(interpolatedpoints)
3783  CALL field_interpolated_points_initialise(interpolationparameters,interpolatedpoints,err,error,*999, &
3784  & field_geometric_components_type)
3785  interpolatedpoint=>interpolatedpoints(field_u_variable_type)%PTR
3786  dataprojection=>interfacedatapoints%DATA_PROJECTIONS(coupledmeshidx+1)%PTR
3787  DO interfaceelementnumber=1,SIZE(pointsconnectivity%coupledElements,1)
3788  decompositionelementdata=>interfacecondition%LAGRANGE%LAGRANGE_FIELD%DECOMPOSITION%TOPOLOGY%dataPoints% &
3789  & elementdatapoint(interfaceelementnumber)
3790  DO datapointidx=1,decompositionelementdata%numberOfProjectedData
3791  globaldatapointnumber=decompositionelementdata%dataIndices(datapointidx)%globalNumber
3792  WRITE(iunit,'(1X,''Node:'',I4)') globaldatapointnumber
3793  DO component=1,3
3794  WRITE(iunit,'(1X,3E25.15)') interfacedatapoints%DATA_POINTS(globaldatapointnumber)%position(component)
3795  ENDDO !component
3796  coupledmeshelementnumber=pointsconnectivity%pointsConnectivity(globaldatapointnumber,coupledmeshidx)% &
3797  & coupledmeshelementnumber
3798  coupledmeshfacelinenumber=coupledmeshdependentfield%DECOMPOSITION%TOPOLOGY%ELEMENTS% &
3799  & elements(coupledmeshelementnumber)% &
3800  & element_faces(pointsconnectivity%pointsConnectivity(globaldatapointnumber,coupledmeshidx)% &
3801  & elementlinefacenumber)
3802  CALL field_interpolation_parameters_face_get(field_values_set_type,coupledmeshfacelinenumber, &
3803  & interpolationparameters(field_u_variable_type)%PTR,err,error,*999,field_geometric_components_type)
3804  CALL field_interpolate_xi(no_part_deriv,pointsconnectivity%pointsConnectivity(globaldatapointnumber, &
3805  & coupledmeshidx)%reducedXi(:),interpolatedpoint,err,error,*999,field_geometric_components_type) !Interpolate contact data points on each surface
3806  DO component=1,3
3807  WRITE(iunit,'(1X,3E25.15)') interpolatedpoint%VALUES(component,no_part_deriv) - &
3808  & interfacedatapoints%DATA_POINTS(globaldatapointnumber)%position(component)
3809  ENDDO !component
3810  DO component=1,3
3811  WRITE(iunit,'(1X,3E25.15)') interpolatedpoint%VALUES(component,no_part_deriv)
3812  ENDDO !component
3813  WRITE(iunit,'(1X,I2)') dataprojection%DATA_PROJECTION_RESULTS(globaldatapointnumber)%EXIT_TAG
3814  ENDDO !dataPointIdx
3815  ENDDO !interfaceElementNumber
3816  CALL field_interpolation_parameters_finalise(interpolationparameters,err,error,*999)
3817  CALL field_interpolated_points_finalise(interpolatedpoints,err,error,*999)
3818  OPEN(unit=iunit)
3819  ENDDO !coupledMeshIdx
3820  ENDIF
3821  ENDDO !interfaceConditionIdx
3822  ENDIF
3823 
3824  CASE DEFAULT
3825  localerror="The problem type of "//trim(number_to_vstring(problem%SPECIFICATION(2),"*",err,error))//" &
3826  & is invalid."
3827  CALL flagerror(localerror,err,error,*999)
3828  END SELECT
3829  CASE(problem_bioelectrics_class,problem_fluid_mechanics_class,problem_electromagnetics_class, &
3830  & problem_classical_field_class,problem_fitting_class,problem_modal_class,problem_multi_physics_class)
3831  !Do nothing???
3832  CASE DEFAULT
3833  localerror="The problem class of "//trim(number_to_vstring(problem%SPECIFICATION(1),"*",err,error))//" &
3834  & is invalid."
3835  CALL flagerror(localerror,err,error,*999)
3836  END SELECT
3837 
3838  ELSE
3839  CALL flagerror("Solver equations is not associated.",err,error,*999)
3840  ENDIF
3841 
3842  exits("Problem_SolverNewtonFieldsOutput")
3843  RETURN
3844 999 errorsexits("Problem_SolverNewtonFieldsOutput",err,error)
3845  RETURN 1
3846  END SUBROUTINE problem_solvernewtonfieldsoutput
3847 
3848  !
3849  !================================================================================================================================
3850  !
3851 
3853  SUBROUTINE problem_specificationget(problem,problemSpecification,err,error,*)
3854 
3855  !Argument variables
3856  TYPE(problem_type), POINTER :: problem
3857  INTEGER(INTG), INTENT(INOUT) :: problemspecification(:)
3858  INTEGER(INTG), INTENT(OUT) :: err
3859  TYPE(varying_string), INTENT(OUT) :: error
3860  !Local Variables
3861  INTEGER(INTG) :: specificationlength
3862 
3863  enters("Problem_SpecificationGet",err,error,*999)
3864 
3865  IF(ASSOCIATED(problem)) THEN
3866  IF(problem%problem_finished) THEN
3867  IF(.NOT.ALLOCATED(problem%specification)) THEN
3868  CALL flagerror("Problem specification is not allocated.",err,error,*999)
3869  END IF
3870  specificationlength=SIZE(problem%specification,1)
3871  IF(SIZE(problemspecification,1)>=specificationlength) THEN
3872  problemspecification(1:specificationlength)=problem%specification(1:specificationlength)
3873  ELSE
3874  CALL flagerror("The problem specification size is "//trim(numbertovstring(specificationlength,"*",err,error))// &
3875  & " but the input array only has size "//trim(numbertovstring(SIZE(problemspecification,1),"*",err,error))//".", &
3876  & err,error,*999)
3877  ENDIF
3878  ELSE
3879  CALL flagerror("Problem has not been finished.",err,error,*999)
3880  ENDIF
3881  ELSE
3882  CALL flagerror("Problem is not associated.",err,error,*999)
3883  ENDIF
3884 
3885  exits("Problem_SpecificationGet")
3886  RETURN
3887 999 errorsexits("Problem_SpecificationGet",err,error)
3888  RETURN 1
3889 
3890  END SUBROUTINE problem_specificationget
3891 
3892  !
3893  !================================================================================================================================
3894  !
3895 
3897  SUBROUTINE problem_specificationset(problem,problemSpecification,err,error,*)
3898 
3899  !Argument variables
3900  TYPE(problem_type), POINTER :: problem
3901  INTEGER(INTG), INTENT(IN) :: problemspecification(:)
3902  INTEGER(INTG), INTENT(OUT) :: err
3903  TYPE(varying_string), INTENT(OUT) :: error
3904  !Local Variables
3905  TYPE(varying_string) :: localerror
3906  INTEGER(INTG) :: problemclass
3907 
3908  enters("Problem_SpecificationSet",err,error,*999)
3909 
3910  IF(ASSOCIATED(problem)) THEN
3911  IF(problem%problem_finished) THEN
3912  CALL flagerror("Problem has been finished.",err,error,*999)
3913  ELSE
3914  IF(SIZE(problemspecification,1)<1) THEN
3915  CALL flagerror("Problem specification array must have one or more entries.",err,error,*999)
3916  ENDIF
3917  problemclass=problemspecification(1)
3918  SELECT CASE(problemclass)
3919  CASE(problem_elasticity_class)
3920  CALL elasticity_problemspecificationset(problem,problemspecification,err,error,*999)
3921  CASE(problem_fluid_mechanics_class)
3922  CALL fluidmechanics_problemspecificationset(problem,problemspecification,err,error,*999)
3923  CASE(problem_electromagnetics_class)
3924  CALL flagerror("Not implemented.",err,error,*999)
3925  CASE(problem_classical_field_class)
3926  CALL classicalfield_problemspecificationset(problem,problemspecification,err,error,*999)
3927  CASE(problem_bioelectrics_class)
3928  CALL bioelectric_problemspecificationset(problem,problemspecification,err,error,*999)
3929  CASE(problem_modal_class)
3930  CALL flagerror("Not implemented.",err,error,*999)
3931  CASE(problem_fitting_class)
3932  CALL fitting_problemspecificationset(problem,problemspecification,err,error,*999)
3933  CASE(problem_optimisation_class)
3934  CALL flagerror("Not implemented.",err,error,*999)
3935  CASE(problem_multi_physics_class)
3936  CALL multiphysics_problemspecificationset(problem,problemspecification,err,error,*999)
3937  CASE DEFAULT
3938  localerror="The first problems specification of "//trim(numbertovstring(problemclass,"*",err,error))//" is not valid."
3939  CALL flagerror(localerror,err,error,*999)
3940  END SELECT
3941  ENDIF
3942  ELSE
3943  CALL flagerror("Problem is not associated.",err,error,*999)
3944  ENDIF
3945 
3946  exits("Problem_SpecificationSet")
3947  RETURN
3948 999 errorsexits("Problem_SpecificationSet",err,error)
3949  RETURN 1
3950 
3951  END SUBROUTINE problem_specificationset
3952 
3953  !
3954  !================================================================================================================================
3955  !
3956 
3958  SUBROUTINE problem_specificationsizeget(problem,specificationSize,err,error,*)
3959 
3960  !Argument variables
3961  TYPE(problem_type), POINTER :: problem
3962  INTEGER(INTG), INTENT(OUT) :: specificationsize
3963  INTEGER(INTG), INTENT(OUT) :: err
3964  TYPE(varying_string), INTENT(OUT) :: error
3965  !Local Variables
3966 
3967  enters("Problem_SpecificationSizeGet",err,error,*999)
3968 
3969  specificationsize=0
3970  IF(ASSOCIATED(problem)) THEN
3971  IF(problem%problem_finished) THEN
3972  IF(.NOT.ALLOCATED(problem%specification)) THEN
3973  CALL flagerror("Problem specification is not allocated.",err,error,*999)
3974  END IF
3975  specificationsize=SIZE(problem%specification,1)
3976  ELSE
3977  CALL flagerror("Problem has not been finished.",err,error,*999)
3978  ENDIF
3979  ELSE
3980  CALL flagerror("Problem is not associated.",err,error,*999)
3981  ENDIF
3982 
3983  exits("Problem_SpecificationSizeGet")
3984  RETURN
3985 999 errorsexits("Problem_SpecificationSizeGet",err,error)
3986  RETURN 1
3987 
3988  END SUBROUTINE problem_specificationsizeget
3989 
3990  !
3991  !================================================================================================================================
3992  !
3993 
3995  SUBROUTINE problem_user_number_find(USER_NUMBER,PROBLEM,ERR,ERROR,*)
3996 
3997  !Argument variables
3998  INTEGER(INTG), INTENT(IN) :: user_number
3999  TYPE(problem_type), POINTER :: problem
4000  INTEGER(INTG), INTENT(OUT) :: err
4001  TYPE(varying_string), INTENT(OUT) :: error
4002  !Local Variables
4003  INTEGER(INTG) :: problem_idx
4004 
4005  enters("PROBLEM_USER_NUMBER_FIND",err,error,*999)
4006 
4007  IF(ASSOCIATED(problem)) THEN
4008  CALL flagerror("Problem is already associated.",err,error,*999)
4009  ELSE
4010  problem_idx=1
4011  DO WHILE(problem_idx<=problems%NUMBER_OF_PROBLEMS.AND..NOT.ASSOCIATED(problem))
4012  IF(problems%PROBLEMS(problem_idx)%PTR%USER_NUMBER==user_number) THEN
4013  problem=>problems%PROBLEMS(problem_idx)%PTR
4014  ELSE
4015  problem_idx=problem_idx+1
4016  ENDIF
4017  ENDDO
4018  ENDIF
4019 
4020  exits("PROBLEM_USER_NUMBER_FIND")
4021  RETURN
4022 999 errorsexits("PROBLEM_USER_NUMBER_FIND",err,error)
4023  RETURN 1
4024  END SUBROUTINE problem_user_number_find
4025 
4026  !
4027  !================================================================================================================================
4028  !
4029 
4031  SUBROUTINE problems_finalise(ERR,ERROR,*)
4032 
4033  !Argument variables
4034  INTEGER(INTG), INTENT(OUT) :: err
4035  TYPE(varying_string), INTENT(OUT) :: error
4036  !Local Variables
4037 
4038  enters("PROBLEMS_FINALISE",err,error,*999)
4039 
4040  DO WHILE(problems%NUMBER_OF_PROBLEMS>0)
4041  CALL problem_destroy(problems%PROBLEMS(1)%PTR,err,error,*999)
4042  ENDDO !problem_idx
4043 
4044  exits("PROBLEMS_FINALISE")
4045  RETURN
4046 999 errorsexits("PROBLEMS_FINALISE",err,error)
4047  RETURN 1
4048  END SUBROUTINE problems_finalise
4049 
4050  !
4051  !================================================================================================================================
4052  !
4053 
4055  SUBROUTINE problems_initialise(ERR,ERROR,*)
4056 
4057  !Argument variables
4058  INTEGER(INTG), INTENT(OUT) :: err
4059  TYPE(varying_string), INTENT(OUT) :: error
4060  !Local Variables
4061 
4062  enters("PROBLEMS_INITIALISE",err,error,*999)
4063 
4064  problems%NUMBER_OF_PROBLEMS=0
4065  NULLIFY(problems%PROBLEMS)
4066 
4067  exits("PROBLEMS_INITIALISE")
4068  RETURN
4069 999 errorsexits("PROBLEMS_INITIALISE",err,error)
4070  RETURN 1
4071  END SUBROUTINE problems_initialise
4072 
4073  !
4074  !================================================================================================================================
4075  !
4076 
4078  RECURSIVE SUBROUTINE problem_control_loop_previous_values_update(CONTROL_LOOP,ERR,ERROR,*)
4079 
4080  !Argument variables
4081  TYPE(control_loop_type), POINTER :: control_loop
4082  INTEGER(INTG), INTENT(OUT) :: err
4083  TYPE(varying_string), INTENT(OUT) :: error
4084  !Local Variables
4085  TYPE(solvers_type), POINTER :: solvers
4086  TYPE(solver_type), POINTER :: solver
4087  INTEGER(INTG) :: solver_idx
4088 
4089  NULLIFY(solver)
4090 
4091  enters("PROBLEM_CONTROL_LOOP_PREVIOUS_VALUES_UPDATE",err,error,*999)
4092 
4093  IF(ASSOCIATED(control_loop)) THEN
4094  IF(control_loop%NUMBER_OF_SUB_LOOPS==0) THEN
4095  !If there are no sub loops then get the solvers for this loop.
4096  solvers=>control_loop%SOLVERS
4097  IF(ASSOCIATED(solvers)) THEN
4098  DO solver_idx=1,solvers%NUMBER_OF_SOLVERS
4099  solver=>solvers%SOLVERS(solver_idx)%PTR
4100  SELECT CASE(solver%SOLVE_TYPE)
4101  CASE(solver_dynamic_type)
4102  CALL solver_variablesdynamicfieldpreviousvaluesupdate(solver,err,error,*999)
4103  CASE DEFAULT
4104  !Do nothing
4105  END SELECT
4106  ENDDO !solver_idx
4107  ELSE
4108  CALL flagerror("Control loop solvers is not associated.",err,error,*999)
4109  ENDIF
4110  ENDIF
4111  ELSE
4112  CALL flagerror("Control loop is not associated.",err,error,*999)
4113  ENDIF
4114 
4115  exits("PROBLEM_CONTROL_LOOP_PREVIOUS_VALUES_UPDATE")
4116  RETURN
4117 999 errorsexits("PROBLEM_CONTROL_LOOP_PREVIOUS_VALUES_UPDATE",err,error)
4118  RETURN 1
4119 
4120  END SUBROUTINE problem_control_loop_previous_values_update
4121 
4122  !
4123  !================================================================================================================================
4124  !
4125 
4126 
4127 END MODULE problem_routines
4128 
4129 !
4130 !================================================================================================================================
4131 !
4132 
4134 SUBROUTINE problem_solverjacobianevaluatepetsc(snes,x,A,B,ctx,err)
4135 
4136  USE base_routines
4137  USE cmisspetsctypes
4139  USE iso_varying_string
4140  USE kinds
4141  USE problem_routines
4142  USE solver_routines
4144  USE strings
4145  USE types
4146 
4147  IMPLICIT NONE
4148 
4149  !Argument variables
4150  TYPE(petscsnestype), INTENT(INOUT) :: snes
4151  TYPE(petscvectype), INTENT(INOUT) :: x
4152  TYPE(petscmattype), INTENT(INOUT) :: a
4153  TYPE(petscmattype), INTENT(INOUT) :: b
4154  TYPE(solver_type), POINTER :: ctx
4155  INTEGER(INTG), INTENT(INOUT) :: err
4156  !Local Variables
4157  INTEGER(INTG) :: dummyerr
4158  TYPE(distributed_vector_type), POINTER :: solvervector
4159  TYPE(newton_solver_type), POINTER :: newtonsolver
4160  TYPE(nonlinear_solver_type), POINTER :: nonlinearsolver
4161  TYPE(quasi_newton_solver_type), POINTER :: quasinewtonsolver
4162  TYPE(solver_equations_type), POINTER :: solverequations
4163  TYPE(solver_matrices_type), POINTER :: solvermatrices
4164  TYPE(solver_matrix_type), POINTER :: solvermatrix
4165  TYPE(varying_string) :: dummyerror,error,localerror
4166 
4167  IF(ASSOCIATED(ctx)) THEN
4168  solverequations=>ctx%SOLVER_EQUATIONS
4169  IF(ASSOCIATED(solverequations)) THEN
4170  solvermatrices=>solverequations%SOLVER_MATRICES
4171  IF(ASSOCIATED(solvermatrices)) THEN
4172  IF(solvermatrices%NUMBER_OF_MATRICES==1) THEN
4173  solvermatrix=>solvermatrices%matrices(1)%ptr
4174  IF(ASSOCIATED(solvermatrix)) THEN
4175  solvervector=>solvermatrix%SOLVER_VECTOR
4176  IF(ASSOCIATED(solvervector)) THEN
4177  CALL distributed_vector_override_set_on(solvervector,x,err,error,*999)
4178 
4179  CALL problem_solver_jacobian_evaluate(ctx,err,error,*999)
4180 
4181  CALL distributed_vector_override_set_off(solvervector,err,error,*999)
4182  ELSE
4183  CALL flagerror("Solver vector is not associated.",err,error,*998)
4184  ENDIF
4185  ELSE
4186  CALL flagerror("Solver matrix is not associated.",err,error,*998)
4187  ENDIF
4188  ELSE
4189  localerror="The number of solver matrices of "// &
4190  & trim(numbertovstring(solvermatrices%NUMBER_OF_MATRICES,"*",err,error))// &
4191  & " is invalid. There should be 1 solver matrix."
4192  CALL flagerror(localerror,err,error,*998)
4193  ENDIF
4194  ELSE
4195  CALL flagerror("Solver equations solver matrices is not associated.",err,error,*998)
4196  ENDIF
4197  ELSE
4198  CALL flagerror("Solver solver equations is not associated.",err,error,*998)
4199  ENDIF
4200 !!TODO: move this to PROBLEM_SOLVER_JACOBIAN_EVALUATE or elsewhere?
4201  nonlinearsolver=>ctx%NONLINEAR_SOLVER
4202  IF(ASSOCIATED(nonlinearsolver)) THEN
4203  SELECT CASE(nonlinearsolver%NONLINEAR_SOLVE_TYPE)
4205  newtonsolver=>nonlinearsolver%NEWTON_SOLVER
4206  IF(ASSOCIATED(newtonsolver)) THEN
4207  newtonsolver%TOTAL_NUMBER_OF_JACOBIAN_EVALUATIONS=newtonsolver%TOTAL_NUMBER_OF_JACOBIAN_EVALUATIONS+1
4208  ELSE
4209  CALL flagerror("Nonlinear solver Newton solver is not associated.",err,error,*998)
4210  ENDIF
4212  quasinewtonsolver=>nonlinearsolver%QUASI_NEWTON_SOLVER
4213  IF(ASSOCIATED(quasinewtonsolver)) THEN
4214  quasinewtonsolver%TOTAL_NUMBER_OF_JACOBIAN_EVALUATIONS=quasinewtonsolver%TOTAL_NUMBER_OF_JACOBIAN_EVALUATIONS+1
4215  ELSE
4216  CALL flagerror("Nonlinear solver Quasi-Newton solver is not associated.",err,error,*998)
4217  ENDIF
4218  CASE DEFAULT
4219  !Do nothing?
4220  END SELECT
4221  ELSE
4222  CALL flagerror("Solver nonlinear solver is not associated.",err,error,*998)
4223  ENDIF
4224  ELSE
4225  CALL flagerror("Solver context is not associated.",err,error,*998)
4226  ENDIF
4227 
4228  RETURN
4229 999 CALL distributed_vector_override_set_off(solvervector,dummyerr,dummyerror,*998)
4230 998 CALL writeerror(err,error,*997)
4231 997 CALL flagwarning("Error evaluating nonlinear Jacobian.",err,error,*996)
4232 996 RETURN
4233 END SUBROUTINE problem_solverjacobianevaluatepetsc
4234 
4235 !
4236 !================================================================================================================================
4237 !
4238 
4241 SUBROUTINE problem_solverjacobianfdcalculatepetsc(snes,x,A,B,ctx,err)
4242 
4243  USE base_routines
4244  USE cmisspetsc
4245  USE cmisspetsctypes
4247  USE iso_varying_string
4248  USE kinds
4249  USE problem_routines
4251  USE solver_routines
4252  USE strings
4253  USE types
4254 
4255 
4256  IMPLICIT NONE
4257 
4258  !Argument variables
4259  TYPE(petscsnestype), INTENT(INOUT) :: snes
4260  TYPE(petscvectype), INTENT(INOUT) :: x
4261  TYPE(petscmattype), INTENT(INOUT) :: a
4262  TYPE(petscmattype), INTENT(INOUT) :: b
4263  TYPE(solver_type), POINTER :: ctx
4264  INTEGER(INTG), INTENT(INOUT) :: err
4265  !Local Variables
4266  INTEGER(INTG) :: dummyerr
4267  TYPE(newton_solver_type), POINTER :: newtonsolver
4268  TYPE(nonlinear_solver_type), POINTER :: nonlinearsolver
4269  TYPE(newton_linesearch_solver_type), POINTER :: linesearchsolver
4270  TYPE(quasi_newton_solver_type), POINTER :: quasinewtonsolver
4271  TYPE(quasi_newton_linesearch_solver_type), POINTER :: quasinewtonlinesearchsolver
4272  TYPE(solver_equations_type), POINTER :: solverequations
4273  TYPE(solver_matrices_type), POINTER :: solvermatrices
4274  TYPE(solver_matrix_type), POINTER :: solvermatrix
4275  TYPE(petscmatfdcoloringtype), POINTER :: jacobianmatfdcoloring
4276  TYPE(varying_string) :: dummyerror,error,localerror
4277 
4278  IF(ASSOCIATED(ctx)) THEN
4279  nonlinearsolver=>ctx%NONLINEAR_SOLVER
4280  IF(ASSOCIATED(nonlinearsolver)) THEN
4281  solverequations=>ctx%SOLVER_EQUATIONS
4282  IF(ASSOCIATED(solverequations)) THEN
4283  solvermatrices=>solverequations%SOLVER_MATRICES
4284  IF(ASSOCIATED(solvermatrices)) THEN
4285  IF(solvermatrices%NUMBER_OF_MATRICES==1) THEN
4286  solvermatrix=>solvermatrices%matrices(1)%ptr
4287  IF(ASSOCIATED(solvermatrix)) THEN
4288  SELECT CASE(solverequations%SPARSITY_TYPE)
4290  SELECT CASE(nonlinearsolver%NONLINEAR_SOLVE_TYPE)
4292  newtonsolver=>nonlinearsolver%NEWTON_SOLVER
4293  IF(ASSOCIATED(newtonsolver)) THEN
4294  linesearchsolver=>newtonsolver%LINESEARCH_SOLVER
4295  IF(ASSOCIATED(linesearchsolver)) THEN
4296  jacobianmatfdcoloring=>linesearchsolver%jacobianMatFDColoring
4297  ELSE
4298  CALL flagerror("Newton solver linesearch solver is not associated.",err,error,*999)
4299  ENDIF
4300  ELSE
4301  CALL flagerror("Nonlinear solver Newton solver is not associated.",err,error,*999)
4302  ENDIF
4304  quasinewtonsolver=>nonlinearsolver%QUASI_NEWTON_SOLVER
4305  IF(ASSOCIATED(quasinewtonsolver)) THEN
4306  quasinewtonlinesearchsolver=>quasinewtonsolver%LINESEARCH_SOLVER
4307  IF(ASSOCIATED(quasinewtonlinesearchsolver)) THEN
4308  jacobianmatfdcoloring=>quasinewtonlinesearchsolver%jacobianMatFDColoring
4309  ELSE
4310  CALL flagerror("Quasi-Newton solver linesearch solver is not associated.",err,error,*999)
4311  ENDIF
4312  ELSE
4313  CALL flagerror("Nonlinear solver quasi Newton solver is not associated.",err,error,*999)
4314  ENDIF
4315  CASE DEFAULT
4316  localerror="The nonlinear solver type of "// &
4317  & trim(numbertovstring(nonlinearsolver%NONLINEAR_SOLVE_TYPE,"*",err,error))// &
4318  & " is invalid."
4319  CALL flagerror(localerror,err,error,*999)
4320  END SELECT
4321  IF(ASSOCIATED(jacobianmatfdcoloring)) THEN
4322  CALL petsc_snescomputejacobiandefaultcolor(snes,x,a,b,jacobianmatfdcoloring,err,error,*999)
4323  ELSE
4324  CALL flagerror("Linesearch solver FD colouring is not associated.",err,error,*998)
4325  ENDIF
4326  CASE(solver_full_matrices)
4327  CALL petsc_snescomputejacobiandefault(snes,x,a,b,ctx,err,error,*999)
4328  CASE DEFAULT
4329  localerror="The specified solver equations sparsity type of "// &
4330  & trim(numbertovstring(solverequations%SPARSITY_TYPE,"*",err,error))//" is invalid."
4331  CALL flagerror(localerror,err,error,*999)
4332  END SELECT
4333  IF(ctx%OUTPUT_TYPE>=solver_matrix_output) THEN
4334  CALL distributed_matrix_override_set_on(solvermatrices%matrices(1)%ptr%matrix,a,err,error,*999)
4336  CALL distributed_matrix_override_set_off(solvermatrices%matrices(1)%ptr%matrix,err,error,*999)
4337  ENDIF
4338  ELSE
4339  CALL flagerror("Solver matrix is not associated.",err,error,*998)
4340  ENDIF
4341  ELSE
4342  localerror="The number of solver matrices of "// &
4343  & trim(numbertovstring(solvermatrices%NUMBER_OF_MATRICES,"*",err,error))// &
4344  & " is invalid. There should be 1 solver matrix."
4345  CALL flagerror(localerror,err,error,*998)
4346  ENDIF
4347  ELSE
4348  CALL flagerror("Solver equations solver matrices is not associated.",err,error,*998)
4349  ENDIF
4350  ELSE
4351  CALL flagerror("Solver solver equations is not associated.",err,error,*998)
4352  ENDIF
4353  ELSE
4354  CALL flagerror("Nonlinear solver is not associated.",err,error,*998)
4355  ENDIF
4356  ELSE
4357  CALL flagerror("Solver context is not associated.",err,error,*998)
4358  ENDIF
4359 
4360  RETURN
4361 999 CALL distributed_matrix_override_set_off(solvermatrix%matrix,dummyerr,dummyerror,*998)
4362 998 CALL writeerror(err,error,*997)
4363 997 CALL flagwarning("Error evaluating nonlinear Jacobian.",err,error,*996)
4364 996 RETURN
4365 
4366 END SUBROUTINE problem_solverjacobianfdcalculatepetsc
4367 
4368 !
4369 !================================================================================================================================
4370 !
4371 
4373 SUBROUTINE problem_solverresidualevaluatepetsc(snes,x,f,ctx,err)
4374 
4375  USE base_routines
4376  USE cmisspetsctypes
4378  USE iso_varying_string
4379  USE kinds
4380  USE problem_routines
4381  USE solver_routines
4382  USE strings
4383  USE types
4384 
4385  IMPLICIT NONE
4386 
4387  !Argument variables
4388  TYPE(petscsnestype), INTENT(INOUT) :: snes
4389  TYPE(petscvectype), INTENT(INOUT) :: x
4390  TYPE(petscvectype), INTENT(INOUT) :: f
4391  TYPE(solver_type), POINTER :: ctx
4392  INTEGER(INTG), INTENT(INOUT) :: err
4393  !Local Variables
4394  INTEGER(INTG) :: dummyerr
4395  TYPE(distributed_vector_type), POINTER :: residualvector,solvervector
4396  TYPE(newton_solver_type), POINTER :: newtonsolver
4397  TYPE(nonlinear_solver_type), POINTER :: nonlinearsolver
4398  TYPE(quasi_newton_solver_type), POINTER :: quasinewtonsolver
4399  TYPE(solver_equations_type), POINTER :: solverequations
4400  TYPE(solver_matrices_type), POINTER :: solvermatrices
4401  TYPE(solver_matrix_type), POINTER :: solvermatrix
4402  TYPE(varying_string) :: dummyerror,error,localerror
4403 
4404  IF(ASSOCIATED(ctx)) THEN
4405  nonlinearsolver=>ctx%NONLINEAR_SOLVER
4406  IF(ASSOCIATED(nonlinearsolver)) THEN
4407  newtonsolver=>nonlinearsolver%NEWTON_SOLVER
4408  IF(ASSOCIATED(newtonsolver)) THEN
4409  solverequations=>ctx%SOLVER_EQUATIONS
4410  IF(ASSOCIATED(solverequations)) THEN
4411  solvermatrices=>solverequations%SOLVER_MATRICES
4412  IF(ASSOCIATED(solvermatrices)) THEN
4413  IF(solvermatrices%NUMBER_OF_MATRICES==1) THEN
4414  solvermatrix=>solvermatrices%MATRICES(1)%PTR
4415  IF(ASSOCIATED(solvermatrix)) THEN
4416  solvervector=>solvermatrix%SOLVER_VECTOR
4417  IF(ASSOCIATED(solvervector)) THEN
4418  residualvector=>solvermatrices%RESIDUAL
4419  IF(ASSOCIATED(residualvector)) THEN
4420  CALL distributed_vector_override_set_on(solvervector,x,err,error,*999)
4421  CALL distributed_vector_override_set_on(residualvector,f,err,error,*999)
4422 
4423  CALL problem_solver_residual_evaluate(ctx,err,error,*999)
4424 
4425  CALL distributed_vector_override_set_off(solvervector,err,error,*999)
4426  CALL distributed_vector_override_set_off(residualvector,err,error,*999)
4427  ELSE
4428  CALL flagerror("Residual vector is not associated.",err,error,*997)
4429  ENDIF
4430  ELSE
4431  CALL flagerror("Solver vector is not associated.",err,error,*997)
4432  ENDIF
4433  ELSE
4434  CALL flagerror("Solver matrix is not associated.",err,error,*997)
4435  ENDIF
4436  ELSE
4437  localerror="The number of solver matrices of "// &
4438  & trim(numbertovstring(solvermatrices%NUMBER_OF_MATRICES,"*",err,error))// &
4439  & " is invalid. There should be 1 solver matrix."
4440  CALL flagerror(localerror,err,error,*997)
4441  ENDIF
4442  ELSE
4443  CALL flagerror("Solver equations solver matrices is not associated.",err,error,*997)
4444  ENDIF
4445  ELSE
4446  CALL flagerror("Solver solver equations is not associated.",err,error,*997)
4447  ENDIF
4448 !!TODO: move this to PROBLEM_SOLVER_RESIDUAL_EVALUATE or elsewhere?
4449  nonlinearsolver=>ctx%NONLINEAR_SOLVER
4450  IF(ASSOCIATED(nonlinearsolver)) THEN
4451  SELECT CASE(nonlinearsolver%NONLINEAR_SOLVE_TYPE)
4453  newtonsolver=>nonlinearsolver%NEWTON_SOLVER
4454  IF(ASSOCIATED(newtonsolver)) THEN
4455  newtonsolver%TOTAL_NUMBER_OF_FUNCTION_EVALUATIONS=newtonsolver%TOTAL_NUMBER_OF_FUNCTION_EVALUATIONS+1
4456  ELSE
4457  CALL flagerror("Newton solver is not associated.",err,error,*997)
4458  ENDIF
4460  quasinewtonsolver=>nonlinearsolver%QUASI_NEWTON_SOLVER
4461  IF(ASSOCIATED(quasinewtonsolver)) THEN
4462  quasinewtonsolver%TOTAL_NUMBER_OF_FUNCTION_EVALUATIONS=quasinewtonsolver%TOTAL_NUMBER_OF_FUNCTION_EVALUATIONS+1
4463  ELSE
4464  CALL flagerror("Quasi-Newton solver is not associated.",err,error,*997)
4465  ENDIF
4466  CASE DEFAULT
4467  !Do nothing?
4468  END SELECT
4469  ELSE
4470  CALL flagerror("Nonlinear solve is not associated.", err,error,*997)
4471  ENDIF
4472  ELSE
4473  CALL flagerror("Nonlinear solver Newton solver is not associated.",err,error,*997)
4474  ENDIF
4475  ELSE
4476  CALL flagerror("Solver nonlinear solver is not associated.",err,error,*997)
4477  ENDIF
4478  ELSE
4479  CALL flagerror("Solver context is not associated.",err,error,*997)
4480  ENDIF
4481 
4482  RETURN
4483 999 CALL distributed_vector_override_set_off(solvervector,dummyerr,dummyerror,*998)
4484 998 CALL distributed_vector_override_set_off(residualvector,dummyerr,dummyerror,*997)
4485 997 CALL writeerror(err,error,*996)
4486 996 CALL flagwarning("Error evaluating nonlinear residual.",err,error,*995)
4487 995 RETURN
4488 
4489 END SUBROUTINE problem_solverresidualevaluatepetsc
4490 
4491 !
4492 !================================================================================================================================
4493 !
4494 
4496 SUBROUTINE problem_solverconvergencetestpetsc(snes,iterationNumber,xnorm,gnorm,fnorm,reason,ctx,err)
4497 
4498  USE base_routines
4499  USE cmisspetsc
4500  USE cmisspetsctypes
4502  USE input_output
4503  USE kinds
4504  USE problem_routines
4505  USE solver_routines
4506  USE strings
4507  USE types
4508 
4509  IMPLICIT NONE
4510 
4511  !Argument variables
4512  TYPE(petscsnestype), INTENT(INOUT) :: snes
4513  INTEGER(INTG), INTENT(INOUT) :: iterationnumber
4514  REAL(DP), INTENT(INOUT) :: xnorm
4515  REAL(DP), INTENT(INOUT) :: gnorm
4516  REAL(DP), INTENT(INOUT) :: fnorm
4517  INTEGER(INTG), INTENT(INOUT) :: reason
4518  TYPE(solver_type), POINTER :: ctx
4519  INTEGER(INTG), INTENT(INOUT) :: err
4520  !Local Variables
4521  TYPE(petscvectype) :: x,f,y,w,g
4522  TYPE(newton_solver_type), POINTER :: newtonsolver
4523  TYPE(nonlinear_solver_type), POINTER :: nonlinearsolver
4524  TYPE(quasi_newton_solver_type), POINTER :: quasinewtonsolver
4525  TYPE(petscsneslinesearchtype) :: linesearch
4526  REAL(DP) :: energy,normalisedenergy
4527  TYPE(varying_string) :: error,localerror
4528 
4529  IF(ASSOCIATED(ctx)) THEN
4530  nonlinearsolver=>ctx%NONLINEAR_SOLVER
4531  IF(ASSOCIATED(nonlinearsolver)) THEN
4532  SELECT CASE(nonlinearsolver%NONLINEAR_SOLVE_TYPE)
4534  newtonsolver=>nonlinearsolver%NEWTON_SOLVER
4535  IF(ASSOCIATED(newtonsolver)) THEN
4536  reason=petsc_snes_converged_iterating
4537  SELECT CASE(newtonsolver%convergenceTestType)
4539  IF(iterationnumber>0) THEN
4540  CALL petsc_sneslinesearchinitialise(linesearch,err,error,*999)
4541  CALL petsc_snesgetlinesearch(snes,linesearch,err,error,*999)
4542  CALL petsc_vecinitialise(x,err,error,*999)
4543  CALL petsc_vecinitialise(f,err,error,*999)
4544  CALL petsc_vecinitialise(y,err,error,*999)
4545  CALL petsc_vecinitialise(w,err,error,*999)
4546  CALL petsc_vecinitialise(g,err,error,*999)
4547  CALL petsc_sneslinesearchgetvecs(linesearch,x,f,y,w,g,err,error,*999)
4548  CALL petsc_vecdot(y,g,energy,err,error,*999)
4549  IF(iterationnumber==1) THEN
4550  IF(abs(energy)<zero_tolerance) THEN
4551  reason=petsc_snes_converged_fnorm_abs
4552  ELSE
4553  newtonsolver%convergenceTest%energyFirstIter=energy
4554  newtonsolver%convergenceTest%normalisedEnergy=1.0
4555  ENDIF
4556  ELSE
4557  normalisedenergy=energy/newtonsolver%convergenceTest%energyFirstIter
4558  newtonsolver%convergenceTest%normalisedEnergy=normalisedenergy
4559  IF(abs(normalisedenergy)<newtonsolver%ABSOLUTE_TOLERANCE) THEN
4560  reason=petsc_snes_converged_fnorm_abs
4561  newtonsolver%convergenceTest%energyFirstIter=0.0_dp
4562  newtonsolver%convergenceTest%normalisedEnergy=0.0_dp
4563  ENDIF
4564  CALL writestring(general_output_type,"*********************************************",err,error,*999)
4565  CALL writestringvalue(general_output_type,"Normalised energy = ",normalisedenergy,err,error,*999)
4566  CALL writestring(general_output_type,"*********************************************",err,error,*999)
4567  ENDIF
4568  CALL petsc_sneslinesearchfinalise(linesearch,err,error,*999)
4569  ENDIF
4571  CALL flagerror("Differentiated ratio convergence test not implemented.",err,error,*999)
4572  CASE DEFAULT
4573  localerror="The specified convergence test type of "//trim(number_to_vstring( &
4574  & newtonsolver%convergenceTestType,"*",err,error))//" is invalid."
4575  CALL flagerror(localerror,err,error,*999)
4576  END SELECT
4577  ELSE
4578  CALL flagerror("Nonlinear solver Newton solver is not associated.",err,error,*999)
4579  ENDIF
4581  quasinewtonsolver=>nonlinearsolver%QUASI_NEWTON_SOLVER
4582  IF(ASSOCIATED(quasinewtonsolver)) THEN
4583  reason=petsc_snes_converged_iterating
4584  SELECT CASE(quasinewtonsolver%convergenceTestType)
4586  IF(iterationnumber>0) THEN
4587  CALL petsc_sneslinesearchinitialise(linesearch,err,error,*999)
4588  CALL petsc_snesgetlinesearch(snes,linesearch,err,error,*999)
4589  CALL petsc_vecinitialise(x,err,error,*999)
4590  CALL petsc_vecinitialise(f,err,error,*999)
4591  CALL petsc_vecinitialise(y,err,error,*999)
4592  CALL petsc_vecinitialise(w,err,error,*999)
4593  CALL petsc_vecinitialise(g,err,error,*999)
4594  CALL petsc_sneslinesearchgetvecs(linesearch,x,f,y,w,g,err,error,*999)
4595  CALL petsc_vecdot(y,g,energy,err,error,*999)
4596  IF(iterationnumber==1) THEN
4597  IF(abs(energy)<zero_tolerance) THEN
4598  reason=petsc_snes_converged_fnorm_abs
4599  ELSE
4600  quasinewtonsolver%convergenceTest%energyFirstIter=energy
4601  quasinewtonsolver%convergenceTest%normalisedEnergy=1.0
4602  ENDIF
4603  ELSE
4604  normalisedenergy=energy/quasinewtonsolver%convergenceTest%energyFirstIter
4605  quasinewtonsolver%convergenceTest%normalisedEnergy=normalisedenergy
4606  IF(abs(normalisedenergy)<quasinewtonsolver%ABSOLUTE_TOLERANCE) THEN
4607  reason=petsc_snes_converged_fnorm_abs
4608  quasinewtonsolver%convergenceTest%energyFirstIter=0.0_dp
4609  quasinewtonsolver%convergenceTest%normalisedEnergy=0.0_dp
4610  ENDIF
4611  CALL writestring(general_output_type,"*********************************************",err,error,*999)
4612  CALL writestringvalue(general_output_type,"Normalised energy = ",normalisedenergy,err,error,*999)
4613  CALL writestring(general_output_type,"*********************************************",err,error,*999)
4614  ENDIF
4615  CALL petsc_sneslinesearchfinalise(linesearch,err,error,*999)
4616  ELSE
4617  quasinewtonsolver%convergenceTest%energyFirstIter=0.0_dp
4618  quasinewtonsolver%convergenceTest%normalisedEnergy=0.0_dp
4619  ENDIF
4621  CALL flagerror("Differentiated ratio convergence test not implemented.",err,error,*999)
4622  CASE DEFAULT
4623  localerror="The specified convergence test type of "//trim(numbertovstring( &
4624  & quasinewtonsolver%convergenceTestType,"*",err,error))//" is invalid."
4625  CALL flagerror(localerror,err,error,*999)
4626  END SELECT
4627  ELSE
4628  CALL flagerror("Nonlinear solver quasi Newton solver is not associated.",err,error,*999)
4629  ENDIF
4630  CASE DEFAULT
4631  !Do nothing?
4632  END SELECT
4633  ELSE
4634  CALL flagerror("Solver nonlinear solver is not associated.",err,error,*999)
4635  ENDIF
4636  ELSE
4637  CALL flagerror("Solver context is not associated.",err,error,*999)
4638  ENDIF
4639 
4640  RETURN
4641 999 CALL writeerror(err,error,*998)
4642 998 CALL flagwarning("Error in convergence test.",err,error,*997)
4643 997 RETURN
4644 
4645 END SUBROUTINE problem_solverconvergencetestpetsc
4646 
4647 !
4648 !================================================================================================================================
4649 !
4650 
4651 
4653 SUBROUTINE problem_solverdaecellmlrhspetsc(ts,time,states,rates,ctx,err)
4654 
4655  USE base_routines
4656  USE cmisspetsctypes
4657  USE cmisspetsc
4658  USE problem_routines
4659  USE types
4660 
4661  IMPLICIT NONE
4662 
4663  !Argument variables
4664  TYPE(petsctstype), INTENT(INOUT) :: ts
4665  REAL(DP), INTENT(INOUT) :: time
4666  TYPE(petscvectype), INTENT(INOUT) :: states
4667  TYPE(petscvectype), INTENT(INOUT) :: rates
4668  TYPE(cellmlpetsccontexttype), POINTER :: ctx
4669  INTEGER(INTG), INTENT(INOUT) :: err
4670  !Local Variables
4671  TYPE(cellml_type), POINTER :: cellml
4672  TYPE(solver_type), POINTER :: solver
4673  TYPE(varying_string) :: error
4674  INTEGER(INTG) :: dofidx
4675  REAL(DP), POINTER :: statedata(:)
4676 
4677  NULLIFY(statedata)
4678 
4679  IF(ASSOCIATED(ctx)) THEN
4680  solver=>ctx%solver
4681  IF(ASSOCIATED(solver)) THEN
4682  cellml=>ctx%cellml
4683  IF(ASSOCIATED(cellml)) THEN
4684  dofidx=ctx%dofIdx
4685  !Get the state data
4686  NULLIFY(statedata)
4687  CALL petsc_vecgetarrayreadf90(states,statedata,err,error,*999)
4688  !Evaluate the CellML model
4689  CALL problem_solverdaecellmlrhsevaluate(cellml,time,dofidx,statedata,ctx%rates,err,error,*999)
4690  !Restore the state data
4691  CALL petsc_vecrestorearrayreadf90(states,statedata,err,error,*999)
4692  !Set the PETSc rates vector
4693  CALL petsc_vecsetvalues(rates,SIZE(statedata,1),ctx%ratesIndices,ctx%rates,petsc_insert_values,err,error,*999)
4694  CALL vecassemblybegin(rates,err,error,*999)
4695  CALL vecassemblyend(rates,err,error,*999)
4696  ELSE
4697  CALL flagerror("Context cellml is not associated.",err,error,*999)
4698  ENDIF
4699  ELSE
4700  CALL flagerror("Context solver is not associated.",err,error,*999)
4701  ENDIF
4702  ELSE
4703  CALL flagerror("Context is not associated.",err,error,*999)
4704  ENDIF
4705 
4706  RETURN
4707 999 CALL writeerror(err,error,*998)
4708 998 CALL flagwarning("Error calling Problem_SolverDAECellMLRHSPetsc routine from PETSc.",err,error,*997)
4709 997 RETURN
4710 
4711 END SUBROUTINE problem_solverdaecellmlrhspetsc
4712 
4713 
4714 !
4715 !================================================================================================================================
4716 !
4717 
4719 SUBROUTINE problem_solvernonlinearmonitorpetsc(snes,iterationNumber,residualNorm,context,err)
4720 
4721  USE base_routines
4722  USE cmisspetsctypes
4724  USE iso_varying_string
4725  USE kinds
4726  USE problem_routines
4727  USE strings
4728  USE types
4729 
4730  IMPLICIT NONE
4731 
4732  !Argument variables
4733  TYPE(petscsnestype), INTENT(INOUT) :: snes
4734  INTEGER(INTG), INTENT(INOUT) :: iterationnumber
4735  REAL(DP), INTENT(INOUT) :: residualnorm
4736  TYPE(solver_type), POINTER :: context
4737  INTEGER(INTG), INTENT(INOUT) :: err
4738  !Local Variables
4739  TYPE(nonlinear_solver_type), POINTER :: nonlinearsolver
4740  TYPE(solver_type), POINTER :: solver
4741  TYPE(varying_string) :: error
4742 
4743  IF(ASSOCIATED(context)) THEN
4744  nonlinearsolver=>context%NONLINEAR_SOLVER
4745  IF(ASSOCIATED(nonlinearsolver)) THEN
4746  solver=>nonlinearsolver%SOLVER
4747  IF(ASSOCIATED(solver)) THEN
4748  CALL problem_solvernonlinearmonitor(solver,iterationnumber,residualnorm,err,error,*999)
4749  ELSE
4750  CALL flagerror("Solver is not associated.",err,error,*999)
4751  ENDIF
4752  ELSE
4753  CALL flagerror("Solver nonlinear solver is not associated.",err,error,*999)
4754  ENDIF
4755  ELSE
4756  CALL flagerror("Solver context is not associated.",err,error,*999)
4757  ENDIF
4758 
4759  RETURN
4760 
4761 999 CALL writeerror(err,error,*998)
4762 998 CALL flagwarning("Error evaluating nonlinear residual.",err,error,*997)
4763 997 RETURN
4764 
4765 END SUBROUTINE problem_solvernonlinearmonitorpetsc
subroutine, public enters(NAME, ERR, ERROR,)
Records the entry into the named procedure and initialises the error code.
subroutine, public distributed_vector_override_set_on(DISTRIBUTED_VECTOR, OVERRIDE_VECTOR, ERR, ERROR,)
Sets the override vector for a distributed vector.
Contains information about the CellML equations for a solver.
Definition: types.f90:2475
This module handles all solver matrix and rhs routines.
This module handles all problem wide constants.
This module handles all multi physics class routines.
Converts a number to its equivalent varying string representation.
Definition: strings.f90:161
This module is a CMISS buffer module to the PETSc library.
Definition: cmiss_petsc.f90:45
subroutine, public petsc_vecsetvalues(x, n, indices, values, insertMode, err, error,)
Buffer routine to the PETSc VecSetValues routine.
This module contains types related to the PETSc library.
Contains information on the type of solver to be used.
Definition: types.f90:2777
Contains information for a Quasi-Newton line search nonlinear solver.
Definition: types.f90:2680
This module handles all elasticity class routines.
This module contains all string manipulation and transformation routines.
Definition: strings.f90:45
Flags a warning to the user.
Contains information on the solvers to be used in a control loop.
Definition: types.f90:2805
integer(intg), parameter, public solver_full_matrices
Use fully populated solver matrices.
subroutine, public petsc_snescomputejacobiandefault(snes, x, j, b, ctx, err, error,)
Buffer routine to the PETSc SNESComputeJacobianDefault routine.
This module contains routines for timing the program.
Definition: timer_f.f90:45
Contains information on the problems defined.
Definition: types.f90:3236
Contains information for a field defined on a region.
Definition: types.f90:1346
subroutine, public solver_daecellmlrhsevaluate(model, time, stateStartIdx, stateDataOffset, stateData, parameterStartIdx, parameterDataOffset, parameterData, intermediateStartIdx, intermediateDataOffset, intermediateData, rateStartIdx, rateDataOffset, rateData, err, error,)
Integrate using a forward Euler differential-algebraic equation solver.
Contains information on a control loop.
Definition: types.f90:3185
This module provides an iso_varying_string module, conformant to the API specified in ISO/IEC 1539-2:...
integer(intg), parameter, public solver_sparse_matrices
Use sparse solver matrices.
subroutine, public petsc_snescomputejacobiandefaultcolor(snes, x, j, b, ctx, err, error,)
Buffer routine to the PETSc SNESComputeJacobianDefaultColor routine.
This module handles all classical field class routines.
integer(intg), parameter, public solver_nonlinear_quasi_newton
Sequential Quasi-Newton nonlinear solver type.
Contains information for a Newton nonlinear solver.
Definition: types.f90:2659
Contains information on the solver, cellml, dof etc. for which cellml equations are to be evaluated b...
Definition: types.f90:2318
Contains information for a nonlinear solver.
Definition: types.f90:2731
subroutine, public petsc_snesgetlinesearch(snes, lineSearch, err, error,)
Buffer routine to the PETSc SNESGetLineSearch routine.
subroutine, public distributed_matrix_override_set_on(DISTRIBUTED_MATRIX, OVERRIDE_MATRIX, ERR, ERROR,)
Sets the override matrix for a distributed matrix.
subroutine, public exits(NAME)
Records the exit out of the named procedure.
This module contains all type definitions in order to avoid cyclic module references.
Definition: types.f90:70
This module contains all the low-level base routines e.g., all debug, control, and low-level communic...
integer(intg), parameter, public general_output_type
General output type.
Contains information on the solver matrix.
Definition: types.f90:2411
This module handles all fluid mechanics class routines.
Returns the specified control loop as indexed by the control loop identifier from the control loop ro...
Contains information for a Quasi-Newton nonlinear solver.
Definition: types.f90:2706
integer(intg), parameter, public solver_newton_convergence_differentiated_ratio
Sum of differentiated ratios of unconstrained to constrained residuals convergence test...
subroutine, public petsc_sneslinesearchgetvecs(lineSearch, x, f, y, w, g, err, error,)
Buffer routine to the PETSc SNESLineSearchGetVecs routine.
subroutine, public petsc_vecinitialise(x, err, error,)
Write a string followed by a value to a given output stream.
subroutine, public petsc_vecrestorearrayreadf90(x, array, err, error,)
Buffer routine to the PETSc VecRestoreArrayReadF90 routine.
integer(intg), parameter problem_setup_finish_action
Finish setup action.
Contains information about the solver equations for a solver.
Definition: types.f90:2452
Contains information for a problem.
Definition: types.f90:3221
integer(intg), parameter problem_setup_cellml_equations_type
CellML equations setup for a problem.
integer(intg), parameter, public solver_nonlinear_newton
Newton nonlinear solver type.
subroutine, public writeerror(err, error,)
Writes the error string.
Contains the information for a vector that is distributed across a number of domains.
Definition: types.f90:786
subroutine, public distributed_vector_override_set_off(DISTRIBUTED_VECTOR, ERR, ERROR,)
Turns off the override vector for a distributed vector.
This module handles all distributed matrix vector routines.
This module defines all constants shared across interface condition routines.
This module handles all solver routines.
Implements lists of Field IO operation.
This module handles all reaction diffusion equation routines.
integer(intg), parameter, public solver_matrices_jacobian_only
Select only the Jacobian solver matrix.
Contains information on the solver matrices and rhs vector.
Definition: types.f90:2427
Contains information for a field variable defined on a field.
Definition: types.f90:1289
Write a string to a given output stream.
This module handles all Galerkin projection routines.
This type is a wrapper for the C_PTR which references the actual CellML model definition object...
Definition: types.f90:2266
subroutine, public petsc_vecdot(x, y, dotProduct, err, error,)
Buffer routine to the PETSc VecDot routine.
integer(intg), parameter problem_setup_start_action
Start setup action.
subroutine, public petsc_sneslinesearchinitialise(lineSearch, err, error,)
This module handles all control loop routines.
This module defines all constants shared across equations set routines.
This module handles all bioelectric class routines.
integer(intg), parameter, public solver_matrix_output
Solver matrices output from the solver routines plus below.
subroutine, public petsc_sneslinesearchfinalise(lineSearch, err, error,)
Contains information for a Newton line search nonlinear solver.
Definition: types.f90:2626
subroutine, public distributed_matrix_override_set_off(DISTRIBUTED_MATRIX, ERR, ERROR,)
Turns off the override matrix for a distributed matrix.
This module handles all equations set routines.
subroutine, public petsc_vecgetarrayreadf90(x, array, err, error,)
Buffer routine to the PETSc VecGetArrayReadF90 routine.
Flags an error condition.
This module handles all finite elasticity routines.
integer(intg), parameter, public solver_newton_convergence_energy_norm
Energy norm convergence test.
recursive subroutine, public solver_solve(SOLVER, ERR, ERROR,)
Solve the problem.
Contains information for a CellML environment.
Definition: types.f90:2372
This module contains all kind definitions.
Definition: kinds.f90:45
subroutine, public solver_matrices_output(ID, SELECTION_TYPE, SOLVER_MATRICES, ERR, ERROR,)
Outputs the solver matrices.
This module handles all formating and input and output.