Octopus
system.F90
Go to the documentation of this file.
1!! Copyright (C) 2019 N. Tancogne-Dejean
2!! Copyright (C) 2020 M. Oliveira, Heiko Appel
3!! Copyright (C) 2021 S. Ohlmann
4!!
5!! This program is free software; you can redistribute it and/or modify
6!! it under the terms of the GNU General Public License as published by
7!! the Free Software Foundation; either version 2, or (at your option)
8!! any later version.
9!!
10!! This program is distributed in the hope that it will be useful,
11!! but WITHOUT ANY WARRANTY; without even the implied warranty of
12!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13!! GNU General Public License for more details.
14!!
15!! You should have received a copy of the GNU General Public License
16!! along with this program; if not, write to the Free Software
17!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18!! 02110-1301, USA.
19!!
20
21#include "global.h"
22
25module system_oct_m
28 use debug_oct_m
30 use global_oct_m
36 use mpi_oct_m
40 use parser_oct_m
43 use unit_oct_m
46 implicit none
47
48 private
49 public :: &
50 system_t, &
63 system_end, &
66
67 type :: barrier_t
68 logical :: active
69 real(real64) :: target_time
70 end type barrier_t
71
72 integer, parameter, public :: &
73 NUMBER_BARRIERS = 1, &
75
79 type, extends(interaction_partner_t), abstract :: system_t
80 private
81 type(iteration_counter_t), public :: iteration
82 class(algorithm_t), pointer, public :: algo => null()
83
84 integer, allocatable, public :: supported_interactions(:)
85 type(interaction_list_t), public :: interactions
86
87 type(mpi_grp_t), public :: grp
88
89 type(barrier_t) :: barrier(NUMBER_BARRIERS)
90 real(real64), public :: kinetic_energy
91 real(real64), public :: potential_energy
92 real(real64), public :: internal_energy
93 ! !! the kinetic energy of its constituents
94 real(real64), public :: total_energy
95
96 contains
97 procedure :: execute_algorithm => system_execute_algorithm
98 procedure :: reset_iteration_counters => system_reset_iteration_counters
99 procedure :: new_algorithm => system_new_algorithm
100 procedure :: algorithm_finished => system_algorithm_finished
101 procedure :: init_iteration_counters => system_init_iteration_counters
102 procedure :: create_interactions => system_create_interactions
103 procedure :: init_parallelization => system_init_parallelization
104 procedure :: update_couplings => system_update_couplings
105 procedure :: update_interactions => system_update_interactions
106 procedure :: update_interactions_start => system_update_interactions_start
107 procedure :: update_interactions_finish => system_update_interactions_finish
108 procedure :: algorithm_start => system_algorithm_start
109 procedure :: algorithm_finish => system_algorithm_finish
110 procedure :: iteration_info => system_iteration_info
111 procedure :: restart_write => system_restart_write
112 procedure :: restart_read => system_restart_read
113 procedure :: output_start => system_output_start
114 procedure :: output_write => system_output_write
115 procedure :: output_finish => system_output_finish
116 procedure :: process_is_slave => system_process_is_slave
117 procedure :: start_barrier => system_start_barrier
118 procedure :: end_barrier => system_end_barrier
119 procedure :: arrived_at_barrier => system_arrived_at_barrier
120 procedure :: arrived_at_any_barrier => system_arrived_at_any_barrier
121 procedure :: update_potential_energy => system_update_potential_energy
122 procedure :: update_internal_energy => system_update_internal_energy
123 procedure :: update_total_energy => system_update_total_energy
124 procedure(system_init_interaction), deferred :: init_interaction
125 procedure(system_initialize), deferred :: initialize
126 procedure(system_do_algorithmic_operation), deferred :: do_algorithmic_operation
127 procedure(system_is_tolerance_reached), deferred :: is_tolerance_reached
128 procedure(system_restart_write_data), deferred :: restart_write_data
129 procedure(system_restart_read_data), deferred :: restart_read_data
130 procedure(system_update_kinetic_energy), deferred :: update_kinetic_energy
131 end type system_t
132
133 abstract interface
134
135 ! ---------------------------------------------------------
141 subroutine system_init_interaction(this, interaction)
142 import system_t
143 import interaction_t
144 class(system_t), target, intent(inout) :: this
145 class(interaction_t), intent(inout) :: interaction
146 end subroutine system_init_interaction
147
148 ! ---------------------------------------------------------
150 subroutine system_initialize(this)
151 import system_t
152 class(system_t), intent(inout) :: this
153 end subroutine system_initialize
154
155 ! ---------------------------------------------------------
165 logical function system_do_algorithmic_operation(this, operation, updated_quantities) result(done)
166 import system_t
168 class(system_t), intent(inout) :: this
169 class(algorithmic_operation_t), intent(in) :: operation
170 character(len=:), allocatable, intent(out) :: updated_quantities(:)
173 ! ---------------------------------------------------------
175 logical function system_is_tolerance_reached(this, tol)
176 use, intrinsic :: iso_fortran_env
177 import system_t
178 class(system_t), intent(in) :: this
179 real(real64), intent(in) :: tol
181
182 ! ---------------------------------------------------------
186 subroutine system_store_current_status(this)
187 import system_t
188 class(system_t), intent(inout) :: this
189 end subroutine system_store_current_status
191 ! ---------------------------------------------------------
193 import system_t
194 class(system_t), intent(inout) :: this
197 ! ---------------------------------------------------------
198 ! this function returns true if restart data could be read
199 logical function system_restart_read_data(this)
200 import system_t
201 class(system_t), intent(inout) :: this
204 import system_t
205 class(system_t), intent(inout) :: this
208 end interface
215 private
216 contains
217 procedure :: add => system_list_add_node
218 procedure :: contains => system_list_contains
222 private
223 contains
224 procedure :: get_next => system_iterator_get_next
225 end type system_iterator_t
226
227contains
228
229 ! ---------------------------------------------------------
242 subroutine system_execute_algorithm(this)
243 class(system_t), intent(inout) :: this
244
245 type(algorithmic_operation_t) :: operation
246 logical :: all_updated, at_barrier, operation_done
247 type(event_handle_t) :: debug_handle
248 integer :: i
249 type(quantity_t), pointer :: quantity
250 character(len=:), allocatable :: updated_quantities(:)
251
253
254 at_barrier = .false.
255
256 do while (.not. at_barrier)
257
258 operation = this%algo%get_current_operation()
259
260 debug_handle = multisystem_debug_write_event_in(this%namespace, event_function_call_t("dt_operation", operation), &
261 system_iteration=this%iteration, algo_iteration=this%algo%iteration)
262
263 ! First try to execute the operation as a system specific operation
264 operation_done = this%do_algorithmic_operation(operation, updated_quantities)
265 if (allocated(updated_quantities)) then
266 ! Update the quantities iteration counters
267 do i = 1, size(updated_quantities)
268 quantity => this%quantities%get(updated_quantities(i))
269 call quantity%iteration%set(this%algo%iteration + 1)
270 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("quantity", quantity%label, &
271 quantity%iteration, "set"))
272 end do
273 end if
274
275 ! If not done, we try to execute it as an algorithm-specific operation.
276 if (.not. operation_done) then
277 operation_done = this%algo%do_operation(operation)
278 else
279 call this%algo%next()
280 end if
281
282 ! If still not done, the operation must be a generic operation
283 if (.not. operation_done) then
284
285 select case (operation%id)
286 case (skip)
287 ! Do nothing
288 call this%algo%next()
289
290 case (iteration_done)
291 ! Increment the system iteration by one
292 this%iteration = this%iteration + 1
293 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("system", "", this%iteration, "tick"))
294
295 ! Recompute the total energy
296 call this%update_total_energy()
297
298 ! Write output
299 call this%output_write()
300
301 ! Update elapsed time
302 call this%algo%update_elapsed_time()
303
304 ! Print information about the current iteration
305 ! (NB: needs to be done after marking the execution step as finished,
306 ! so that the timings are correct)
307 call this%iteration_info()
308
309 call this%algo%next()
312 if (.not. this%algo%finished()) then
313 if (.not. this%arrived_at_any_barrier()) then
314 ! Reset propagator for next step if not waiting at barrier
315 call this%algo%rewind()
316 else
317 at_barrier = .true.
318 end if
319 else
320 if (this%algo%continues_after_finished()) then
321 call this%algo%rewind()
322 else
323 at_barrier = .true.
324 end if
325 end if
326
327 case (update_couplings)
328 ! We increment by one algorithmic step
329 this%algo%iteration = this%algo%iteration + 1
330 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("algorithm", "", &
331 this%algo%iteration, "tick"))
332
333 ! Try to update all needed quantities from the interaction partners
334 all_updated = this%update_couplings()
336 ! Move to next algorithm step if all couplings have been
337 ! updated. Otherwise roll back the iteration counter and try again later.
338 if (all_updated) then
339 call this%algo%next()
340 else
341 this%algo%iteration = this%algo%iteration - 1
342 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("algorithm", "", &
343 this%algo%iteration, "reverse"))
344 end if
345
346 ! Couplings are implicit barriers
347 at_barrier = .true.
348
350 ! Update all the interactions
351 call this%update_interactions()
352 call this%algo%next()
353
354 case default
355 message(1) = "Unsupported algorithmic operation."
356 write(message(2), '(A,A,A)') trim(operation%id), ": ", trim(operation%label)
357 call messages_fatal(2, namespace=this%namespace)
358 end select
359 end if
360
361 call multisystem_debug_write_event_out(debug_handle, system_iteration=this%iteration, algo_iteration=this%algo%iteration)
362 end do
363
365 end subroutine system_execute_algorithm
366
367 ! ---------------------------------------------------------
368 subroutine system_reset_iteration_counters(this, accumulated_iterations)
369 class(system_t), intent(inout) :: this
370 integer, intent(in) :: accumulated_iterations
371
372 type(interaction_iterator_t) :: iter
373 class(interaction_t), pointer :: interaction
374 type(quantity_iterator_t) :: qiter
375 class(quantity_t), pointer :: quantity
376
377 character(len=MAX_INFO_LEN) :: extended_label
378
380
381 ! Propagator counter
382 this%algo%iteration = this%algo%iteration - accumulated_iterations
383 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("algorithm", "", this%algo%iteration, "reset"))
384
385 ! Interaction counters
386 call iter%start(this%interactions)
387 do while (iter%has_next())
388 interaction => iter%get_next()
389 interaction%iteration = interaction%iteration - accumulated_iterations
390
391 extended_label = trim(interaction%label)//"-"//trim(interaction%partner%namespace%get())
392 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t( "interaction", extended_label, &
393 interaction%iteration, "reset"))
394 end do
395
396 ! Internal quantities counters
397 call qiter%start(this%interactions)
398 do while(qiter%has_next())
399 quantity => qiter%get_next()
400 quantity%iteration = quantity%iteration - accumulated_iterations
401 call multisystem_debug_write_marker(this%namespace, event_iteration_update_t("quantity", quantity%label, &
402 quantity%iteration, "reset"))
403 end do
404
407
408
409 ! ---------------------------------------------------------
422 recursive subroutine system_create_interactions(this, interaction_factory, available_partners)
423 class(system_t), intent(inout) :: this
424 class(interactions_factory_abst_t), intent(in) :: interaction_factory
425 class(partner_list_t), target, intent(in) :: available_partners
426 ! !! for the given system.
427
428 logical :: in_list
429 integer :: i, ip, iq, interaction_type
430 type(partner_list_t) :: partners
431 type(partner_iterator_t) :: iter
432 class(interaction_partner_t), pointer :: partner
433 class(interaction_t), pointer :: interaction
434 type(interactions_factory_options_t), allocatable :: options(:)
435
437
438 ! Sanity checks
439 assert(allocated(this%supported_interactions))
440 assert(allocated(this%supported_interactions_as_partner))
441
442
443 ! All systems need to be connected to make sure they remain synchronized.
444 ! We enforce that be adding a ghost interaction between all systems.
445 ! Note that this recursively adds subsystems of containers.
446 call iter%start(available_partners)
447 do while (iter%has_next())
448 partner => iter%get_next()
449 call partner%add_partners_to_list(partners)
450 end do
451
452 call iter%start(partners)
453 do while (iter%has_next())
454 partner => iter%get_next()
455
456 ! No self-interaction
457 if (partner%namespace%get() == this%namespace%get()) cycle
458
459 call this%interactions%add(ghost_interaction_t(partner))
460 end do
462
463 ! Now create the non-ghost interactions:
464 ! Here we only add systems to the parters list, which support the given interaction as a partner
465 ! Note that ensemble containers do not add their subsystems to the list.
466 ! (see ensemble_oct_m::ensemble_add_parters_to_list())
467
468 call partners%empty()
469
470 ! Get options to use to create all the interactions supported by this system
471 allocate(options(0)) ! Workaround to avoid a gfortran warning
472 options = interaction_factory%options(this%namespace, this%supported_interactions)
473
474 ! Loop over all interactions supported by this system and create them according to the provided options
475 do i = 1, size(this%supported_interactions)
476 interaction_type = this%supported_interactions(i)
477
478 ! Supported interactions should only appear once in the corresponding
479 ! list, otherwise more than one interaction of the same type will be
480 ! created
481 assert(count(this%supported_interactions == interaction_type) == 1)
482
483 ! Get the list of partners that support this interaction type
484 call iter%start(available_partners)
485 do while (iter%has_next())
486 partner => iter%get_next()
487 call partner%add_partners_to_list(partners, interaction_type)
488 end do
489
490 ! Create list of partners for this interaction taking into account the selected mode
491 select case (options(i)%mode)
492 case (all_partners)
493 ! Use all available partners, so no need to modify the list
494
495 case (no_partners)
496 ! No partners for this interaction, so empty the list
497 call partners%empty()
498
499 case (only_partners)
500 ! Start with full list and remove the partners not listed in the options
501 call iter%start(partners)
502 do while (iter%has_next())
503 partner => iter%get_next()
504 in_list = .false.
505 do ip = 1, size(options(i)%partners)
506 if (partner%namespace%is_contained_in(options(i)%partners(ip))) then
507 in_list = .true.
508 exit
509 end if
510 end do
511 if (.not. in_list) then
512 call partners%delete(partner)
513 end if
514 end do
516 case (all_except)
517 ! Start with full list and remove the partners listed in the options
518 do ip = 1, size(options(i)%partners)
519 call iter%start(partners)
520 do while (iter%has_next())
521 partner => iter%get_next()
522 if (partner%namespace%is_contained_in(options(i)%partners(ip))) then
523 call partners%delete(partner)
524 end if
525 end do
526 end do
527
528 end select
529
530 ! Now actually create the interactions for the selected partners
531 call iter%start(partners)
532 do while (iter%has_next())
533 partner => iter%get_next()
534
535 interaction => interaction_factory%create(interaction_type, partner)
536
537
538 ! Set flag for self-interaction
539 interaction%intra_interaction = partner%namespace%get() == this%namespace%get()
540
541 ! Set timing and perform sanity checks
542 interaction%timing = options(i)%timing
543 if (interaction%timing == timing_exact) then
544 select type (partner => interaction%partner)
545 class is (system_t)
546 if (this%algo%iteration%global_step() /= partner%algo%iteration%global_step() .and. &
547 .not. all(partner%quantities%always_available(interaction%couplings_from_partner))) then
548 write(message(1), '(2a)') "InteractionTiming was set to exact timing, but systems ", &
549 trim(this%namespace%get())
550 write(message(2), '(3a)') "and ", trim(partner%namespace%get()), " have incompatible steps."
551 call messages_fatal(2, namespace=this%namespace)
552 end if
553 end select
554 end if
555
556 ! Initialize interaction from system and from partner
557 call this%init_interaction(interaction)
558 call interaction%partner%init_interaction_as_partner(interaction)
559
560 ! Make sure all quantities required by the interaction are available in the system and partner
561 if (allocated(interaction%system_quantities)) then
562 do iq = 1, size(interaction%system_quantities)
563 if (.not. associated(this%quantities%get(interaction%system_quantities(iq)))) then
564 write(message(1), '(5a)') "Interaction '", trim(interaction%label), "' requires quantity '", &
565 trim(interaction%system_quantities(iq)), "'"
566 write(message(2), '(3a)') "from system '", trim(this%namespace%get()), "' but it is not available."
567 call messages_fatal(2, namespace=this%namespace)
568 end if
569 end do
570 end if
571 if (allocated(interaction%couplings_from_partner)) then
572 do iq = 1, size(interaction%couplings_from_partner)
573 if (.not. associated(partner%quantities%get(interaction%couplings_from_partner(iq)))) then
574 write(message(1), '(5a)') "Interaction '", trim(interaction%label), "' requires coupling '", &
575 trim(interaction%couplings_from_partner(iq)), "'"
576 write(message(2), '(3a)') "from partner '", trim(partner%namespace%get()), "' but it is not available."
577 call messages_fatal(2, namespace=this%namespace)
578 end if
579 end do
580 end if
581
582 ! Add interaction to list
583 call this%interactions%add(interaction)
584 end do
585
586 ! Empty partner list for next interaction
587 call partners%empty()
588 end do
589
591 end subroutine system_create_interactions
592
593 ! ---------------------------------------------------------
599 logical function system_update_couplings(this) result(all_updated)
600 class(system_t), intent(inout) :: this
601
602 class(interaction_t), pointer :: interaction
603 type(interaction_iterator_t) :: iter
604
606
607 all_updated = .true.
608 call iter%start(this%interactions)
609 do while (iter%has_next())
610 interaction => iter%get_next()
611
612 select type (partner => interaction%partner)
613 class is (system_t)
614 ! If the partner is a system, we can only update its couplings if it
615 ! is not too much behind the requested iteration
616 if (partner%algo%iteration + 1 >= this%algo%iteration) then
617 call interaction%update_partner_couplings(this%algo%iteration)
618 end if
619
620 class default
621 ! Partner that are not systems can have their couplings updated at any iteration
622 call interaction%update_partner_couplings(this%algo%iteration)
623 end select
624
625 all_updated = all_updated .and. interaction%partner_couplings_up_to_date
626 end do
627
629 end function system_update_couplings
630
631 ! ---------------------------------------------------------
636 subroutine system_update_interactions(this)
637 class(system_t), intent(inout) :: this
638
639 integer :: iq, n_quantities
640 class(interaction_t), pointer :: interaction
641 type(interaction_iterator_t) :: iter
642 class(quantity_t), pointer :: quantity
643
645
646 ! Some systems might need to perform some specific operations before the
647 ! update.
648 call this%update_interactions_start()
649
650 !Loop over all interactions
651 call iter%start(this%interactions)
652 do while (iter%has_next())
653 interaction => iter%get_next()
654
655 ! Update the system quantities that will be needed for computing the interaction
656 if (allocated(interaction%system_quantities)) then
657 n_quantities = size(interaction%system_quantities)
658 else
659 n_quantities = 0
660 end if
661 do iq = 1, n_quantities
662 ! Get requested quantity
663 quantity => this%quantities%get(interaction%system_quantities(iq))
664
665 if (.not. quantity%iteration == this%algo%iteration) then
666 ! The requested quantity is not at the requested iteration
667
668 ! Sanity check: it should never happen that the quantity is in advance
669 ! with respect to the requested iteration.
670 if (quantity%iteration > this%algo%iteration) then
671 message(1) = "The quantity "//trim(quantity%label)//" is in advance compared to the requested iteration."
672 message(2) = "The interaction is "//trim(interaction%label)//"."
673 call messages_fatal(2, namespace=this%namespace)
674 end if
675
676 ! If the quantity can be updated on demand, we try to update it
677 if (quantity%updated_on_demand) then
678 call this%update_on_demand_quantity(quantity, this%algo%iteration)
679 end if
680
681 ! Quantity must be at the correct iteration, otherwise the algorithm and
682 ! the interaction are incompatible
683 if (.not. quantity%iteration == this%algo%iteration .and. .not. quantity%always_available) then
684 write(message(1), '(5a)') "Interaction ", trim(interaction%label), " is incompatible with the selected algorithm."
685 write(message(2), '(3a)') "The interaction requires the ", trim(quantity%label), &
686 " at an iteration it is not available."
687 call messages_fatal(2, namespace=this%namespace)
688 end if
689
690 end if
691
692 end do
693
694 call interaction%update(this%algo%iteration)
695 end do
696
697 ! Some systems might need to perform some specific operations after all the
698 ! interactions have been updated
699 call this%update_interactions_finish()
700
702 end subroutine system_update_interactions
703
704 ! ---------------------------------------------------------
705 subroutine system_update_interactions_start(this)
706 class(system_t), intent(inout) :: this
707
709
710 ! By default nothing is done just before updating the interactions. Child
711 ! classes that wish to change this behaviour should override this method.
712
715
716 ! ---------------------------------------------------------
717 subroutine system_update_interactions_finish(this)
718 class(system_t), intent(inout) :: this
719
721
722 ! By default nothing is done just after updating the interactions. Child
723 ! classes that wish to change this behaviour should override this method.
724
727
728 ! ---------------------------------------------------------
729 subroutine system_restart_write(this)
730 class(system_t), intent(inout) :: this
731
732 logical :: restart_write
733 type(interaction_iterator_t) :: iter
734 class(interaction_t), pointer :: interaction
735 type(quantity_iterator_t) :: qiter
736 class(quantity_t), pointer :: quantity
737
738
739 push_sub(system_restart_write)
740
741 call parse_variable(this%namespace, 'RestartWrite', .true., restart_write)
742
743 if (restart_write) then
744 ! do some generic restart steps here
745 ! write iteration counter restart data
746 call this%iteration%restart_write('restart_iteration_system', this%namespace)
747 call this%algo%iteration%restart_write('restart_iteration_algorithm', this%namespace)
748 call iter%start(this%interactions)
749 do while (iter%has_next())
750 interaction => iter%get_next()
751 call interaction%restart_write(this%namespace)
752 end do
753 call qiter%start(this%quantities)
754 do while (qiter%has_next())
755 quantity => qiter%get_next()
756 call quantity%iteration%restart_write('restart_iteration_quantity_'//trim(quantity%label), &
757 this%namespace)
758 end do
759 ! the following call is delegated to the corresponding system
760 call this%restart_write_data()
761 message(1) = "Wrote restart data for system "//trim(this%namespace%get())
762 call messages_info(1, namespace=this%namespace)
763 end if
764
765 pop_sub(system_restart_write)
766 end subroutine system_restart_write
767
768 ! ---------------------------------------------------------
769 ! this function returns true if restart data could be read
770 logical function system_restart_read(this)
771 class(system_t), intent(inout) :: this
772
773 type(interaction_iterator_t) :: iter
774 class(interaction_t), pointer :: interaction
775 type(quantity_iterator_t) :: qiter
776 class(quantity_t), pointer :: quantity
777
778 push_sub(system_restart_read)
779
780 ! do some generic restart steps here
781 ! read iteration data
782 system_restart_read = this%iteration%restart_read('restart_iteration_system', this%namespace)
784 this%algo%iteration%restart_read('restart_iteration_algorithm', this%namespace)
785 call iter%start(this%interactions)
786 do while (iter%has_next())
787 interaction => iter%get_next()
788 system_restart_read = system_restart_read .and. interaction%restart_read(this%namespace)
789 ! reduce by one because of the first UPDATE_INTERACTIONS
790 interaction%iteration = interaction%iteration - 1
791 end do
792 call qiter%start(this%quantities)
793 do while (qiter%has_next())
794 quantity => qiter%get_next()
796 quantity%iteration%restart_read('restart_iteration_quantity_'//trim(quantity%label), &
797 this%namespace)
798 if (quantity%updated_on_demand) then
799 ! decrease iteration by one for on-demand quantities to account for initial update_interactions step
800 quantity%iteration = quantity%iteration - 1
801 end if
802 end do
803 ! the following call is delegated to the corresponding system
804 system_restart_read = system_restart_read .and. this%restart_read_data()
805
806 if (system_restart_read) then
807 message(1) = "Successfully read restart data for system "//trim(this%namespace%get())
808 call messages_info(1, namespace=this%namespace)
809 end if
811 pop_sub(system_restart_read)
812 end function system_restart_read
813
814 ! ---------------------------------------------------------
815 subroutine system_output_start(this)
816 class(system_t), intent(inout) :: this
817
818 push_sub(system_output_start)
819
820 ! By default nothing is done to regarding output. Child classes that wish
821 ! to change this behaviour should override this method.
823 pop_sub(system_output_start)
824 end subroutine system_output_start
825
826 ! ---------------------------------------------------------
827 subroutine system_output_write(this)
828 class(system_t), intent(inout) :: this
829
830 push_sub(system_output_write)
831
832 ! By default nothing is done to regarding output. Child classes that wish
833 ! to change this behaviour should override this method.
834
835 pop_sub(system_output_write)
836 end subroutine system_output_write
837
838 ! ---------------------------------------------------------
839 subroutine system_output_finish(this)
840 class(system_t), intent(inout) :: this
841
842 push_sub(system_output_finish)
843
844 ! By default nothing is done to regarding output. Child classes that wish
845 ! to change this behaviour should override this method.
846
847 pop_sub(system_output_finish)
848 end subroutine system_output_finish
849
850 ! ---------------------------------------------------------
851 subroutine system_new_algorithm(this, factory)
852 class(system_t), intent(inout) :: this
853 class(algorithm_factory_t), intent(in) :: factory
854
855 integer :: ii
856
857 push_sub(system_new_algorithm)
858
859 call messages_experimental('Multi-system framework')
860
861 this%algo => factory%create(this)
862
863 call this%init_iteration_counters()
864
865 do ii = 1, number_barriers
866 this%barrier(ii)%active = .false.
867 this%barrier(ii)%target_time = m_zero
868 end do
869
870 pop_sub(system_new_algorithm)
871 end subroutine system_new_algorithm
872
873 ! ---------------------------------------------------------------------------------------
874 recursive function system_algorithm_finished(this) result(finished)
875 class(system_t), intent(in) :: this
876 logical :: finished
877
878 finished = this%algo%finished()
879
880 end function system_algorithm_finished
881
882 ! ---------------------------------------------------------
888 !
889 subroutine system_init_iteration_counters(this)
890 class(system_t), intent(inout) :: this
891
892 type(interaction_iterator_t) :: iter
893 class(interaction_t), pointer :: interaction
894 type(quantity_iterator_t) :: qiter
895 class(quantity_t), pointer :: quantity
896
898
899 ! Initialize algorithm and system counters
900 call this%algo%init_iteration_counters()
901
902 ! Interactions counters
903 call iter%start(this%interactions)
904 do while (iter%has_next())
905 interaction => iter%get_next()
906 interaction%iteration = this%algo%iteration - 1
907 end do
909 ! Quantities counters
910 call qiter%start(this%quantities)
911 do while (qiter%has_next())
912 quantity => qiter%get_next()
913 if (quantity%updated_on_demand) then
914 ! On demand quantities will be updated before first use,
915 ! hence we set the iteration counter one iteration behind the algorithms iteration counter
916 quantity%iteration = this%algo%iteration - 1
917 else
918 quantity%iteration = this%algo%iteration
919 end if
920 end do
921
923 end subroutine system_init_iteration_counters
924
925 ! ---------------------------------------------------------
926 subroutine system_algorithm_start(this)
927 class(system_t), intent(inout) :: this
928
929 logical :: all_updated
930 type(event_handle_t) :: debug_handle
931 character(len=:), allocatable :: updated_quantities(:)
933 push_sub(system_algorithm_start)
934
935 debug_handle = multisystem_debug_write_event_in(this%namespace, event_function_call_t("system_algorithm_start"), &
936 system_iteration = this%iteration, algo_iteration = this%algo%iteration)
937
938 ! Update interactions at initial iteration
939 all_updated = this%update_couplings()
940 if (.not. all_updated) then
941 message(1) = "Unable to update interactions when initializing the algorithm."
942 call messages_fatal(1, namespace=this%namespace)
943 end if
944 call this%update_interactions()
945
946 ! System-specific and algorithm-specific initialization step
947 if (this%algo%start_operation%id /= skip) then
948 if (.not. this%do_algorithmic_operation(this%algo%start_operation, updated_quantities)) then
949 message(1) = "Unsupported algorithmic operation."
950 write(message(2), '(A,A,A)') trim(this%algo%start_operation%id), ": ", trim(this%algo%start_operation%label)
951 call messages_fatal(2, namespace=this%namespace)
952 end if
953 if (allocated(updated_quantities)) then
954 message(1) = "Update of quantities not allowed in algorithmic operation."
955 write(message(2), '(A,A,A)') trim(this%algo%start_operation%id), ": ", trim(this%algo%start_operation%label)
956 call messages_fatal(2, namespace=this%namespace)
957 end if
958 end if
959
960 ! Compute the total energy at the beginning of the simulation
961 call this%update_total_energy()
962
963 ! Start output
964 call this%output_start()
965
966 ! Write header for execution log
967 call this%algo%write_output_header()
968
969 ! Rewind algorithm (will also set the initial time to compute the elapsed time)
970 call this%algo%rewind()
971
972 call multisystem_debug_write_event_out(debug_handle, system_iteration = this%iteration, algo_iteration = this%algo%iteration)
973
975 end subroutine system_algorithm_start
976
977 ! ---------------------------------------------------------
978 subroutine system_algorithm_finish(this)
979 class(system_t), intent(inout) :: this
980 type(event_handle_t) :: debug_handle
981
982 character(len=:), allocatable :: updated_quantities(:)
983
985
986 debug_handle = multisystem_debug_write_event_in(this%namespace, event_function_call_t("system_algorithm_finish"), &
987 system_iteration = this%iteration, algo_iteration = this%algo%iteration)
988
989 ! Finish output
990 call this%output_finish()
991
992 ! System-specific and algorithm-specific finalization step
993 if (this%algo%final_operation%id /= skip) then
994 if (.not. this%do_algorithmic_operation(this%algo%final_operation, updated_quantities)) then
995 message(1) = "Unsupported algorithmic operation."
996 write(message(2), '(A,A,A)') trim(this%algo%final_operation%id), ": ", trim(this%algo%final_operation%label)
997 call messages_fatal(2, namespace=this%namespace)
998 end if
999 if (allocated(updated_quantities)) then
1000 message(1) = "Update of quantities not allowed in algorithmic operation."
1001 write(message(2), '(A,A,A)') trim(this%algo%final_operation%id), ": ", trim(this%algo%final_operation%label)
1002 call messages_fatal(2, namespace=this%namespace)
1003 end if
1004 end if
1005
1006 call multisystem_debug_write_event_out(debug_handle, system_iteration = this%iteration, algo_iteration = this%algo%iteration)
1007
1009 end subroutine system_algorithm_finish
1010
1011 ! ---------------------------------------------------------
1012 subroutine system_iteration_info(this)
1013 class(system_t), intent(in) :: this
1014
1015 real(real64) :: energy
1016 character(len=40) :: fmt
1017
1018 push_sub(system_iteration_info)
1020 energy = units_from_atomic(units_out%energy, this%total_energy)
1021 if (abs(energy) >= 1e5) then
1022 fmt = '(i7,1x,f14.6,1X,es13.6,1X,i9,1X,'
1023 else
1024 fmt = '(i7,1x,f14.6,1X,f13.6,1X,i9,1X,'
1025 end if
1026 if (this%algo%elapsed_time < 1e-3) then
1027 fmt = trim(fmt)//'es13.3)'
1028 else
1029 fmt = trim(fmt)//'f13.3)'
1030 end if
1031
1032 write(message(1), fmt) this%iteration%counter(), &
1033 units_from_atomic(units_out%time, this%iteration%value()), energy, &
1034 0, this%algo%elapsed_time
1035 call messages_info(1, namespace=this%namespace)
1036
1037 pop_sub(system_iteration_info)
1038 end subroutine system_iteration_info
1039
1040 ! ---------------------------------------------------------
1041 logical function system_process_is_slave(this)
1042 class(system_t), intent(in) :: this
1043
1044 push_sub(system_process_is_slave)
1045
1046 ! By default an MPI process is not a slave
1047 system_process_is_slave = .false.
1048
1050 end function system_process_is_slave
1051
1052 ! ---------------------------------------------------------
1053 subroutine system_end(this)
1054 class(system_t), intent(inout) :: this
1055
1056 type(interaction_iterator_t) :: iter
1057 class(interaction_t), pointer :: interaction
1058
1059 push_sub(system_end)
1060
1061 ! No call to safe_deallocate macro here, as it gives an ICE with gfortran
1062 if (associated(this%algo)) then
1063 deallocate(this%algo)
1064 end if
1065
1066 call iter%start(this%interactions)
1067 do while (iter%has_next())
1068 interaction => iter%get_next()
1069 if (associated(interaction)) then
1070 deallocate(interaction)
1071 end if
1072 end do
1073
1074 pop_sub(system_end)
1075 end subroutine system_end
1076
1077 ! ---------------------------------------------------------
1079 subroutine system_list_add_node(this, partner)
1080 class(system_list_t) :: this
1081 class(interaction_partner_t), target :: partner
1082
1083 push_sub(system_list_add_node)
1084
1085 select type (partner)
1086 class is (system_t)
1087 call this%add_ptr(partner)
1088 class default
1089 assert(.false.)
1090 end select
1091
1092 pop_sub(system_list_add_node)
1093 end subroutine system_list_add_node
1094
1095 ! ---------------------------------------------------------
1096 recursive logical function system_list_contains(this, partner) result(contains)
1097 class(system_list_t) :: this
1098 class(interaction_partner_t), target :: partner
1099
1100 type(partner_iterator_t) :: iterator
1101 class(interaction_partner_t), pointer :: system
1102
1103 push_sub(system_list_contains)
1104
1105 contains = .false.
1106
1107 select type (partner)
1108 class is (system_t)
1109
1110 call iterator%start(this)
1111 do while (iterator%has_next() .and. .not. contains)
1112 system => iterator%get_next()
1113 contains = associated(system, partner)
1114 end do
1115
1116 class default
1117 contains = .false.
1118 end select
1119
1120 pop_sub(system_list_contains)
1121 end function system_list_contains
1122
1123 ! ---------------------------------------------------------
1124 function system_iterator_get_next(this) result(system)
1125 class(system_iterator_t), intent(inout) :: this
1126 class(system_t), pointer :: system
1127
1128 push_sub(system_iterator_get_next)
1129
1130 select type (ptr => this%get_next_ptr())
1131 class is (system_t)
1132 system => ptr
1133 class default
1134 assert(.false.)
1135 end select
1136
1138 end function system_iterator_get_next
1139
1140 ! ---------------------------------------------------------
1144 subroutine system_init_parallelization(this, grp)
1145 class(system_t), intent(inout) :: this
1146 type(mpi_grp_t), intent(in) :: grp
1147
1149
1150 call mpi_grp_copy(this%grp, grp)
1151 call messages_update_mpi_grp(this%namespace, grp)
1152
1154 end subroutine system_init_parallelization
1155
1156
1157
1158 ! ---------------------------------------------------------
1159 subroutine system_start_barrier(this, target_time, barrier_index)
1160 class(system_t), intent(inout) :: this
1161 real(real64), intent(in) :: target_time
1162 integer, intent(in) :: barrier_index
1163
1164 push_sub(system_start_barrier)
1165
1166 this%barrier(barrier_index)%active = .true.
1167 this%barrier(barrier_index)%target_time = target_time
1168
1169 pop_sub(system_start_barrier)
1170 end subroutine system_start_barrier
1171
1172 ! ---------------------------------------------------------
1173 subroutine system_end_barrier(this, barrier_index)
1174 class(system_t), intent(inout) :: this
1175 integer, intent(in) :: barrier_index
1176
1177 push_sub(system_end_barrier)
1178
1179 this%barrier(barrier_index)%active = .false.
1180 this%barrier(barrier_index)%target_time = m_zero
1181
1182 pop_sub(system_end_barrier)
1183 end subroutine system_end_barrier
1184
1185 ! ---------------------------------------------------------
1186 logical function system_arrived_at_barrier(this, barrier_index)
1187 class(system_t), intent(inout) :: this
1188 integer, intent(in) :: barrier_index
1190 type(iteration_counter_t) :: iteration
1191
1193
1195 if (this%barrier(barrier_index)%active) then
1196 iteration = this%iteration + 1
1197 if (iteration%value() > this%barrier(barrier_index)%target_time) then
1199 end if
1200 end if
1201
1203 end function system_arrived_at_barrier
1204
1205 ! ---------------------------------------------------------
1206 logical function system_arrived_at_any_barrier(this)
1207 class(system_t), intent(inout) :: this
1208
1209 integer :: ii
1210
1212
1214 do ii = 1, number_barriers
1216 .or. this%arrived_at_barrier(ii)
1217 end do
1218
1221
1222
1223 ! ---------------------------------------------------------
1228 subroutine system_update_potential_energy(this)
1229 class(system_t), intent(inout) :: this
1230
1231 type(interaction_iterator_t) :: iter
1232 class(interaction_t), pointer :: interaction
1233
1235
1236 this%potential_energy = m_zero
1238 call iter%start(this%interactions)
1239 do while (iter%has_next())
1240 interaction => iter%get_next()
1241 if(.not. interaction%intra_interaction) then
1242 call interaction%calculate_energy()
1243 this%potential_energy = this%potential_energy + interaction%energy
1244 end if
1245 end do
1246
1248 end subroutine system_update_potential_energy
1249
1250 ! ---------------------------------------------------------
1255 subroutine system_update_internal_energy(this)
1256 class(system_t), intent(inout) :: this
1257
1258 type(interaction_iterator_t) :: iter
1259 class(interaction_t), pointer :: interaction
1260
1262
1263 this%internal_energy = m_zero
1264 call iter%start(this%interactions)
1265 do while (iter%has_next())
1266 interaction => iter%get_next()
1267 if(interaction%intra_interaction) then
1268 call interaction%calculate_energy()
1269 this%internal_energy = this%internal_energy + interaction%energy
1270 end if
1271 end do
1272
1274 end subroutine system_update_internal_energy
1275
1276 ! ---------------------------------------------------------
1280 subroutine system_update_total_energy(this)
1281 class(system_t), intent(inout) :: this
1282
1284
1285 call this%update_kinetic_energy()
1286 this%total_energy = this%kinetic_energy
1287
1289 call this%update_potential_energy()
1290 this%total_energy = this%total_energy + this%potential_energy
1291
1293 call this%update_internal_energy()
1294 this%total_energy = this%total_energy + this%internal_energy
1295
1297 end subroutine system_update_total_energy
1298
1300
1301!! Local Variables:
1302!! mode: f90
1303!! coding: utf-8
1304!! End:
Execute one operation that is part of a larger algorithm. Returns true if the operation was successfu...
Definition: system.F90:258
initialize a given interaction of the system
Definition: system.F90:234
set initial conditions for a system
Definition: system.F90:243
check whether a system has reached a given tolerance
Definition: system.F90:268
For some algorithms it might be necessary to store the status of a system at a given algorithmic step...
Definition: system.F90:279
This module defines the abstract interfact for algorithm factories.
This module implements the basic elements defining algorithms.
Definition: algorithm.F90:141
character(len=algo_label_len), parameter, public update_interactions
Definition: algorithm.F90:172
character(len=algo_label_len), parameter, public rewind_algorithm
Definition: algorithm.F90:172
character(len=algo_label_len), parameter, public update_couplings
Definition: algorithm.F90:172
character(len=algo_label_len), parameter, public iteration_done
Definition: algorithm.F90:172
character(len=algo_label_len), parameter, public skip
Operations that can be used by any algorithm and, therefore, should be implemented by all systems.
Definition: algorithm.F90:172
real(real64), parameter, public m_zero
Definition: global.F90:188
This module defines the abstract interaction_t class, and some auxiliary classes for interactions.
integer, parameter, public timing_exact
This module defines classes and functions for interaction partners.
This module defines the abstract class for the interaction factory.
integer, parameter, public only_partners
This module implements fully polymorphic linked lists, and some specializations thereof.
subroutine, public messages_update_mpi_grp(namespace, mpigrp)
Definition: messages.F90:371
character(len=256), dimension(max_lines), public message
to be output by fatal, warning
Definition: messages.F90:160
subroutine, public messages_fatal(no_lines, only_root_writes, namespace)
Definition: messages.F90:414
subroutine, public messages_experimental(name, namespace)
Definition: messages.F90:1085
subroutine, public messages_info(no_lines, iunit, debug_only, stress, all_nodes, namespace)
Definition: messages.F90:616
subroutine mpi_grp_copy(mpi_grp_out, mpi_grp_in)
Definition: mpi.F90:407
This module implements the multisystem debug functionality.
subroutine, public multisystem_debug_write_marker(system_namespace, event)
type(event_handle_t) function, public multisystem_debug_write_event_in(system_namespace, event, extra, system_iteration, algo_iteration, interaction_iteration, partner_iteration, requested_iteration)
subroutine, public multisystem_debug_write_event_out(handle, extra, update, system_iteration, algo_iteration, interaction_iteration, partner_iteration, requested_iteration)
This module defines the quantity_t class and the IDs for quantities, which can be exposed by a system...
Definition: quantity.F90:138
This module implements the abstract system type.
Definition: system.F90:118
subroutine, public system_algorithm_start(this)
Definition: system.F90:1020
subroutine, public system_update_total_energy(this)
Calculate the total energy of the system. The total energy is defined as the sum of the kinetic,...
Definition: system.F90:1374
subroutine system_iteration_info(this)
Definition: system.F90:1106
subroutine, public system_init_iteration_counters(this)
Initialize the iteration counters of the system and its interactions, algorithms and quantities.
Definition: system.F90:983
integer, parameter, public barrier_restart
Definition: system.F90:165
subroutine system_update_internal_energy(this)
Calculate the internal energy of the system. The internal energy is defined as the sum of all energie...
Definition: system.F90:1349
logical function system_arrived_at_any_barrier(this)
Definition: system.F90:1300
recursive logical function system_list_contains(this, partner)
Definition: system.F90:1190
subroutine, public system_restart_write(this)
Definition: system.F90:823
subroutine, public system_update_potential_energy(this)
Calculate the potential energy of the system. The potential energy is defined as the sum of all energ...
Definition: system.F90:1322
subroutine, public system_init_parallelization(this, grp)
Basic functionality: copy the MPI group. This function needs to be implemented by extended types that...
Definition: system.F90:1238
subroutine system_output_start(this)
Definition: system.F90:909
subroutine system_update_interactions_start(this)
Definition: system.F90:799
subroutine, public system_algorithm_finish(this)
Definition: system.F90:1072
subroutine system_start_barrier(this, target_time, barrier_index)
Definition: system.F90:1253
recursive subroutine, public system_create_interactions(this, interaction_factory, available_partners)
create the interactions of the system
Definition: system.F90:516
subroutine, public system_end(this)
Definition: system.F90:1147
subroutine system_output_write(this)
Definition: system.F90:921
subroutine system_update_interactions_finish(this)
Definition: system.F90:811
subroutine, public system_execute_algorithm(this)
perform one or more algorithmic operations
Definition: system.F90:336
subroutine system_update_interactions(this)
Attempt to update all interactions of the system.
Definition: system.F90:730
class(system_t) function, pointer system_iterator_get_next(this)
Definition: system.F90:1218
logical function system_update_couplings(this)
Update the couplings (quantities) of the interaction partners.
Definition: system.F90:693
logical function system_process_is_slave(this)
Definition: system.F90:1135
logical function system_arrived_at_barrier(this, barrier_index)
Definition: system.F90:1280
recursive logical function system_algorithm_finished(this)
Definition: system.F90:968
logical function, public system_restart_read(this)
Definition: system.F90:864
subroutine, public system_new_algorithm(this, factory)
Definition: system.F90:945
subroutine system_output_finish(this)
Definition: system.F90:933
subroutine system_list_add_node(this, partner)
add system to list
Definition: system.F90:1173
subroutine, public system_reset_iteration_counters(this, accumulated_iterations)
Definition: system.F90:462
subroutine system_end_barrier(this, barrier_index)
Definition: system.F90:1267
brief This module defines the class unit_t which is used by the unit_systems_oct_m module.
Definition: unit.F90:132
This module defines the unit system, used for input and output.
type(unit_system_t), public units_out
Abstract class for the algorithm factories.
Descriptor of one algorithmic operation.
Definition: algorithm.F90:163
The ghost ineraction is a dummy interaction, which needs to be setup between otherwise non-interactin...
These class extend the list and list iterator to make an interaction list.
abstract interaction class
abstract class for general interaction partners
type for storing options to be used when creating a given interaction
This class implements the iteration counter used by the multisystem algorithms. As any iteration coun...
This class implements an iterator for the polymorphic linked list.
This is defined even when running serial.
Definition: mpi.F90:142
handle to keep track of in- out- events
Systems (system_t) can expose quantities that can be used to calculate interactions with other system...
Definition: quantity.F90:171
These classes extends the list and list iterator to create a system list.
Definition: system.F90:307
Abstract class for systems.
Definition: system.F90:172
int true(void)