Index: trunk/src/system/system.nw =================================================================== --- trunk/src/system/system.nw (revision 8770) +++ trunk/src/system/system.nw (revision 8771) @@ -1,4230 +1,4860 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: system interfaces \chapter{System: Interfaces and Handlers} \includemodulegraph{system} Here, we collect modules that deal with the ``system'': operating-system interfaces, error handlers and diagnostics. \begin{description} \item[system\_defs] Constants relevant for the modules in this set. \item[diagnostics] Error and diagnostic message handling. Any messages and errors issued by WHIZARD functions are handled by the subroutines in this module, if possible. \item[os\_interface] Execute system calls, build and link external object files and libraries. \item[cputime] Timer data type and methods, for measuring performance. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Constants} The parameters here are used in various parts of the program, starting from the modules in the current chapter. Some of them may be modified if the need arises. <<[[system_defs.f90]]>>= <> module system_defs use, intrinsic :: iso_fortran_env, only: iostat_end, iostat_eor !NODEP! <> <> end module system_defs @ %def system_defs @ \subsection{Version} The version string is used for checking files. Note that the string length MUST NOT be changed, because reading binary files relies on it. <>= integer, parameter, public :: VERSION_STRLEN = 255 character(len=VERSION_STRLEN), parameter, public :: & & VERSION_STRING = "WHIZARD version <> (<>)" @ %def VERSION_STRLEN VERSION_STRING @ \subsection{Text Buffer} There is a hard limit on the line length which we should export. This buffer size is used both by the message handler, the lexer, and some further modules. <>= integer, parameter, public :: BUFFER_SIZE = 1000 @ %def BUFFER_SIZE @ \subsection{IOSTAT Codes} Defined in [[iso_fortran_env]], but we would like to use shorthands. <>= integer, parameter, public :: EOF = iostat_end, EOR = iostat_eor @ %def EOF EOR @ \subsection{Character Codes} Single-character constants. <>= character, parameter, public :: BLANK = ' ' character, parameter, public :: TAB = achar(9) character, parameter, public :: CR = achar(13) character, parameter, public :: LF = achar(10) character, parameter, public :: BACKSLASH = achar(92) @ %def BLANK TAB CR NL @ Character strings that indicate character classes. <>= character(*), parameter, public :: WHITESPACE_CHARS = BLANK// TAB // CR // LF character(*), parameter, public :: LCLETTERS = "abcdefghijklmnopqrstuvwxyz" character(*), parameter, public :: UCLETTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" character(*), parameter, public :: DIGITS = "0123456789" @ %def WHITESPACE_CHARS LCLETTERS UCLETTERS DIGITS @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for sigaction} This implements calls to [[sigaction]] and the appropriate signal handlers in C. The functionality is needed for the [[diagnostics]] module. <<[[signal_interface.c]]>>= /* <> */ #include #include extern int wo_sigint; extern int wo_sigterm; extern int wo_sigxcpu; extern int wo_sigxfsz; static void wo_handler_sigint (int sig) { wo_sigint = sig; } static void wo_handler_sigterm (int sig) { wo_sigterm = sig; } static void wo_handler_sigxcpu (int sig) { wo_sigxcpu = sig; } static void wo_handler_sigxfsz (int sig) { wo_sigxfsz = sig; } int wo_mask_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigint; return sigaction(SIGINT, &sa, NULL); } int wo_mask_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigterm; return sigaction(SIGTERM, &sa, NULL); } int wo_mask_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxcpu; return sigaction(SIGXCPU, &sa, NULL); } int wo_mask_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = wo_handler_sigxfsz; return sigaction(SIGXFSZ, &sa, NULL); } int wo_release_sigint () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGINT, &sa, NULL); } int wo_release_sigterm () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGTERM, &sa, NULL); } int wo_release_sigxcpu () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXCPU, &sa, NULL); } int wo_release_sigxfsz () { struct sigaction sa; sigset_t blocks; sigfillset (&blocks); sa.sa_flags = 0; sa.sa_mask = blocks; sa.sa_handler = SIG_DFL; return sigaction(SIGXFSZ, &sa, NULL); } @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{C wrapper for printf} The [[printf]] family of functions is implemented in C with an undefined number of arguments. This is not supported by the [[bind(C)]] interface. We therefore write wrappers for the versions of [[sprintf]] that we will actually use. This is used by the [[formats]] module. <<[[sprintf_interface.c]]>>= /* <> */ #include int sprintf_none(char* str, const char* format) { return sprintf(str, format); } int sprintf_int(char* str, const char* format, int val) { return sprintf(str, format, val); } int sprintf_double(char* str, const char* format, double val) { return sprintf(str, format, val); } int sprintf_str(char* str, const char* format, const char* val) { return sprintf(str, format, val); } <>= interface function sprintf_none (str, fmt) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt end function sprintf_none end interface interface function sprintf_int (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt integer(c_int), value :: val end function sprintf_int end interface interface function sprintf_double (str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt real(c_double), value :: val end function sprintf_double end interface interface function sprintf_str(str, fmt, val) result (stat) bind(C) use iso_c_binding !NODEP! integer(c_int) :: stat character(c_char), dimension(*), intent(inout) :: str character(c_char), dimension(*), intent(in) :: fmt character(c_char), dimension(*), intent(in) :: val end function sprintf_str end interface @ %def sprintf_int sprintf_double sprintf_str @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Error, Message and Signal Handling} We are not so ambitious as to do proper exception handling in [[WHIZARD]], but at least it may be useful to have a common interface for diagnostics: Results, messages, warnings, and such. As module variables we keep a buffer where the current message may be written to and a level indicator which tells which messages should be written on screen and which ones should be skipped. Alternatively, a string may be directly supplied to the message routine: this overrides the buffer, avoiding the necessety of formatted I/O in trivial cases. <<[[diagnostics.f90]]>>= <> module diagnostics use, intrinsic :: iso_c_binding !NODEP! - use, intrinsic :: iso_fortran_env, only: output_unit !NODEP! <> <> -<> - use string_utils, only: str - use io_units - use system_dependencies use system_defs, only: BUFFER_SIZE, MAX_ERRORS <> <> <> <> <> <> -contains - -<> + interface +<> + end interface end module diagnostics - <> @ %def diagnostics @ +<<[[diagnostics_sub.f90]]>>= +<> + +submodule (diagnostics) diagnostics_s + + use, intrinsic :: iso_fortran_env, only: output_unit !NODEP! + + use system_dependencies +<> + use string_utils, only: str + use io_units + +contains + +<> + +end submodule diagnostics_s + +@ %def diagnostics_s +@ Diagnostics levels: <>= public :: RESULT, DEBUG, DEBUG2 <>= integer, parameter :: TERMINATE=-2, BUG=-1, FATAL=1, & ERROR=2, WARNING=3, MESSAGE=4, RESULT=5, & DEBUG=6, DEBUG2=7 @ %def FATAL ERROR WARNING MESSAGE RESULT DEBUG DEBUG2 Diagnostics areas: <>= public :: d_area <>= interface d_area module procedure d_area_of_string module procedure d_area_to_string end interface +<>= + module function d_area_of_string (string) result (i) + integer :: i + type(string_t), intent(in) :: string + end function d_area_of_string + + elemental module function d_area_to_string (i) result (string) + type(string_t) :: string + integer, intent(in) :: i + end function d_area_to_string <>= - function d_area_of_string (string) result (i) + module function d_area_of_string (string) result (i) integer :: i type(string_t), intent(in) :: string select case (char (string)) case ("particles") i = D_PARTICLES case ("events") i = D_EVENTS case ("shower") i = D_SHOWER case ("model_features") i = D_MODEL_F case ("matching") i = D_MATCHING case ("transforms") i = D_TRANSFORMS case ("subtraction") i = D_SUBTRACTION case ("virtual") i = D_VIRTUAL case ("threshold") i = D_THRESHOLD case ("phasespace") i = D_PHASESPACE case ("mismatch") i = D_MISMATCH case ("me_methods") i = D_ME_METHODS case ("process_integration") i = D_PROCESS_INTEGRATION case ("tauola") i = D_TAUOLA case ("core") i = D_CORE case ("vamp2") i = D_VAMP2 case ("mpi") i = D_MPI case ("qft") i = D_QFT case ("beams") i = D_BEAMS case ("real") i = D_REAL case ("flavor") i = D_FLAVOR case ("all") i = D_ALL case default print "(A)", "Possible values for --debug are:" do i = 0, D_LAST print "(A)", char (' ' // d_area_to_string(i)) end do call msg_fatal ("Please use one of the listed areas") end select end function d_area_of_string - elemental function d_area_to_string (i) result (string) + elemental module function d_area_to_string (i) result (string) type(string_t) :: string integer, intent(in) :: i select case (i) case (D_PARTICLES) string = "particles" case (D_EVENTS) string = "events" case (D_SHOWER) string = "shower" case (D_MODEL_F) string = "model_features" case (D_MATCHING) string = "matching" case (D_TRANSFORMS) string = "transforms" case (D_SUBTRACTION) string = "subtraction" case (D_VIRTUAL) string = "virtual" case (D_THRESHOLD) string = "threshold" case (D_PHASESPACE) string = "phasespace" case (D_MISMATCH) string = "mismatch" case (D_ME_METHODS) string = "me_methods" case (D_PROCESS_INTEGRATION) string = "process_integration" case (D_TAUOLA) string = "tauola" case (D_CORE) string = "core" case (D_VAMP2) string = "vamp2" case (D_MPI) string = "mpi" case (D_QFT) string = "qft" case (D_BEAMS) string = "beams" case (D_REAL) string = "real" case (D_FLAVOR) string = "flavor" case (D_ALL) string = "all" case default string = "undefined" end select end function d_area_to_string @ %def d_area @ <>= public :: D_PARTICLES, D_EVENTS, D_SHOWER, D_MODEL_F, & D_MATCHING, D_TRANSFORMS, D_SUBTRACTION, D_VIRTUAL, D_THRESHOLD, & D_PHASESPACE, D_MISMATCH, D_ME_METHODS, D_PROCESS_INTEGRATION, & D_TAUOLA, D_CORE, D_VAMP2, D_MPI, D_QFT, D_BEAMS, D_REAL, D_FLAVOR <>= integer, parameter :: D_ALL=0, D_PARTICLES=1, D_EVENTS=2, & D_SHOWER=3, D_MODEL_F=4, & D_MATCHING=5, D_TRANSFORMS=6, & D_SUBTRACTION=7, D_VIRTUAL=8, D_THRESHOLD=9, D_PHASESPACE=10, & D_MISMATCH=11, D_ME_METHODS=12, D_PROCESS_INTEGRATION=13, & D_TAUOLA=14, D_CORE=15, D_VAMP2 = 16, D_MPI = 17, D_QFT = 18, & D_BEAMS=19, D_REAL=20, D_FLAVOR=21, D_LAST=21 @ %def D_ALL D_PARTICLES D_EVENTS @ %def D_SHOWER D_MODEL_F D_MATCHING D_TRANSFORMS @ %def D_SUBTRACTION D_VIRTUAL D_THRESHOLD D_PHASESPACE @ %def D_MISMATCH D_ME_METHODS D_PROCESS_INTEGRATION @ %def D_TAUOLA D_CORE D_VAMP2 D_MPI D_QFT @ <>= public :: msg_level <>= integer, save, dimension(D_ALL:D_LAST) :: msg_level = RESULT @ %def msg_level @ <>= integer, parameter, public :: COL_UNDEFINED = -1 integer, parameter, public :: COL_GREY = 90, COL_PEACH = 91, COL_LIGHT_GREEN = 92, & COL_LIGHT_YELLOW = 93, COL_LIGHT_BLUE = 94, COL_PINK = 95, & COL_LIGHT_AQUA = 96, COL_PEARL_WHITE = 97, COL_BLACK = 30, & COL_RED = 31, COL_GREEN = 32, COL_YELLOW = 33, COL_BLUE = 34, & COL_PURPLE = 35, COL_AQUA = 36 @ %def COLORS @ <>= public :: set_debug_levels +<>= + module subroutine set_debug_levels (area_str) + type(string_t), intent(in) :: area_str + end subroutine set_debug_levels <>= - subroutine set_debug_levels (area_str) + module subroutine set_debug_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG else msg_level(area) = DEBUG end if end subroutine set_debug_levels @ %def set_debug_levels @ <>= public :: set_debug2_levels +<>= + module subroutine set_debug2_levels (area_str) + type(string_t), intent(in) :: area_str + end subroutine set_debug2_levels <>= - subroutine set_debug2_levels (area_str) + module subroutine set_debug2_levels (area_str) type(string_t), intent(in) :: area_str integer :: area if (.not. debug_on) call msg_fatal ("Debugging options & &can be used only if configured with --enable-fc-debug") area = d_area (area_str) if (area == D_ALL) then msg_level = DEBUG2 else msg_level(area) = DEBUG2 end if end subroutine set_debug2_levels @ %def set_debug2_levels @ <>= type :: terminal_color_t integer :: color = COL_UNDEFINED contains <> end type terminal_color_t @ %def terminal_color_t @ <>= public :: term_col <>= interface term_col module procedure term_col_int module procedure term_col_char end interface term_col @ %def term_col @ +<>= + module function term_col_int (col_int) result (color) + type(terminal_color_t) :: color + integer, intent(in) :: col_int + end function term_col_int + + module function term_col_char (col_char) result (color) + type(terminal_color_t) :: color + character(len=*), intent(in) :: col_char + end function term_col_char <>= - function term_col_int (col_int) result (color) + module function term_col_int (col_int) result (color) type(terminal_color_t) :: color integer, intent(in) :: col_int color%color = col_int end function term_col_int - function term_col_char (col_char) result (color) + module function term_col_char (col_char) result (color) type(terminal_color_t) :: color character(len=*), intent(in) :: col_char type(string_t) :: buf select case (col_char) case ('Grey') color%color = COL_GREY case ('Peach') color%color = COL_PEACH case ('Light Green') color%color = COL_LIGHT_GREEN case ('Light Yellow') color%color = COL_LIGHT_YELLOW case ('Light Blue') color%color = COL_LIGHT_BLUE case ('Pink') color%color = COL_PINK case ('Light Aqua') color%color = COL_LIGHT_AQUA case ('Pearl White') color%color = COL_PEARL_WHITE case ('Black') color%color = COL_BLACK case ('Red') color%color = COL_RED case ('Green') color%color = COL_GREEN case ('Yellow') color%color = COL_YELLOW case ('Blue') color%color = COL_BLUE case ('Purple') color%color = COL_PURPLE case ('Aqua') color%color = COL_AQUA case default buf = var_str ('Color ') // var_str (col_char) // var_str (' is not defined') call msg_warning (char (buf)) color%color = COL_UNDEFINED end select end function term_col_char + +@ %def term_col_int term_col_char @ Mask fatal errors so that are treated as normal errors. Useful for interactive mode. <>= public :: mask_fatal_errors <>= logical, save :: mask_fatal_errors = .false. @ %def mask_fatal_errors @ How to handle bugs and unmasked fatal errors. Either execute a normal stop statement, or call the C [[exit()]] function, or try to cause a program crash by dereferencing a null pointer. These procedures are appended to the [[diagnostics]] source code, but not as module procedures but as external procedures. This avoids a circular module dependency across source directories. <>= integer, parameter, public :: TERM_STOP = 0, TERM_EXIT = 1, TERM_CRASH = 2 @ %def TERM_STOP TERM_EXIT TERM_CRASH <>= public :: handle_fatal_errors <>= integer, save :: handle_fatal_errors = TERM_EXIT <>= subroutine fatal_force_crash () use diagnostics, only: handle_fatal_errors, TERM_CRASH !NODEP! implicit none handle_fatal_errors = TERM_CRASH end subroutine fatal_force_crash subroutine fatal_force_exit () use diagnostics, only: handle_fatal_errors, TERM_EXIT !NODEP! implicit none handle_fatal_errors = TERM_EXIT end subroutine fatal_force_exit subroutine fatal_force_stop () use diagnostics, only: handle_fatal_errors, TERM_STOP !NODEP! implicit none handle_fatal_errors = TERM_STOP end subroutine fatal_force_stop @ %def fatal_force_crash @ %def fatal_force_exit @ %def fatal_force_stop @ Keep track of errors. This might be used for exception handling, later. The counter is incremented only for screen messages, to avoid double counting. <>= public :: msg_count <>= integer, dimension(TERMINATE:WARNING), save :: msg_count = 0 @ %def msg_count @ Keep a list of all errors and warnings. Since we do not know the number of entries beforehand, we use a linked list. <>= type :: string_list character(len=BUFFER_SIZE) :: string type(string_list), pointer :: next end type string_list type :: string_list_pointer type(string_list), pointer :: first, last end type string_list_pointer @ %def string_list string_list_pointer <>= type(string_list_pointer), dimension(TERMINATE:WARNING), save :: & & msg_list = string_list_pointer (null(), null()) @ %def msg_list @ Create a format string indicating color @ Add the current message buffer contents to the internal list. <>= subroutine msg_add (level) integer, intent(in) :: level type(string_list), pointer :: message select case (level) case (TERMINATE:WARNING) allocate (message) message%string = msg_buffer nullify (message%next) if (.not.associated (msg_list(level)%first)) & & msg_list(level)%first => message if (associated (msg_list(level)%last)) & & msg_list(level)%last%next => message msg_list(level)%last => message msg_count(level) = msg_count(level) + 1 end select end subroutine msg_add @ %def msg_add @ Initialization: <>= public :: msg_list_clear +<>= + module subroutine msg_list_clear + end subroutine msg_list_clear <>= - subroutine msg_list_clear + module subroutine msg_list_clear integer :: level type(string_list), pointer :: message do level = TERMINATE, WARNING do while (associated (msg_list(level)%first)) message => msg_list(level)%first msg_list(level)%first => message%next deallocate (message) end do nullify (msg_list(level)%last) end do msg_count = 0 end subroutine msg_list_clear @ %def msg_list_clear @ Display the summary of errors and warnings (no need to count fatals\ldots) <>= public :: msg_summary +<>= + module subroutine msg_summary (unit) + integer, intent(in), optional :: unit + end subroutine msg_summary <>= - subroutine msg_summary (unit) + module subroutine msg_summary (unit) integer, intent(in), optional :: unit call expect_summary (unit) 1 format (A,1x,I2,1x,A,I2,1x,A) if (msg_count(ERROR) > 0 .and. msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) else if (msg_count(ERROR) > 0) then write (msg_buffer, 1) "There were", & & msg_count(ERROR), "error(s) and no warnings." call msg_message (unit=unit) else if (msg_count(WARNING) > 0) then write (msg_buffer, 1) "There were no errors and ", & & msg_count(WARNING), "warning(s)." call msg_message (unit=unit) end if end subroutine msg_summary @ %def msg_summary @ Print the list of all messages of a given level. <>= public :: msg_listing +<>= + module subroutine msg_listing (level, unit, prefix) + integer, intent(in) :: level + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: prefix + end subroutine msg_listing <>= - subroutine msg_listing (level, unit, prefix) + module subroutine msg_listing (level, unit, prefix) integer, intent(in) :: level integer, intent(in), optional :: unit character(len=*), intent(in), optional :: prefix type(string_list), pointer :: message integer :: u u = given_output_unit (unit); if (u < 0) return if (present (unit)) u = unit message => msg_list(level)%first do while (associated (message)) if (present (prefix)) then write (u, "(A)") prefix // trim (message%string) else write (u, "(A)") trim (message%string) end if message => message%next end do flush (u) end subroutine msg_listing @ %def msg_listing @ The message buffer: <>= public :: msg_buffer <>= character(len=BUFFER_SIZE), save :: msg_buffer = " " @ %def msg_buffer @ After a message is issued, the buffer should be cleared: <>= subroutine buffer_clear msg_buffer = " " end subroutine buffer_clear @ %def buffer_clear <>= public :: create_col_string +<>= + module function create_col_string (color) result (col_string) + type(string_t) :: col_string + integer, intent(in) :: color + end function create_col_string <>= - function create_col_string (color) result (col_string) + module function create_col_string (color) result (col_string) type(string_t) :: col_string integer, intent(in) :: color character(2) :: buf write (buf, '(I2)') color col_string = var_str ("[") // var_str (buf) // var_str ("m") end function create_col_string @ %def create_col_string @ The generic handler for messages. If the unit is omitted (or $=6$), the message is written to standard output if the precedence if sufficiently high (as determined by the value of [[msg_level]]). If the string is omitted, the buffer is used. In any case, the buffer is cleared after printing. In accordance with FORTRAN custom, the first column in the output is left blank. For messages and warnings, an additional exclamation mark and a blank is prepended. Furthermore, each message is appended to the internal message list (without prepending anything). <>= subroutine message_print (level, string, str_arr, unit, logfile, area, color) integer, intent(in) :: level character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: str_arr integer, intent(in), optional :: unit logical, intent(in), optional :: logfile integer, intent(in), optional :: area integer, intent(in), optional :: color type(string_t) :: col_string, prep_string, aux_string, head_footer, app_string integer :: lu, i, ar logical :: severe, is_error ar = D_ALL; if (present (area)) ar = area severe = .false. head_footer = "******************************************************************************" aux_string = "" is_error = .false. app_string = "" select case (level) case (TERMINATE) prep_string = "" case (BUG) prep_string = "*** WHIZARD BUG: " aux_string = "*** " severe = .true. is_error = .true. case (FATAL) prep_string = "*** FATAL ERROR: " aux_string = "*** " severe = .true. is_error = .true. case (ERROR) prep_string = "*** ERROR: " aux_string = "*** " is_error = .true. case (WARNING) prep_string = "Warning: " case (MESSAGE) prep_string = "| " case (DEBUG, DEBUG2) prep_string = "D: " case default prep_string = "" end select if (present (color)) then if (color > COL_UNDEFINED) then col_string = create_col_string (color) prep_string = achar(27) // col_string // prep_string app_string = app_string // achar(27) // "[0m" end if end if if (present(string)) msg_buffer = string lu = log_unit if (present(unit)) then if (unit /= output_unit) then if (severe) write (unit, "(A)") char(head_footer) if (is_error) write (unit, "(A)") char(head_footer) write (unit, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (unit, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (unit, "(A)") char(head_footer) if (severe) write (unit, "(A)") char(head_footer) flush (unit) lu = -1 else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) if (unit == log_unit) lu = -1 end if else if (level <= msg_level(ar)) then if (severe) print "(A)", char(head_footer) if (is_error) print "(A)", char(head_footer) print "(A,A,A)", char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) print "(A,A)", char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) print "(A)", char(head_footer) if (severe) print "(A)", char(head_footer) flush (output_unit) end if if (present (logfile)) then if (.not. logfile) lu = -1 end if if (logging .and. lu >= 0) then if (severe) write (lu, "(A)") char(head_footer) if (is_error) write (lu, "(A)") char(head_footer) write (lu, "(A,A,A)") char(prep_string), trim(msg_buffer), & char(app_string) if (present (str_arr)) then do i = 1, size(str_arr) write (lu, "(A,A)") char(aux_string), char(trim(str_arr(i))) end do end if if (is_error) write (lu, "(A)") char(head_footer) if (severe) write (lu, "(A)") char(head_footer) flush (lu) end if call msg_add (level) call buffer_clear end subroutine message_print @ %def message_print @ The number of non-fatal errors that we allow before stopping the program. We might trade this later for an adjustable number. <>= integer, parameter, public :: MAX_ERRORS = 10 @ %def MAX_ERRORS @ The specific handlers. In the case of fatal errors, bugs (failed assertions) and normal termination execution is stopped. For non-fatal errors a message is printed to standard output if no unit is given. Only if the number of [[MAX_ERRORS]] errors is reached, we abort the program. There are no further actions in the other cases, but this may change. <>= public :: msg_terminate public :: msg_bug, msg_fatal, msg_error, msg_warning public :: msg_message, msg_result +<>= + module subroutine msg_terminate (string, unit, quit_code) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + integer, intent(in), optional :: quit_code + end subroutine msg_terminate + + module subroutine msg_bug (string, arr, unit) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + type(string_t), dimension(:), intent(in), optional :: arr + end subroutine msg_bug + + recursive module subroutine msg_fatal (string, arr, unit) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + type(string_t), dimension(:), intent(in), optional :: arr + end subroutine msg_fatal + + module subroutine msg_error (string, arr, unit) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + type(string_t), dimension(:), intent(in), optional :: arr + end subroutine msg_error + + module subroutine msg_warning (string, arr, unit, color) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + type(string_t), dimension(:), intent(in), optional :: arr + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_warning + + module subroutine msg_message (string, unit, arr, logfile, color) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + type(string_t), dimension(:), intent(in), optional :: arr + logical, intent(in), optional :: logfile + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_message + + module subroutine msg_result (string, arr, unit, logfile, color) + integer, intent(in), optional :: unit + character(len=*), intent(in), optional :: string + type(string_t), dimension(:), intent(in), optional :: arr + logical, intent(in), optional :: logfile + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_result <>= - subroutine msg_terminate (string, unit, quit_code) + module subroutine msg_terminate (string, unit, quit_code) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string integer, intent(in), optional :: quit_code integer(c_int) :: return_code call release_term_signals () if (present (quit_code)) then return_code = quit_code else return_code = 0 end if if (present (string)) & call message_print (MESSAGE, string, unit=unit) call msg_summary (unit) if (return_code == 0 .and. expect_failures /= 0) then return_code = 5 call message_print (MESSAGE, & "WHIZARD run finished with 'expect' failure(s).", unit=unit) else if (return_code == 7) then call message_print (MESSAGE, & "WHIZARD run finished with failed self-test.", unit=unit) else call message_print (MESSAGE, "WHIZARD run finished.", unit=unit) end if call message_print (0, & "|=============================================================================|", unit=unit) call logfile_final () call msg_list_clear () if (return_code /= 0) then call exit (return_code) else !!! Should implement WHIZARD exit code (currently only via C) call exit (0) end if end subroutine msg_terminate - subroutine msg_bug (string, arr, unit) + module subroutine msg_bug (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr call message_print (BUG, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (-1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end subroutine msg_bug - recursive subroutine msg_fatal (string, arr, unit) + recursive module subroutine msg_fatal (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, pointer :: crash_ptr if (mask_fatal_errors) then call msg_error (string, arr, unit) else call message_print (FATAL, string, arr, unit) call msg_summary (unit) select case (handle_fatal_errors) case (TERM_EXIT) call message_print (TERMINATE, "WHIZARD run aborted.", unit=unit) call exit (1_c_int) case (TERM_CRASH) print *, "*** Intentional crash ***" crash_ptr => null () print *, crash_ptr end select stop "WHIZARD run aborted." end if end subroutine msg_fatal - subroutine msg_error (string, arr, unit) + module subroutine msg_error (string, arr, unit) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr call message_print (ERROR, string, arr, unit) if (msg_count(ERROR) >= MAX_ERRORS) then mask_fatal_errors = .false. call msg_fatal (" Too many errors encountered.") else if (.not.present(unit) .and. .not.mask_fatal_errors) then call message_print (MESSAGE, " (WHIZARD run continues)") end if end subroutine msg_error - subroutine msg_warning (string, arr, unit, color) + module subroutine msg_warning (string, arr, unit, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = WARNING, string = string, & str_arr = arr, unit = unit, color = cl) end subroutine msg_warning - subroutine msg_message (string, unit, arr, logfile, color) + module subroutine msg_message (string, unit, arr, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = MESSAGE, & string = string, str_arr = arr, unit = unit, & logfile = logfile, color = cl) end subroutine msg_message - subroutine msg_result (string, arr, unit, logfile, color) + module subroutine msg_result (string, arr, unit, logfile, color) integer, intent(in), optional :: unit character(len=*), intent(in), optional :: string type(string_t), dimension(:), intent(in), optional :: arr logical, intent(in), optional :: logfile type(terminal_color_t), intent(in), optional :: color integer :: cl cl = COL_UNDEFINED; if (present (color)) cl = color%color call message_print (level = RESULT, string = string, & str_arr = arr, unit = unit, logfile = logfile, color = cl) end subroutine msg_result @ %def msg_warning msg_message msg_result @ Debugging aids. Print messages or values of various kinds. All versions ultimately call [[msg_debug_none]], which in turn uses [[message_print]]. Safeguard: force crash if a routine (i.e., a debugging routine below) is called while the master switch [[debug_on]] is unset. Such calls should always be hidden behind [[if (debug_on)]], since they can significantly slow down the program. <>= if (.not. debug_on) call msg_bug ("msg_debug called with debug_on=.false.") @ The [[debug_on]] flag is provided by the [[debug_master]] module, and we can assume that it is a compile-time parameter. <>= public :: msg_debug <>= interface msg_debug module procedure msg_debug_none module procedure msg_debug_logical module procedure msg_debug_integer module procedure msg_debug_real module procedure msg_debug_complex module procedure msg_debug_string end interface +<>= + module subroutine msg_debug_none (area, string, color) + integer, intent(in) :: area + character(len=*), intent(in), optional :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug_none + + module subroutine msg_debug_logical (area, string, value, color) + logical, intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug_logical + + module subroutine msg_debug_integer (area, string, value, color) + integer, intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug_integer + + module subroutine msg_debug_real (area, string, value, color) + real(default), intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug_real + + module subroutine msg_debug_complex (area, string, value, color) + complex(default), intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug_complex + + module subroutine msg_debug_string (area, string, value, color) + type(string_t), intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug_string <>= - subroutine msg_debug_none (area, string, color) + module subroutine msg_debug_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug_none - subroutine msg_debug_logical (area, string, value, color) + module subroutine msg_debug_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug_logical - subroutine msg_debug_integer (area, string, value, color) + module subroutine msg_debug_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug_integer - subroutine msg_debug_real (area, string, value, color) + module subroutine msg_debug_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug_real - subroutine msg_debug_complex (area, string, value, color) + module subroutine msg_debug_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug_complex - subroutine msg_debug_string (area, string, value, color) + module subroutine msg_debug_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug_active (area)) then call msg_debug_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug_string @ %def msg_debug <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug_active (area)) then write (buffer, *) value call msg_debug_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: msg_print_color <>= interface msg_print_color module procedure msg_print_color_none module procedure msg_print_color_logical module procedure msg_print_color_integer module procedure msg_print_color_real end interface +<>= + module subroutine msg_print_color_none (string, color) + character(len=*), intent(in) :: string + !!!type(terminal_color_t), intent(in) :: color + integer, intent(in) :: color + end subroutine msg_print_color_none + + module subroutine msg_print_color_logical (string, value, color) + character(len=*), intent(in) :: string + logical, intent(in) :: value + integer, intent(in) :: color + end subroutine msg_print_color_logical + + module subroutine msg_print_color_integer (string, value, color) + character(len=*), intent(in) :: string + integer, intent(in) :: value + integer, intent(in) :: color + end subroutine msg_print_color_integer + + module subroutine msg_print_color_real (string, value, color) + character(len=*), intent(in) :: string + real(default), intent(in) :: value + integer, intent(in) :: color + end subroutine msg_print_color_real <>= - subroutine msg_print_color_none (string, color) + module subroutine msg_print_color_none (string, color) character(len=*), intent(in) :: string !!!type(terminal_color_t), intent(in) :: color integer, intent(in) :: color call message_print (0, string, color = color) end subroutine msg_print_color_none - subroutine msg_print_color_logical (string, value, color) + module subroutine msg_print_color_logical (string, value, color) character(len=*), intent(in) :: string logical, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_logical - subroutine msg_print_color_integer (string, value, color) + module subroutine msg_print_color_integer (string, value, color) character(len=*), intent(in) :: string integer, intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_integer - subroutine msg_print_color_real (string, value, color) + module subroutine msg_print_color_real (string, value, color) character(len=*), intent(in) :: string real(default), intent(in) :: value integer, intent(in) :: color call msg_print_color_none (char (string // " = " // str (value)), & color = color) end subroutine msg_print_color_real @ %def msg_print_color_none, msg_print_color_logical @ %def msg_print_color_integer, msg_print_color_real @ Secondary debugging aids which implement more fine-grained debugging. Again, there is a safeguard against calling anything while [[debug_on=.false.]]. <>= if (.not. debug_on) call msg_bug ("msg_debug2 called with debug_on=.false.") <>= public :: msg_debug2 <>= interface msg_debug2 module procedure msg_debug2_none module procedure msg_debug2_logical module procedure msg_debug2_integer module procedure msg_debug2_real module procedure msg_debug2_complex module procedure msg_debug2_string end interface +<>= + module subroutine msg_debug2_none (area, string, color) + integer, intent(in) :: area + character(len=*), intent(in), optional :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug2_none + + module subroutine msg_debug2_logical (area, string, value, color) + logical, intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug2_logical + + module subroutine msg_debug2_integer (area, string, value, color) + integer, intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug2_integer + + module subroutine msg_debug2_real (area, string, value, color) + real(default), intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug2_real + + module subroutine msg_debug2_complex (area, string, value, color) + complex(default), intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug2_complex + + module subroutine msg_debug2_string (area, string, value, color) + type(string_t), intent(in) :: value + integer, intent(in) :: area + character(len=*), intent(in) :: string + type(terminal_color_t), intent(in), optional :: color + end subroutine msg_debug2_string <>= - subroutine msg_debug2_none (area, string, color) + module subroutine msg_debug2_none (area, string, color) integer, intent(in) :: area character(len=*), intent(in), optional :: string type(terminal_color_t), intent(in), optional :: color integer :: cl if (debug2_active (area)) then cl = COL_BLUE; if (present (color)) cl = color%color call message_print (DEBUG2, string, unit = output_unit, & area = area, logfile = .false., color = cl) else <> end if end subroutine msg_debug2_none - subroutine msg_debug2_logical (area, string, value, color) + module subroutine msg_debug2_logical (area, string, value, color) logical, intent(in) :: value <> end subroutine msg_debug2_logical - subroutine msg_debug2_integer (area, string, value, color) + module subroutine msg_debug2_integer (area, string, value, color) integer, intent(in) :: value <> end subroutine msg_debug2_integer - subroutine msg_debug2_real (area, string, value, color) + module subroutine msg_debug2_real (area, string, value, color) real(default), intent(in) :: value <> end subroutine msg_debug2_real - subroutine msg_debug2_complex (area, string, value, color) + module subroutine msg_debug2_complex (area, string, value, color) complex(default), intent(in) :: value <> end subroutine msg_debug2_complex - subroutine msg_debug2_string (area, string, value, color) + module subroutine msg_debug2_string (area, string, value, color) type(string_t), intent(in) :: value integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color if (debug2_active (area)) then call msg_debug2_none (area, string // " = " // char (value), & color = color) else <> end if end subroutine msg_debug2_string @ %def msg_debug2 <>= integer, intent(in) :: area character(len=*), intent(in) :: string type(terminal_color_t), intent(in), optional :: color character(len=64) :: buffer if (debug2_active (area)) then write (buffer, *) value call msg_debug2_none (area, string // " = " // trim (buffer), & color = color) else <> end if @ <>= public :: debug_active +<>= + elemental module function debug_active (area) result (active) + logical :: active + integer, intent(in) :: area + end function debug_active <>= - elemental function debug_active (area) result (active) + elemental module function debug_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG end function debug_active @ %def debug_active @ <>= public :: debug2_active +<>= + elemental module function debug2_active (area) result (active) + logical :: active + integer, intent(in) :: area + end function debug2_active <>= - elemental function debug2_active (area) result (active) + elemental module function debug2_active (area) result (active) logical :: active integer, intent(in) :: area active = debug_on .and. msg_level(area) >= DEBUG2 end function debug2_active @ %def debug2_active @ Show the progress of a loop in steps of 10 \%. Could be generalized to other step sizes with an optional argument. <>= public :: msg_show_progress +<>= + module subroutine msg_show_progress (i_call, n_calls) + integer, intent(in) :: i_call, n_calls + end subroutine msg_show_progress <>= - subroutine msg_show_progress (i_call, n_calls) + module subroutine msg_show_progress (i_call, n_calls) integer, intent(in) :: i_call, n_calls real(default) :: progress integer, save :: next_check if (i_call == 1) next_check = 10 progress = (i_call * 100._default) / n_calls if (progress >= next_check) then write (msg_buffer, "(F5.1,A)") progress, "%" call msg_message () next_check = next_check + 10 end if end subroutine msg_show_progress @ %def msg_show_progress @ Interface to the standard clib exit function <>= public :: exit <>= interface subroutine exit (status) bind (C) use iso_c_binding !NODEP! integer(c_int), value :: status end subroutine exit end interface @ %def exit @ Print the WHIZARD banner: <>= public :: msg_banner +<>= + module subroutine msg_banner (unit) + integer, intent(in), optional :: unit + end subroutine msg_banner <>= - subroutine msg_banner (unit) + module subroutine msg_banner (unit) integer, intent(in), optional :: unit call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WWWWW WWWW |", unit=unit) call message_print (0, "| WW WW WW WW WW WW WW WWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WWWWWWW WW WW WW WW WWWWW WW WW |", unit=unit) call message_print (0, "| WWWW WWWW WW WW WW WW WWWWWWWW WW WW WW WW |", unit=unit) call message_print (0, "| WW WW WW WW WW WWWWWW WW WW WW WW WWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| W |", unit=unit) call message_print (0, "| sW |", unit=unit) call message_print (0, "| WW |", unit=unit) call message_print (0, "| sWW |", unit=unit) call message_print (0, "| WWW |", unit=unit) call message_print (0, "| wWWW |", unit=unit) call message_print (0, "| wWWWW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| wWW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| WW WW |", unit=unit) call message_print (0, "| wwwwww WW WW |", unit=unit) call message_print (0, "| WWWWWww WW WW |", unit=unit) call message_print (0, "| WWWWWwwwww WW WW |", unit=unit) call message_print (0, "| wWWWwwwwwWW WW |", unit=unit) call message_print (0, "| wWWWWWWWWWWwWWW WW |", unit=unit) call message_print (0, "| wWWWWW wW WWWWWWW |", unit=unit) call message_print (0, "| WWWW wW WW wWWWWWWWwww |", unit=unit) call message_print (0, "| WWWW wWWWWWWWwwww |", unit=unit) call message_print (0, "| WWWW WWWW WWw |", unit=unit) call message_print (0, "| WWWWww WWWW |", unit=unit) call message_print (0, "| WWWwwww WWWW |", unit=unit) call message_print (0, "| wWWWWwww wWWWWW |", unit=unit) call message_print (0, "| WwwwwwwwwWWW |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| by: Wolfgang Kilian, Thorsten Ohl, Juergen Reuter |", unit=unit) call message_print (0, "| with contributions from Christian Speckner |", unit=unit) call message_print (0, "| Contact: |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "| if you use WHIZARD please cite: |", unit=unit) call message_print (0, "| W. Kilian, T. Ohl, J. Reuter, Eur.Phys.J.C71 (2011) 1742 |", unit=unit) call message_print (0, "| [arXiv: 0708.4233 [hep-ph]] |", unit=unit) call message_print (0, "| M. Moretti, T. Ohl, J. Reuter, arXiv: hep-ph/0102195 |", unit=unit) call message_print (0, "| |", unit=unit) call message_print (0, "|=============================================================================|", unit=unit) call message_print (0, "| WHIZARD " // WHIZARD_VERSION, unit=unit) call message_print (0, "|=============================================================================|", unit=unit) end subroutine msg_banner @ %def msg_banner @ \subsection{Logfile} All screen output should be duplicated in the logfile, unless requested otherwise. <>= public :: logging <>= integer, save :: log_unit = -1 logical, target, save :: logging = .false. <>= public :: logfile_init +<>= + module subroutine logfile_init (filename) + type(string_t), intent(in) :: filename + end subroutine logfile_init <>= - subroutine logfile_init (filename) + module subroutine logfile_init (filename) type(string_t), intent(in) :: filename call msg_message ("Writing log to '" // char (filename) // "'") if (.not. logging) call msg_message ("(Logging turned off.)") log_unit = free_unit () open (file = char (filename), unit = log_unit, & action = "write", status = "replace") end subroutine logfile_init @ %def logfile_init <>= public :: logfile_final +<>= + module subroutine logfile_final () + end subroutine logfile_final <>= - subroutine logfile_final () + module subroutine logfile_final () if (log_unit >= 0) then close (log_unit) log_unit = -1 end if end subroutine logfile_final @ %def logfile_final @ This returns the valid logfile unit only if the default is write to screen, and if [[logfile]] is not set false. <>= public :: logfile_unit +<>= + module function logfile_unit (unit, logfile) + integer :: logfile_unit + integer, intent(in), optional :: unit + logical, intent(in), optional :: logfile + end function logfile_unit <>= - function logfile_unit (unit, logfile) + module function logfile_unit (unit, logfile) integer :: logfile_unit integer, intent(in), optional :: unit logical, intent(in), optional :: logfile if (logging) then if (present (unit)) then if (unit == output_unit) then logfile_unit = log_unit else logfile_unit = -1 end if else if (present (logfile)) then if (logfile) then logfile_unit = log_unit else logfile_unit = -1 end if else logfile_unit = log_unit end if else logfile_unit = -1 end if end function logfile_unit @ %def logfile_unit @ \subsection{Checking values} The [[expect]] function does not just check a value for correctness (actually, it checks if a logical expression is true); it records its result here. If failures are present when the program terminates, the exit code is nonzero. <>= integer, save :: expect_total = 0 integer, save :: expect_failures = 0 @ %def expect_total expect_failures <>= public :: expect_record +<>= + module subroutine expect_record (success) + logical, intent(in) :: success + end subroutine expect_record <>= - subroutine expect_record (success) + module subroutine expect_record (success) logical, intent(in) :: success expect_total = expect_total + 1 if (.not. success) expect_failures = expect_failures + 1 end subroutine expect_record @ %def expect_record <>= public :: expect_clear +<>= + module subroutine expect_clear () + end subroutine expect_clear <>= - subroutine expect_clear () + module subroutine expect_clear () expect_total = 0 expect_failures = 0 end subroutine expect_clear @ %def expect_clear <>= public :: expect_summary +<>= + module subroutine expect_summary (unit, force) + integer, intent(in), optional :: unit + logical, intent(in), optional :: force + end subroutine expect_summary <>= - subroutine expect_summary (unit, force) + module subroutine expect_summary (unit, force) integer, intent(in), optional :: unit logical, intent(in), optional :: force logical :: force_output force_output = .false.; if (present (force)) force_output = force if (expect_total /= 0 .or. force_output) then call msg_message ("Summary of value checks:", unit) write (msg_buffer, "(2x,A,1x,I0,1x,A,1x,A,1x,I0)") & "Failures:", expect_failures, "/", "Total:", expect_total call msg_message (unit=unit) end if end subroutine expect_summary @ %def expect_summary @ Helpers for converting integers into strings with minimal length. <>= public :: int2string public :: int2char public :: int2fixed +<>= + pure module function int2fixed (i) result (c) + integer, intent(in) :: i + character(200) :: c + end function int2fixed + + pure module function int2string (i) result (s) + integer, intent(in) :: i + type (string_t) :: s + end function int2string + + pure module function int2char (i) result (c) + integer, intent(in) :: i + character(len (trim (int2fixed (i)))) :: c + end function int2char <>= - pure function int2fixed (i) result (c) + pure module function int2fixed (i) result (c) integer, intent(in) :: i character(200) :: c c = "" write (c, *) i c = adjustl (c) end function int2fixed - pure function int2string (i) result (s) + pure module function int2string (i) result (s) integer, intent(in) :: i type (string_t) :: s s = trim (int2fixed (i)) end function int2string - pure function int2char (i) result (c) + pure module function int2char (i) result (c) integer, intent(in) :: i character(len (trim (int2fixed (i)))) :: c c = int2fixed (i) end function int2char @ %def int2fixed int2string int2char @ Dito for reals. <>= public :: real2string public :: real2char public :: real2fixed <>= interface real2string module procedure real2string_list, real2string_fmt end interface interface real2char module procedure real2char_list, real2char_fmt end interface +<>= + pure module function real2fixed (x, fmt) result (c) + real(default), intent(in) :: x + character(*), intent(in), optional :: fmt + character(200) :: c + end function real2fixed + + pure module function real2fixed_fmt (x, fmt) result (c) + real(default), intent(in) :: x + character(*), intent(in) :: fmt + character(200) :: c + end function real2fixed_fmt + + pure module function real2string_list (x) result (s) + real(default), intent(in) :: x + type(string_t) :: s + end function real2string_list + + pure module function real2string_fmt (x, fmt) result (s) + real(default), intent(in) :: x + character(*), intent(in) :: fmt + type(string_t) :: s + end function real2string_fmt + + pure module function real2char_list (x) result (c) + real(default), intent(in) :: x + character(len_trim (real2fixed (x))) :: c + end function real2char_list + + pure module function real2char_fmt (x, fmt) result (c) + real(default), intent(in) :: x + character(*), intent(in) :: fmt + character(len_trim (real2fixed_fmt (x, fmt))) :: c + end function real2char_fmt <>= - pure function real2fixed (x, fmt) result (c) + pure module function real2fixed (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in), optional :: fmt character(200) :: c c = "" write (c, *) x c = adjustl (c) end function real2fixed - pure function real2fixed_fmt (x, fmt) result (c) + pure module function real2fixed_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(200) :: c c = "" write (c, fmt) x c = adjustl (c) end function real2fixed_fmt - pure function real2string_list (x) result (s) + pure module function real2string_list (x) result (s) real(default), intent(in) :: x type(string_t) :: s s = trim (real2fixed (x)) end function real2string_list - pure function real2string_fmt (x, fmt) result (s) + pure module function real2string_fmt (x, fmt) result (s) real(default), intent(in) :: x character(*), intent(in) :: fmt type(string_t) :: s s = trim (real2fixed_fmt (x, fmt)) end function real2string_fmt - pure function real2char_list (x) result (c) + pure module function real2char_list (x) result (c) real(default), intent(in) :: x character(len_trim (real2fixed (x))) :: c c = real2fixed (x) end function real2char_list - pure function real2char_fmt (x, fmt) result (c) + pure module function real2char_fmt (x, fmt) result (c) real(default), intent(in) :: x character(*), intent(in) :: fmt character(len_trim (real2fixed_fmt (x, fmt))) :: c c = real2fixed_fmt (x, fmt) end function real2char_fmt @ %def real2fixed real2string real2char @ Dito for complex values; we do not use the slightly ugly FORTRAN output form here but instead introduce our own. Ifort and Portland seem to have problems with this, therefore temporarily disable it. % <>= public :: cmplx2string public :: cmplx2char <>= pure function cmplx2string (x) result (s) complex(default), intent(in) :: x type(string_t) :: s s = real2string (real (x, default)) if (aimag (x) /= 0) s = s // " + " // real2string (aimag (x)) // " I" end function cmplx2string pure function cmplx2char (x) result (c) complex(default), intent(in) :: x character(len (char (cmplx2string (x)))) :: c c = char (cmplx2string (x)) end function cmplx2char @ %def cmplx2string cmplx2char @ \subsection{Suppression of numerical noise} <>= public :: pacify <>= interface pacify module procedure pacify_real_default module procedure pacify_complex_default end interface pacify -@ +<>= + elemental module subroutine pacify_real_default (x, tolerance) + real(default), intent(inout) :: x + real(default), intent(in) :: tolerance + end subroutine pacify_real_default + + elemental module subroutine pacify_complex_default (x, tolerance) + complex(default), intent(inout) :: x + real(default), intent(in) :: tolerance + end subroutine pacify_complex_default <>= - elemental subroutine pacify_real_default (x, tolerance) + elemental module subroutine pacify_real_default (x, tolerance) real(default), intent(inout) :: x real(default), intent(in) :: tolerance if (abs (x) < tolerance) x = 0._default end subroutine pacify_real_default - elemental subroutine pacify_complex_default (x, tolerance) + elemental module subroutine pacify_complex_default (x, tolerance) complex(default), intent(inout) :: x real(default), intent(in) :: tolerance if (abs (real (x)) < tolerance) & x = cmplx (0._default, aimag (x), kind=default) if (abs (aimag (x)) < tolerance) & x = cmplx (real (x), 0._default, kind=default) end subroutine pacify_complex_default @ %def pacify @ \subsection{Signal handling} Killing the program by external signals may leave the files written by it in an undefined state. This can be avoided by catching signals and deferring program termination. Instead of masking only critical sections, we choose to mask signals globally (done in the main program) and terminate the program at predefined checkpoints only. Checkpoints are after each command, within the sampling function (so the program can be terminated after each event), and after each iteration in the phase-space generation algorithm. Signal handling is done via a C interface to the [[sigaction]] system call. When a signal is raised that has been masked by the handler, the corresponding variable is set to the value of the signal. The variables are visible from the C signal handler. The signal SIGINT is for keyboard interrupt (ctrl-C), SIGTERM is for system interrupt, e.g., at shutdown. The SIGXCPU and SIGXFSZ signals may be issued by batch systems. <>= public :: wo_sigint public :: wo_sigterm public :: wo_sigxcpu public :: wo_sigxfsz <>= integer(c_int), bind(C), volatile :: wo_sigint = 0 integer(c_int), bind(C), volatile :: wo_sigterm = 0 integer(c_int), bind(C), volatile :: wo_sigxcpu = 0 integer(c_int), bind(C), volatile :: wo_sigxfsz = 0 @ %def wo_sigint wo_sigterm wo_sigxcpu wo_sigxfsz @ Here are the interfaces to the C functions. The routine [[mask_term_signals]] forces termination signals to be delayed. [[release_term_signals]] restores normal behavior. However, the program can be terminated anytime by calling [[terminate_now_if_signal]] which inspects the signals and terminates the program if requested.. <>= public :: mask_term_signals +<>= + module subroutine mask_term_signals () + end subroutine mask_term_signals <>= - subroutine mask_term_signals () + module subroutine mask_term_signals () logical :: ok wo_sigint = 0 ok = wo_mask_sigint () == 0 if (.not. ok) call msg_error ("Masking SIGINT failed") wo_sigterm = 0 ok = wo_mask_sigterm () == 0 if (.not. ok) call msg_error ("Masking SIGTERM failed") wo_sigxcpu = 0 ok = wo_mask_sigxcpu () == 0 if (.not. ok) call msg_error ("Masking SIGXCPU failed") wo_sigxfsz = 0 ok = wo_mask_sigxfsz () == 0 if (.not. ok) call msg_error ("Masking SIGXFSZ failed") end subroutine mask_term_signals @ %def mask_term_signals <>= interface integer(c_int) function wo_mask_sigint () bind(C) import end function wo_mask_sigint end interface interface integer(c_int) function wo_mask_sigterm () bind(C) import end function wo_mask_sigterm end interface interface integer(c_int) function wo_mask_sigxcpu () bind(C) import end function wo_mask_sigxcpu end interface interface integer(c_int) function wo_mask_sigxfsz () bind(C) import end function wo_mask_sigxfsz end interface @ %def wo_mask_sigint wo_mask_sigterm wo_mask_sigxcpu wo_mask_sigxfsz <>= public :: release_term_signals +<>= + module subroutine release_term_signals () + end subroutine release_term_signals <>= - subroutine release_term_signals () + module subroutine release_term_signals () logical :: ok ok = wo_release_sigint () == 0 if (.not. ok) call msg_error ("Releasing SIGINT failed") ok = wo_release_sigterm () == 0 if (.not. ok) call msg_error ("Releasing SIGTERM failed") ok = wo_release_sigxcpu () == 0 if (.not. ok) call msg_error ("Releasing SIGXCPU failed") ok = wo_release_sigxfsz () == 0 if (.not. ok) call msg_error ("Releasing SIGXFSZ failed") end subroutine release_term_signals @ %def release_term_signals <>= interface integer(c_int) function wo_release_sigint () bind(C) import end function wo_release_sigint end interface interface integer(c_int) function wo_release_sigterm () bind(C) import end function wo_release_sigterm end interface interface integer(c_int) function wo_release_sigxcpu () bind(C) import end function wo_release_sigxcpu end interface interface integer(c_int) function wo_release_sigxfsz () bind(C) import end function wo_release_sigxfsz end interface @ %def wo_release_sigint wo_release_sigterm @ %def wo_release_sigxcpu wo_release_sigxfsz <>= public :: signal_is_pending +<>= + module function signal_is_pending () result (flag) + logical :: flag + end function signal_is_pending <>= - function signal_is_pending () result (flag) + module function signal_is_pending () result (flag) logical :: flag flag = & wo_sigint /= 0 .or. & wo_sigterm /= 0 .or. & wo_sigxcpu /= 0 .or. & wo_sigxfsz /= 0 end function signal_is_pending @ %def signal_is_pending <>= public :: terminate_now_if_signal +<>= + module subroutine terminate_now_if_signal () + end subroutine terminate_now_if_signal <>= - subroutine terminate_now_if_signal () + module subroutine terminate_now_if_signal () if (wo_sigint /= 0) then call msg_terminate ("Signal SIGINT (keyboard interrupt) received.", & quit_code=int (wo_sigint)) else if (wo_sigterm /= 0) then call msg_terminate ("Signal SIGTERM (termination signal) received.", & quit_code=int (wo_sigterm)) else if (wo_sigxcpu /= 0) then call msg_terminate ("Signal SIGXCPU (CPU time limit exceeded) received.", & quit_code=int (wo_sigxcpu)) else if (wo_sigxfsz /= 0) then call msg_terminate ("Signal SIGXFSZ (file size limit exceeded) received.", & quit_code=int (wo_sigxfsz)) end if end subroutine terminate_now_if_signal @ %def terminate_now_if_signal @ <>= public :: single_event <>= logical :: single_event = .false. @ <>= public :: terminate_now_if_single_event +<>= + module subroutine terminate_now_if_single_event () + end subroutine terminate_now_if_single_event <>= - subroutine terminate_now_if_single_event () + module subroutine terminate_now_if_single_event () integer, save :: n_calls = 0 n_calls = n_calls + 1 if (single_event .and. n_calls > 1) then call msg_terminate ("Stopping after one event", quit_code=0) end if end subroutine terminate_now_if_single_event @ %def terminate_now_if_single_event @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Operating-system interface} For specific purposes, we need direct access to the OS (system calls). This is, of course, system dependent. The current version is valid for GNU/Linux; we expect to use a preprocessor for this module if different OSs are to be supported. The current implementation lacks error handling. <<[[os_interface.f90]]>>= <> module os_interface use, intrinsic :: iso_c_binding !NODEP! <> - use io_units - use diagnostics - use system_defs, only: DLERROR_LEN, ENVVAR_LEN - use system_dependencies - -<> <> <> <> <> + interface +<> + end interface + +end module os_interface +@ %def os_interface +@ +<<[[os_interface_sub.f90]]>>= +<> + +submodule (os_interface) os_interface_s + + use system_defs, only: DLERROR_LEN, ENVVAR_LEN + use io_units + use diagnostics + use system_dependencies + +<> + contains <> -end module os_interface -@ %def os_interface +end submodule os_interface_s + +@ %def os_interface_s @ \subsection{Path variables} This is a transparent container for storing user-defined path variables. <>= public :: paths_t <>= type :: paths_t type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: localprefix type(string_t) :: libtool type(string_t) :: lhapdfdir end type paths_t @ %def paths_t <>= public :: paths_init +<>= + module subroutine paths_init (paths) + type(paths_t), intent(out) :: paths + end subroutine paths_init <>= - subroutine paths_init (paths) + module subroutine paths_init (paths) type(paths_t), intent(out) :: paths paths%prefix = "" paths%exec_prefix = "" paths%bindir = "" paths%libdir = "" paths%includedir = "" paths%datarootdir = "" paths%localprefix = "" paths%libtool = "" paths%lhapdfdir = "" end subroutine paths_init @ %def paths_init @ \subsection{System dependencies} We store all potentially system- and user/run-dependent data in a transparent container. This includes compiler/linker names and flags, file extensions, etc. There are actually two different possibilities for extensions of shared libraries, depending on whether the Fortran compiler or the system linker (usually the C compiler) has been used for linking. The default for the Fortran compiler on most systems is [[.so]]. <>= public :: os_data_t <>= type :: os_data_t logical :: use_libtool logical :: use_testfiles type(string_t) :: fc type(string_t) :: fcflags type(string_t) :: fcflags_pic type(string_t) :: fclibs type(string_t) :: fc_src_ext type(string_t) :: cc type(string_t) :: cflags type(string_t) :: cflags_pic type(string_t) :: cxx type(string_t) :: cxxflags type(string_t) :: cxxlibs type(string_t) :: obj_ext type(string_t) :: ld type(string_t) :: ldflags type(string_t) :: ldflags_so type(string_t) :: ldflags_static type(string_t) :: ldflags_hepmc type(string_t) :: ldflags_lcio type(string_t) :: ldflags_hoppet type(string_t) :: ldflags_looptools type(string_t) :: shrlib_ext type(string_t) :: fc_shrlib_ext type(string_t) :: pack_cmd type(string_t) :: unpack_cmd type(string_t) :: pack_ext type(string_t) :: makeflags type(string_t) :: prefix type(string_t) :: exec_prefix type(string_t) :: bindir type(string_t) :: libdir type(string_t) :: includedir type(string_t) :: datarootdir type(string_t) :: whizard_omega_binpath type(string_t) :: whizard_includes type(string_t) :: whizard_ldflags type(string_t) :: whizard_libtool type(string_t) :: whizard_modelpath type(string_t) :: whizard_modelpath_ufo type(string_t) :: whizard_models_libpath type(string_t) :: whizard_susypath type(string_t) :: whizard_gmlpath type(string_t) :: whizard_cutspath type(string_t) :: whizard_texpath type(string_t) :: whizard_sharepath type(string_t) :: whizard_testdatapath type(string_t) :: whizard_modelpath_local type(string_t) :: whizard_models_libpath_local type(string_t) :: whizard_omega_binpath_local type(string_t) :: whizard_circe2path type(string_t) :: whizard_beamsimpath type(string_t) :: whizard_mulipath type(string_t) :: pdf_builtin_datapath logical :: event_analysis = .false. logical :: event_analysis_ps = .false. logical :: event_analysis_pdf = .false. type(string_t) :: latex type(string_t) :: mpost type(string_t) :: gml type(string_t) :: dvips type(string_t) :: ps2pdf type(string_t) :: gosampath type(string_t) :: golempath type(string_t) :: formpath type(string_t) :: qgrafpath type(string_t) :: ninjapath type(string_t) :: samuraipath contains <> end type os_data_t @ %def os_data_t @ Since all are allocatable strings, explicit initialization is necessary. <>= integer, parameter, public :: ENVVAR_LEN = 1000 @ %def ENVVAR_LEN <>= procedure :: init => os_data_init +<>= + module subroutine os_data_init (os_data, paths) + class(os_data_t), intent(out) :: os_data + type(paths_t), intent(in), optional :: paths + end subroutine os_data_init <>= - subroutine os_data_init (os_data, paths) + module subroutine os_data_init (os_data, paths) class(os_data_t), intent(out) :: os_data type(paths_t), intent(in), optional :: paths character(len=ENVVAR_LEN) :: home type(string_t) :: localprefix, local_includes os_data%use_libtool = .true. inquire (file = "TESTFLAG", exist = os_data%use_testfiles) call get_environment_variable ("HOME", home) if (present(paths)) then if (paths%localprefix == "") then localprefix = trim (home) // "/.whizard" else localprefix = paths%localprefix end if else localprefix = trim (home) // "/.whizard" end if local_includes = localprefix // "/lib/whizard/mod/models" os_data%whizard_modelpath_local = localprefix // "/share/whizard/models" os_data%whizard_models_libpath_local = localprefix // "/lib/whizard/models" os_data%whizard_omega_binpath_local = localprefix // "/bin" os_data%fc = DEFAULT_FC os_data%fcflags = DEFAULT_FCFLAGS os_data%fcflags_pic = DEFAULT_FCFLAGS_PIC os_data%fclibs = FCLIBS os_data%fc_src_ext = DEFAULT_FC_SRC_EXT os_data%cc = DEFAULT_CC os_data%cflags = DEFAULT_CFLAGS os_data%cflags_pic = DEFAULT_CFLAGS_PIC os_data%cxx = DEFAULT_CXX os_data%cxxflags = DEFAULT_CXXFLAGS os_data%cxxlibs = DEFAULT_CXXLIBS os_data%obj_ext = DEFAULT_OBJ_EXT os_data%ld = DEFAULT_LD os_data%ldflags = DEFAULT_LDFLAGS os_data%ldflags_so = DEFAULT_LDFLAGS_SO os_data%ldflags_static = DEFAULT_LDFLAGS_STATIC os_data%ldflags_hepmc = DEFAULT_LDFLAGS_HEPMC os_data%ldflags_lcio = DEFAULT_LDFLAGS_LCIO os_data%ldflags_hoppet = DEFAULT_LDFLAGS_HOPPET os_data%ldflags_looptools = DEFAULT_LDFLAGS_LOOPTOOLS os_data%shrlib_ext = DEFAULT_SHRLIB_EXT os_data%fc_shrlib_ext = DEFAULT_FC_SHRLIB_EXT os_data%pack_cmd = DEFAULT_PACK_CMD os_data%unpack_cmd = DEFAULT_UNPACK_CMD os_data%pack_ext = DEFAULT_PACK_EXT os_data%makeflags = DEFAULT_MAKEFLAGS os_data%prefix = PREFIX os_data%exec_prefix = EXEC_PREFIX os_data%bindir = BINDIR os_data%libdir = LIBDIR os_data%includedir = INCLUDEDIR os_data%datarootdir = DATAROOTDIR if (present (paths)) then if (paths%prefix /= "") os_data%prefix = paths%prefix if (paths%exec_prefix /= "") os_data%exec_prefix = paths%exec_prefix if (paths%bindir /= "") os_data%bindir = paths%bindir if (paths%libdir /= "") os_data%libdir = paths%libdir if (paths%includedir /= "") os_data%includedir = paths%includedir if (paths%datarootdir /= "") os_data%datarootdir = paths%datarootdir end if if (os_data%use_testfiles) then os_data%whizard_omega_binpath = WHIZARD_TEST_OMEGA_BINPATH os_data%whizard_includes = WHIZARD_TEST_INCLUDES os_data%whizard_ldflags = WHIZARD_TEST_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL_TEST os_data%whizard_modelpath = WHIZARD_TEST_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_TEST_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_TEST_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_TEST_SUSYPATH os_data%whizard_gmlpath = WHIZARD_TEST_GMLPATH os_data%whizard_cutspath = WHIZARD_TEST_CUTSPATH os_data%whizard_texpath = WHIZARD_TEST_TEXPATH os_data%whizard_sharepath = WHIZARD_TEST_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TEST_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_TEST_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_TEST_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_TEST_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_TEST_DATAPATH else if (os_dir_exist (local_includes)) then os_data%whizard_includes = "-I" // local_includes // " "// & WHIZARD_INCLUDES else os_data%whizard_includes = WHIZARD_INCLUDES end if os_data%whizard_omega_binpath = WHIZARD_OMEGA_BINPATH os_data%whizard_ldflags = WHIZARD_LDFLAGS os_data%whizard_libtool = WHIZARD_LIBTOOL if(present(paths)) then if (paths%libtool /= "") os_data%whizard_libtool = paths%libtool end if os_data%whizard_modelpath = WHIZARD_MODELPATH os_data%whizard_modelpath_ufo = WHIZARD_MODELPATH_UFO os_data%whizard_models_libpath = WHIZARD_MODELS_LIBPATH os_data%whizard_susypath = WHIZARD_SUSYPATH os_data%whizard_gmlpath = WHIZARD_GMLPATH os_data%whizard_cutspath = WHIZARD_CUTSPATH os_data%whizard_texpath = WHIZARD_TEXPATH os_data%whizard_sharepath = WHIZARD_SHAREPATH os_data%whizard_testdatapath = WHIZARD_TESTDATAPATH os_data%whizard_circe2path = WHIZARD_CIRCE2PATH os_data%whizard_beamsimpath = WHIZARD_BEAMSIMPATH os_data%whizard_mulipath = WHIZARD_MULIPATH os_data%pdf_builtin_datapath = PDF_BUILTIN_DATAPATH end if os_data%event_analysis = EVENT_ANALYSIS == "yes" os_data%event_analysis_ps = EVENT_ANALYSIS_PS == "yes" os_data%event_analysis_pdf = EVENT_ANALYSIS_PDF == "yes" os_data%latex = PRG_LATEX // " " // OPT_LATEX os_data%mpost = PRG_MPOST // " " // OPT_MPOST if (os_data%use_testfiles) then os_data%gml = os_data%whizard_gmlpath // "/whizard-gml" // " " // & OPT_MPOST // " " // "--gmldir " // os_data%whizard_gmlpath else os_data%gml = os_data%bindir // "/whizard-gml" // " " // OPT_MPOST & // " " // "--gmldir " // os_data%whizard_gmlpath end if os_data%dvips = PRG_DVIPS os_data%ps2pdf = PRG_PS2PDF call os_data_expand_paths (os_data) os_data%gosampath = GOSAM_DIR os_data%golempath = GOLEM_DIR os_data%formpath = FORM_DIR os_data%qgrafpath = QGRAF_DIR os_data%ninjapath = NINJA_DIR os_data%samuraipath = SAMURAI_DIR end subroutine os_data_init @ %def os_data_init @ Replace occurences of GNU path variables (such as [[${prefix}]]) by their values. Do this for all strings that could depend on them, and do the replacement in reverse order, since the path variables may be defined in terms of each other. %% Fooling Noweb Emacs mode: $ <>= subroutine os_data_expand_paths (os_data) type(os_data_t), intent(inout) :: os_data integer, parameter :: N_VARIABLES = 6 type(string_t), dimension(N_VARIABLES) :: variable, value variable(1) = "${prefix}"; value(1) = os_data%prefix variable(2) = "${exec_prefix}"; value(2) = os_data%exec_prefix variable(3) = "${bindir}"; value(3) = os_data%bindir variable(4) = "${libdir}"; value(4) = os_data%libdir variable(5) = "${includedir}"; value(5) = os_data%includedir variable(6) = "${datarootdir}"; value(6) = os_data%datarootdir call expand_paths (os_data%whizard_omega_binpath) call expand_paths (os_data%whizard_includes) call expand_paths (os_data%whizard_ldflags) call expand_paths (os_data%whizard_libtool) call expand_paths (os_data%whizard_modelpath) call expand_paths (os_data%whizard_modelpath_ufo) call expand_paths (os_data%whizard_models_libpath) call expand_paths (os_data%whizard_susypath) call expand_paths (os_data%whizard_gmlpath) call expand_paths (os_data%whizard_cutspath) call expand_paths (os_data%whizard_texpath) call expand_paths (os_data%whizard_sharepath) call expand_paths (os_data%whizard_testdatapath) call expand_paths (os_data%whizard_circe2path) call expand_paths (os_data%whizard_beamsimpath) call expand_paths (os_data%whizard_mulipath) call expand_paths (os_data%whizard_models_libpath_local) call expand_paths (os_data%whizard_modelpath_local) call expand_paths (os_data%whizard_omega_binpath_local) call expand_paths (os_data%pdf_builtin_datapath) call expand_paths (os_data%latex) call expand_paths (os_data%mpost) call expand_paths (os_data%gml) call expand_paths (os_data%dvips) call expand_paths (os_data%ps2pdf) contains subroutine expand_paths (string) type(string_t), intent(inout) :: string integer :: i do i = N_VARIABLES, 1, -1 string = replace (string, variable(i), value(i), every=.true.) end do end subroutine expand_paths end subroutine os_data_expand_paths @ %def os_data_update_paths @ Write contents <>= procedure :: write => os_data_write +<>= + module subroutine os_data_write (os_data, unit) + class(os_data_t), intent(in) :: os_data + integer, intent(in), optional :: unit + end subroutine os_data_write <>= - subroutine os_data_write (os_data, unit) + module subroutine os_data_write (os_data, unit) class(os_data_t), intent(in) :: os_data integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "OS data:" write (u, *) "use_libtool = ", os_data%use_libtool write (u, *) "use_testfiles = ", os_data%use_testfiles write (u, *) "fc = ", char (os_data%fc) write (u, *) "fcflags = ", char (os_data%fcflags) write (u, *) "fcflags_pic = ", char (os_data%fcflags_pic) write (u, *) "fclibs = ", char (os_data%fclibs) write (u, *) "fc_src_ext = ", char (os_data%fc_src_ext) write (u, *) "cc = ", char (os_data%cc) write (u, *) "cflags = ", char (os_data%cflags) write (u, *) "cflags_pic = ", char (os_data%cflags_pic) write (u, *) "cxx = ", char (os_data%cxx) write (u, *) "cxxflags = ", char (os_data%cxxflags) write (u, *) "cxxlibs = ", char (os_data%cxxlibs) write (u, *) "obj_ext = ", char (os_data%obj_ext) write (u, *) "ld = ", char (os_data%ld) write (u, *) "ldflags = ", char (os_data%ldflags) write (u, *) "ldflags_so = ", char (os_data%ldflags_so) write (u, *) "ldflags_static = ", char (os_data%ldflags_static) write (u, *) "ldflags_hepmc = ", char (os_data%ldflags_hepmc) write (u, *) "ldflags_lcio = ", char (os_data%ldflags_lcio) write (u, *) "ldflags_hoppet = ", char (os_data%ldflags_hoppet) write (u, *) "ldflags_looptools = ", char (os_data%ldflags_looptools) write (u, *) "shrlib_ext = ", char (os_data%shrlib_ext) write (u, *) "fc_shrlib_ext = ", char (os_data%fc_shrlib_ext) write (u, *) "makeflags = ", char (os_data%makeflags) write (u, *) "prefix = ", char (os_data%prefix) write (u, *) "exec_prefix = ", char (os_data%exec_prefix) write (u, *) "bindir = ", char (os_data%bindir) write (u, *) "libdir = ", char (os_data%libdir) write (u, *) "includedir = ", char (os_data%includedir) write (u, *) "datarootdir = ", char (os_data%datarootdir) write (u, *) "whizard_omega_binpath = ", & char (os_data%whizard_omega_binpath) write (u, *) "whizard_includes = ", char (os_data%whizard_includes) write (u, *) "whizard_ldflags = ", char (os_data%whizard_ldflags) write (u, *) "whizard_libtool = ", char (os_data%whizard_libtool) write (u, *) "whizard_modelpath = ", & char (os_data%whizard_modelpath) write (u, *) "whizard_modelpath_ufo = ", & char (os_data%whizard_modelpath_ufo) write (u, *) "whizard_models_libpath = ", & char (os_data%whizard_models_libpath) write (u, *) "whizard_susypath = ", char (os_data%whizard_susypath) write (u, *) "whizard_gmlpath = ", char (os_data%whizard_gmlpath) write (u, *) "whizard_cutspath = ", char (os_data%whizard_cutspath) write (u, *) "whizard_texpath = ", char (os_data%whizard_texpath) write (u, *) "whizard_circe2path = ", char (os_data%whizard_circe2path) write (u, *) "whizard_beamsimpath = ", char (os_data%whizard_beamsimpath) write (u, *) "whizard_mulipath = ", char (os_data%whizard_mulipath) write (u, *) "whizard_sharepath = ", & char (os_data%whizard_sharepath) write (u, *) "whizard_testdatapath = ", & char (os_data%whizard_testdatapath) write (u, *) "whizard_modelpath_local = ", & char (os_data%whizard_modelpath_local) write (u, *) "whizard_models_libpath_local = ", & char (os_data%whizard_models_libpath_local) write (u, *) "whizard_omega_binpath_local = ", & char (os_data%whizard_omega_binpath_local) write (u, *) "event_analysis = ", os_data%event_analysis write (u, *) "event_analysis_ps = ", os_data%event_analysis_ps write (u, *) "event_analysis_pdf = ", os_data%event_analysis_pdf write (u, *) "latex = ", char (os_data%latex) write (u, *) "mpost = ", char (os_data%mpost) write (u, *) "gml = ", char (os_data%gml) write (u, *) "dvips = ", char (os_data%dvips) write (u, *) "ps2pdf = ", char (os_data%ps2pdf) if (os_data%gosampath /= "") then write (u, *) "gosam = ", char (os_data%gosampath) write (u, *) "golem = ", char (os_data%golempath) write (u, *) "form = ", char (os_data%formpath) write (u, *) "qgraf = ", char (os_data%qgrafpath) write (u, *) "ninja = ", char (os_data%ninjapath) write (u, *) "samurai = ", char (os_data%samuraipath) end if end subroutine os_data_write @ %def os_data_write @ <>= procedure :: build_latex_file => os_data_build_latex_file +<>= + module subroutine os_data_build_latex_file (os_data, filename, stat_out) + class(os_data_t), intent(in) :: os_data + type(string_t), intent(in) :: filename + integer, intent(out), optional :: stat_out + end subroutine os_data_build_latex_file <>= - subroutine os_data_build_latex_file (os_data, filename, stat_out) + module subroutine os_data_build_latex_file (os_data, filename, stat_out) class(os_data_t), intent(in) :: os_data type(string_t), intent(in) :: filename integer, intent(out), optional :: stat_out type(string_t) :: setenv_tex, pipe, pipe_dvi integer :: unit_dev, status status = -1 if (os_data%event_analysis_ps) then !!! Check if our OS has a /dev/null unit_dev = free_unit () open (file = "/dev/null", unit = unit_dev, & action = "write", iostat = status) close (unit_dev) if (status /= 0) then pipe = "" pipe_dvi = "" else pipe = " > /dev/null" pipe_dvi = " 2>/dev/null 1>/dev/null" end if if (os_data%whizard_texpath /= "") then setenv_tex = "TEXINPUTS=" // & os_data%whizard_texpath // ":$TEXINPUTS " else setenv_tex = "" end if call os_system_call (setenv_tex // & os_data%latex // " " // filename // ".tex " // pipe, & verbose = .true., status = status) call os_system_call (os_data%dvips // " -o " // filename // & ".ps " // filename // ".dvi" // pipe_dvi, verbose = .true., & status = status) call os_system_call (os_data%ps2pdf // " " // filename // ".ps", & verbose = .true., status = status) end if if (present (stat_out)) stat_out = status end subroutine os_data_build_latex_file @ %def os_data_build_latex_file @ \subsection{Dynamic linking} We define a type that holds the filehandle for a dynamically linked library (shared object), together with functions to open and close the library, and to access functions in this library. <>= public :: dlaccess_t <>= type :: dlaccess_t private type(string_t) :: filename type(c_ptr) :: handle = c_null_ptr logical :: is_open = .false. logical :: has_error = .false. type(string_t) :: error contains <> end type dlaccess_t @ %def dlaccess_t @ Output. This is called by the output routine for the process library. <>= procedure :: write => dlaccess_write +<>= + module subroutine dlaccess_write (object, unit) + class(dlaccess_t), intent(in) :: object + integer, intent(in) :: unit + end subroutine dlaccess_write <>= - subroutine dlaccess_write (object, unit) + module subroutine dlaccess_write (object, unit) class(dlaccess_t), intent(in) :: object integer, intent(in) :: unit write (unit, "(1x,A)") "DL access info:" write (unit, "(3x,A,L1)") "is open = ", object%is_open if (object%has_error) then write (unit, "(3x,A,A,A)") "error = '", char (object%error), "'" else write (unit, "(3x,A)") "error = [none]" end if end subroutine dlaccess_write @ %def dlaccess_write @ The interface to the library functions: <>= interface function dlopen (filename, flag) result (handle) bind(C) import character(c_char), dimension(*) :: filename integer(c_int), value :: flag type(c_ptr) :: handle end function dlopen end interface interface function dlclose (handle) result (status) bind(C) import type(c_ptr), value :: handle integer(c_int) :: status end function dlclose end interface interface function dlerror () result (str) bind(C) import type(c_ptr) :: str end function dlerror end interface interface function dlsym (handle, symbol) result (fptr) bind(C) import type(c_ptr), value :: handle character(c_char), dimension(*) :: symbol type(c_funptr) :: fptr end function dlsym end interface @ %def dlopen dlclose dlsym @ This reads an error string and transforms it into a [[string_t]] object, if an error has occured. If not, set the error flag to false and return an empty string. <>= integer, parameter, public :: DLERROR_LEN = 160 <>= subroutine read_dlerror (has_error, error) logical, intent(out) :: has_error type(string_t), intent(out) :: error type(c_ptr) :: err_cptr character(len=DLERROR_LEN, kind=c_char), pointer :: err_fptr integer :: str_end err_cptr = dlerror () if (c_associated (err_cptr)) then call c_f_pointer (err_cptr, err_fptr) has_error = .true. str_end = scan (err_fptr, c_null_char) if (str_end > 0) then error = err_fptr(1:str_end-1) else error = err_fptr end if else has_error = .false. error = "" end if end subroutine read_dlerror @ %def read_dlerror @ This is the Fortran API. Init/final open and close the file, i.e., load and unload the library. Note that a library can be opened more than once, and that for an ultimate close as many [[dlclose]] calls as [[dlopen]] calls are necessary. However, we assume that it is opened and closed only once. <>= public :: dlaccess_init public :: dlaccess_final <>= procedure :: init => dlaccess_init procedure :: final => dlaccess_final +<>= + module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) + class(dlaccess_t), intent(out) :: dlaccess + type(string_t), intent(in) :: prefix, libname + type(os_data_t), intent(in), optional :: os_data + end subroutine dlaccess_init + module subroutine dlaccess_final (dlaccess) + class(dlaccess_t), intent(inout) :: dlaccess + end subroutine dlaccess_final <>= - subroutine dlaccess_init (dlaccess, prefix, libname, os_data) + module subroutine dlaccess_init (dlaccess, prefix, libname, os_data) class(dlaccess_t), intent(out) :: dlaccess type(string_t), intent(in) :: prefix, libname type(os_data_t), intent(in), optional :: os_data type(string_t) :: filename logical :: exist dlaccess%filename = libname filename = prefix // "/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then filename = prefix // "/.libs/" // libname inquire (file=char(filename), exist=exist) if (.not. exist) then dlaccess%has_error = .true. dlaccess%error = "Library '" // filename // "' not found" return end if end if dlaccess%handle = dlopen (char (filename) // c_null_char, ior ( & RTLD_LAZY, RTLD_LOCAL)) dlaccess%is_open = c_associated (dlaccess%handle) call read_dlerror (dlaccess%has_error, dlaccess%error) end subroutine dlaccess_init - subroutine dlaccess_final (dlaccess) + module subroutine dlaccess_final (dlaccess) class(dlaccess_t), intent(inout) :: dlaccess integer(c_int) :: status if (dlaccess%is_open) then status = dlclose (dlaccess%handle) dlaccess%is_open = .false. call read_dlerror (dlaccess%has_error, dlaccess%error) end if end subroutine dlaccess_final @ %def dlaccess_init dlaccess_final @ Return true if an error has occured. <>= public :: dlaccess_has_error +<>= + module function dlaccess_has_error (dlaccess) result (flag) + logical :: flag + type(dlaccess_t), intent(in) :: dlaccess + end function dlaccess_has_error <>= - function dlaccess_has_error (dlaccess) result (flag) + module function dlaccess_has_error (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%has_error end function dlaccess_has_error @ %def dlaccess_has_error @ Return the error string currently stored in the [[dlaccess]] object. <>= public :: dlaccess_get_error +<>= + module function dlaccess_get_error (dlaccess) result (error) + type(string_t) :: error + type(dlaccess_t), intent(in) :: dlaccess + end function dlaccess_get_error <>= - function dlaccess_get_error (dlaccess) result (error) + module function dlaccess_get_error (dlaccess) result (error) type(string_t) :: error type(dlaccess_t), intent(in) :: dlaccess error = dlaccess%error end function dlaccess_get_error @ %def dlaccess_get_error @ The symbol handler returns the C address of the function with the given string name. (It is a good idea to use [[bind(C)]] for all functions accessed by this, such that the name string is well-defined.) Call [[c_f_procpointer]] to cast this into a Fortran procedure pointer with an appropriate interface. <>= public :: dlaccess_get_c_funptr +<>= + module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) + type(c_funptr) :: fptr + type(dlaccess_t), intent(inout) :: dlaccess + type(string_t), intent(in) :: fname + end function dlaccess_get_c_funptr <>= - function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) + module function dlaccess_get_c_funptr (dlaccess, fname) result (fptr) type(c_funptr) :: fptr type(dlaccess_t), intent(inout) :: dlaccess type(string_t), intent(in) :: fname fptr = dlsym (dlaccess%handle, char (fname) // c_null_char) call read_dlerror (dlaccess%has_error, dlaccess%error) end function dlaccess_get_c_funptr @ %def dlaccess_get_c_funptr @ \subsection{Predicates} Return true if the library is loaded. In particular, this is false if loading was unsuccessful. <>= public :: dlaccess_is_open +<>= + module function dlaccess_is_open (dlaccess) result (flag) + logical :: flag + type(dlaccess_t), intent(in) :: dlaccess + end function dlaccess_is_open <>= - function dlaccess_is_open (dlaccess) result (flag) + module function dlaccess_is_open (dlaccess) result (flag) logical :: flag type(dlaccess_t), intent(in) :: dlaccess flag = dlaccess%is_open end function dlaccess_is_open @ %def dlaccess_is_open @ \subsection{Shell access} This is the standard system call for executing a shell command, such as invoking a compiler. In F2008 there will be the equivalent built-in command [[execute_command_line]]. <>= public :: os_system_call +<>= + module subroutine os_system_call (command_string, status, verbose) + type(string_t), intent(in) :: command_string + integer, intent(out), optional :: status + logical, intent(in), optional :: verbose + end subroutine os_system_call <>= - subroutine os_system_call (command_string, status, verbose) + module subroutine os_system_call (command_string, status, verbose) type(string_t), intent(in) :: command_string integer, intent(out), optional :: status logical, intent(in), optional :: verbose logical :: verb integer :: stat verb = .false.; if (present (verbose)) verb = verbose if (verb) & call msg_message ("command: " // char (command_string)) stat = system (char (command_string) // c_null_char) if (present (status)) then status = stat else if (stat /= 0) then if (.not. verb) & call msg_message ("command: " // char (command_string)) write (msg_buffer, "(A,I0)") "Return code = ", stat call msg_message () call msg_fatal ("System command returned with nonzero status code") end if end subroutine os_system_call @ %def os_system_call <>= interface function system (command) result (status) bind(C) import integer(c_int) :: status character(c_char), dimension(*) :: command end function system end interface @ %def system @ \subsection{Querying for a directory} This queries for the existence of a directory. There is no standard way to achieve this in FORTRAN, and if we were to call into [[libc]], we would need access to C macros for evaluating the result, so we resort to calling [[test]] as a system call. <>= public :: os_dir_exist +<>= + module function os_dir_exist (name) result (res) + type(string_t), intent(in) :: name + logical :: res + end function os_dir_exist <>= - function os_dir_exist (name) result (res) + module function os_dir_exist (name) result (res) type(string_t), intent(in) :: name logical :: res integer :: status call os_system_call ('test -d "' // name // '"', status=status) res = status == 0 end function os_dir_exist + @ %def os_dir_exist @ <>= public :: os_file_exist +<>= + module function os_file_exist (name) result (exist) + type(string_t), intent(in) :: name + logical :: exist + end function os_file_exist <>= - function os_file_exist (name) result (exist) + module function os_file_exist (name) result (exist) type(string_t), intent(in) :: name logical :: exist inquire (file = char (name), exist=exist) end function os_file_exist @ %def os_file_exist @ \subsection{Pack/unpack} The argument to [[pack]] may be a file or a directory. The name of the packed file will get the [[pack_ext]] extension appended. The argument to [[unpack]] must be a file, with the extension already included in the file name. <>= public :: os_pack_file public :: os_unpack_file +<>= + module subroutine os_pack_file (file, os_data, status) + type(string_t), intent(in) :: file + type(os_data_t), intent(in) :: os_data + integer, intent(out), optional :: status + end subroutine os_pack_file + module subroutine os_unpack_file (file, os_data, status) + type(string_t), intent(in) :: file + type(os_data_t), intent(in) :: os_data + integer, intent(out), optional :: status + end subroutine os_unpack_file <>= - subroutine os_pack_file (file, os_data, status) + module subroutine os_pack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%pack_cmd // " " & // file // os_data%pack_ext // " " // file call os_system_call (command_string, status) end subroutine os_pack_file - subroutine os_unpack_file (file, os_data, status) + module subroutine os_unpack_file (file, os_data, status) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string command_string = os_data%unpack_cmd // " " // file call os_system_call (command_string, status) end subroutine os_unpack_file @ %def os_pack_file @ %def os_unpack_file @ \subsection{Fortran compiler and linker} Compile a single module for use in a shared library, but without linking. <>= public :: os_compile_shared +<>= + module subroutine os_compile_shared (src, os_data, status) + type(string_t), intent(in) :: src + type(os_data_t), intent(in) :: os_data + integer, intent(out), optional :: status + end subroutine os_compile_shared <>= - subroutine os_compile_shared (src, os_data, status) + module subroutine os_compile_shared (src, os_data, status) type(string_t), intent(in) :: src type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=compile " // & os_data%fc // " " // & "-c " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" else command_string = & os_data%fc // " " // & "-c " // & os_data%fcflags_pic // " " // & os_data%whizard_includes // " " // & os_data%fcflags // " " // & "'" // src // os_data%fc_src_ext // "'" end if call os_system_call (command_string, status) end subroutine os_compile_shared @ %def os_compile_shared @ Link an array of object files to build a shared object library. In the libtool case, we have to specify a [[-rpath]], otherwise only a static library can be built. However, since the library is never installed, this rpath is irrelevant. <>= public :: os_link_shared +<>= + module subroutine os_link_shared (objlist, lib, os_data, status) + type(string_t), intent(in) :: objlist, lib + type(os_data_t), intent(in) :: os_data + integer, intent(out), optional :: status + end subroutine os_link_shared <>= - subroutine os_link_shared (objlist, lib, os_data, status) + module subroutine os_link_shared (objlist, lib, os_data, status) type(string_t), intent(in) :: objlist, lib type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-module " // & "-rpath /usr/local/lib" // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // ".la' " // & objlist else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & "-o '" // lib // "." // os_data%fc_shrlib_ext // "' " // & objlist end if call os_system_call (command_string, status) end subroutine os_link_shared @ %def os_link_shared @ Link an array of object files / libraries to build a static executable. <>= public :: os_link_static +<>= + module subroutine os_link_static (objlist, exec_name, os_data, status) + type(string_t), intent(in) :: objlist, exec_name + type(os_data_t), intent(in) :: os_data + integer, intent(out), optional :: status + end subroutine os_link_static <>= - subroutine os_link_static (objlist, exec_name, os_data, status) + module subroutine os_link_static (objlist, exec_name, os_data, status) type(string_t), intent(in) :: objlist, exec_name type(os_data_t), intent(in) :: os_data integer, intent(out), optional :: status type(string_t) :: command_string if (os_data%use_libtool) then command_string = & os_data%whizard_libtool // " --mode=link " // & os_data%fc // " " // & "-static " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools else command_string = & os_data%ld // " " // & os_data%ldflags_so // " " // & os_data%fcflags // " " // & os_data%whizard_ldflags // " " // & os_data%ldflags // " " // & os_data%ldflags_static // " " // & "-o '" // exec_name // "' " // & objlist // " " // & os_data%ldflags_hepmc // " " // & os_data%ldflags_lcio // " " // & os_data%ldflags_hoppet // " " // & os_data%ldflags_looptools end if call os_system_call (command_string, status) end subroutine os_link_static @ %def os_link_static @ Determine the name of the shared library to link. If libtool is used, this is encoded in the [[.la]] file which resides in place of the library itself. <>= public :: os_get_dlname +<>= + module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) + type(string_t) :: dlname + type(string_t), intent(in) :: lib + type(os_data_t), intent(in) :: os_data + logical, intent(in), optional :: ignore, silent + end function os_get_dlname <>= - function os_get_dlname (lib, os_data, ignore, silent) result (dlname) + module function os_get_dlname (lib, os_data, ignore, silent) result (dlname) type(string_t) :: dlname type(string_t), intent(in) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: ignore, silent type(string_t) :: filename type(string_t) :: buffer logical :: exist, required, quiet integer :: u u = free_unit () if (present (ignore)) then required = .not. ignore else required = .true. end if if (present (silent)) then quiet = silent else quiet = .false. end if if (os_data%use_libtool) then filename = lib // ".la" inquire (file=char(filename), exist=exist) if (exist) then open (unit=u, file=char(filename), action="read", status="old") SCAN_LTFILE: do call get (u, buffer) if (extract (buffer, 1, 7) == "dlname=") then dlname = extract (buffer, 9) dlname = remove (dlname, len (dlname)) exit SCAN_LTFILE end if end do SCAN_LTFILE close (u) else if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "': libtool archive not found") dlname = "" else if (.not. quiet) call msg_message ("[No compiled library '" & // char (lib) // "']") dlname = "" end if else dlname = lib // "." // os_data%fc_shrlib_ext inquire (file=char(dlname), exist=exist) if (.not. exist) then if (required) then if (.not. quiet) call msg_fatal (" Library '" // char (lib) & // "' not found") else if (.not. quiet) call msg_message & ("[No compiled process library '" // char (lib) // "']") dlname = "" end if end if end if end function os_get_dlname @ %def os_get_dlname @ \subsection{Controlling OpenMP} OpenMP is handled automatically by the library for the most part. Here is a convenience routine for setting the number of threads, with some diagnostics. <>= public :: openmp_set_num_threads_verbose +<>= + module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) + integer, intent(in) :: num_threads + logical, intent(in), optional :: openmp_logging + end subroutine openmp_set_num_threads_verbose <>= - subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) + module subroutine openmp_set_num_threads_verbose (num_threads, openmp_logging) integer, intent(in) :: num_threads integer :: n_threads logical, intent(in), optional :: openmp_logging logical :: logging if (present (openmp_logging)) then logging = openmp_logging else logging = .true. end if n_threads = num_threads if (openmp_is_active ()) then if (num_threads == 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " thread" call msg_message end if n_threads = num_threads else if (num_threads > 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", num_threads, & " threads" call msg_message end if n_threads = num_threads else if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: " & // "Illegal value of openmp_num_threads (", num_threads, & ") ignored" call msg_error end if n_threads = openmp_get_default_max_threads () if (logging) then write (msg_buffer, "(A,I0,A)") "OpenMP: Using ", & n_threads, " threads" call msg_message end if end if if (n_threads > openmp_get_default_max_threads ()) then if (logging) then write (msg_buffer, "(A,I0)") "OpenMP: " & // "Number of threads is greater than library default of ", & openmp_get_default_max_threads () call msg_warning end if end if call openmp_set_num_threads (n_threads) else if (num_threads /= 1) then if (logging) then write (msg_buffer, "(A,I0,A)") "openmp_num_threads set to ", & num_threads, ", but OpenMP is not active: ignored" call msg_warning end if end if end subroutine openmp_set_num_threads_verbose @ %def openmp_set_num_threads_verbose @ \subsection{Controlling MPI} The overall MPI handling has to be defined in a context specific way, but we can simplify things like logging or receiving [[n_size]] or [[rank]]. <>= public :: mpi_set_logging +<>= + module subroutine mpi_set_logging (mpi_logging) + logical, intent(in) :: mpi_logging + end subroutine mpi_set_logging <>= - subroutine mpi_set_logging (mpi_logging) + module subroutine mpi_set_logging (mpi_logging) logical, intent(in) :: mpi_logging integer :: n_size, rank call mpi_get_comm_id (n_size, rank) if (mpi_logging .and. n_size > 1) then write (msg_buffer, "(A,I0,A)") "MPI: Using ", n_size, " processes." call msg_message () if (rank == 0) then call msg_message ("MPI: master worker") else write (msg_buffer, "(A,I0)") "MPI: slave worker #", rank call msg_message () end if end if end subroutine mpi_set_logging @ %def mpi_set_logging @ Receive communicator size and rank inside communicator. The subroutine is a stub, if not compiled with [[MPI]]. <>= public :: mpi_get_comm_id +<>= + module subroutine mpi_get_comm_id (n_size, rank) + integer, intent(out) :: n_size + integer, intent(out) :: rank + end subroutine mpi_get_comm_id <>= - subroutine mpi_get_comm_id (n_size, rank) + module subroutine mpi_get_comm_id (n_size, rank) integer, intent(out) :: n_size integer, intent(out) :: rank n_size = 1 rank = 0 <> end subroutine mpi_get_comm_id @ %def mpi_get_comm_id <>= @ <>= call MPI_Comm_size (MPI_COMM_WORLD, n_size) call MPI_Comm_rank (MPI_COMM_WORLD, rank) @ <>= public :: mpi_is_comm_master +<>= + module function mpi_is_comm_master () result (flag) + logical :: flag + end function mpi_is_comm_master <>= - logical function mpi_is_comm_master () result (flag) + module function mpi_is_comm_master () result (flag) integer :: n_size, rank + logical :: flag call mpi_get_comm_id (n_size, rank) flag = (rank == 0) end function mpi_is_comm_master @ %def mpi_is_comm_master @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[os_interface_ut.f90]]>>= <> module os_interface_ut use unit_tests use os_interface_uti <> <> contains <> end module os_interface_ut @ %def os_interface_ut @ <<[[os_interface_uti.f90]]>>= <> module os_interface_uti use, intrinsic :: iso_c_binding !NODEP! <> use io_units use os_interface <> <> contains <> end module os_interface_uti @ %def os_interface_ut @ API: driver for the unit tests below. <>= public :: os_interface_test <>= subroutine os_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine os_interface_test @ %def os_interface_test @ Write a Fortran source file, compile it to a shared library, load it, and execute the contained function. <>= call test (os_interface_1, "os_interface_1", & "check OS interface routines", & u, results) <>= public :: os_interface_1 <>= subroutine os_interface_1 (u) integer, intent(in) :: u type(dlaccess_t) :: dlaccess type(string_t) :: fname, libname, ext type(os_data_t) :: os_data type(string_t) :: filename_src, filename_obj abstract interface function so_test_proc (i) result (j) bind(C) import c_int integer(c_int), intent(in) :: i integer(c_int) :: j end function so_test_proc end interface procedure(so_test_proc), pointer :: so_test => null () type(c_funptr) :: c_fptr integer :: unit integer(c_int) :: i call os_data%init () fname = "so_test" filename_src = fname // os_data%fc_src_ext if (os_data%use_libtool) then ext = ".lo" else ext = os_data%obj_ext end if filename_obj = fname // ext libname = fname // '.' // os_data%fc_shrlib_ext write (u, "(A)") "* Test output: OS interface" write (u, "(A)") "* Purpose: check os_interface routines" write (u, "(A)") write (u, "(A)") "* write source file 'so_test.f90'" write (u, "(A)") unit = free_unit () open (unit=unit, file=char(filename_src), action="write") write (unit, "(A)") "function so_test (i) result (j) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " integer(c_int) :: j" write (unit, "(A)") " j = 2 * i" write (unit, "(A)") "end function so_test" close (unit) write (u, "(A)") "* compile and link as 'so_test.so/dylib'" write (u, "(A)") call os_compile_shared (fname, os_data) call os_link_shared (filename_obj, fname, os_data) write (u, "(A)") "* load library 'so_test.so/dylib'" write (u, "(A)") call dlaccess_init (dlaccess, var_str ("."), libname, os_data) if (dlaccess_is_open (dlaccess)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if write (u, "(A)") "* load symbol 'so_test'" write (u, "(A)") c_fptr = dlaccess_get_c_funptr (dlaccess, fname) if (c_associated (c_fptr)) then write (u, "(A)") " success" else write (u, "(A)") " failure" end if call c_f_procpointer (c_fptr, so_test) write (u, "(A)") "* Execute function from 'so_test.so/dylib'" i = 7 write (u, "(A,1x,I1)") " input = ", i write (u, "(A,1x,I1)") " result = ", so_test(i) if (so_test(i) / i .ne. 2) then write (u, "(A)") "* Compiling and linking ISO C functions failed." else write (u, "(A)") "* Successful." end if write (u, "(A)") write (u, "(A)") "* Cleanup" call dlaccess_final (dlaccess) end subroutine os_interface_1 @ %def os_interface_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Interface for formatted I/O} For access to formatted printing (possibly input), we interface the C [[printf]] family of functions. There are two important issues here: \begin{enumerate} \item [[printf]] takes an arbitrary number of arguments, relying on the C stack. This is not interoperable. We interface it with C wrappers that output a single integer, real or string and restrict the allowed formats accordingly. \item Restricting format strings is essential also for preventing format string attacks. Allowing arbitrary format string would create a real security hole in a Fortran program. \item The string returned by [[sprintf]] must be allocated to the right size. \end{enumerate} <<[[formats.f90]]>>= <> module formats use, intrinsic :: iso_c_binding <> <> - use io_units - use diagnostics <> <> <> <> <> + interface +<> + end interface + +end module formats +@ %def formats +@ +<<[[formats_sub.f90]]>>= +<> + +submodule (formats) formats_s + + use io_units + use diagnostics + contains <> -end module formats -@ %def formats +end submodule formats_s + +@ %def formats_s @ \subsection{Parsing a C format string} The C format string contains characters and format conversion specifications. The latter are initiated by a [[%]] sign. If the next letter is also a [[%]], a percent sign is printed and no conversion is done. Otherwise, a conversion is done and applied to the next argument in the argument list. First comes an optional flag ([[#]], [[0]], [[-]], [[+]], or space), an optional field width (decimal digits starting not with zero), an optional precision (period, then another decimal digit string), a length modifier (irrelevant for us, therefore not supported), and a conversion specifier: [[d]] or [[i]] for integer; [[e]], [[f]], [[g]] (also upper case) for double-precision real, [[s]] for a string. We explicitly exclude all other conversion specifiers, and we check the specifiers against the actual arguments. \subsubsection{A type for passing arguments} This is a polymorphic type that can hold integer, real (double), and string arguments. <>= integer, parameter, public :: ARGTYPE_NONE = 0 integer, parameter, public :: ARGTYPE_LOG = 1 integer, parameter, public :: ARGTYPE_INT = 2 integer, parameter, public :: ARGTYPE_REAL = 3 integer, parameter, public :: ARGTYPE_STR = 4 @ %def ARGTYPE_NONE ARGTYPE_LOG ARGTYPE_INT ARGTYPE_REAL ARGTYPE_STRING @ The integer and real entries are actually scalars, but we avoid relying on the allocatable-scalar feature and make them one-entry arrays. The character entry is a real array which is a copy of the string. Logical values are mapped to strings (true or false), so this type parameter value is mostly unused. <>= public :: sprintf_arg_t <>= type :: sprintf_arg_t private integer :: type = ARGTYPE_NONE integer(c_int), dimension(:), allocatable :: ival real(c_double), dimension(:), allocatable :: rval character(c_char), dimension(:), allocatable :: sval end type sprintf_arg_t @ %def sprintf_arg_t <>= public :: sprintf_arg_init <>= interface sprintf_arg_init module procedure sprintf_arg_init_log module procedure sprintf_arg_init_int module procedure sprintf_arg_init_real module procedure sprintf_arg_init_str end interface +<>= + module subroutine sprintf_arg_init_log (arg, lval) + type(sprintf_arg_t), intent(out) :: arg + logical, intent(in) :: lval + end subroutine sprintf_arg_init_log + module subroutine sprintf_arg_init_int (arg, ival) + type(sprintf_arg_t), intent(out) :: arg + integer, intent(in) :: ival + end subroutine sprintf_arg_init_int + module subroutine sprintf_arg_init_real (arg, rval) + type(sprintf_arg_t), intent(out) :: arg + real(default), intent(in) :: rval + end subroutine sprintf_arg_init_real + module subroutine sprintf_arg_init_str (arg, sval) + type(sprintf_arg_t), intent(out) :: arg + type(string_t), intent(in) :: sval + end subroutine sprintf_arg_init_str <>= - subroutine sprintf_arg_init_log (arg, lval) + module subroutine sprintf_arg_init_log (arg, lval) type(sprintf_arg_t), intent(out) :: arg logical, intent(in) :: lval arg%type = ARGTYPE_STR if (lval) then allocate (arg%sval (5)) arg%sval = ['t', 'r', 'u', 'e', c_null_char] else allocate (arg%sval (6)) arg%sval = ['f', 'a', 'l', 's', 'e', c_null_char] end if end subroutine sprintf_arg_init_log - subroutine sprintf_arg_init_int (arg, ival) + module subroutine sprintf_arg_init_int (arg, ival) type(sprintf_arg_t), intent(out) :: arg integer, intent(in) :: ival arg%type = ARGTYPE_INT allocate (arg%ival (1)) arg%ival = ival end subroutine sprintf_arg_init_int - subroutine sprintf_arg_init_real (arg, rval) + module subroutine sprintf_arg_init_real (arg, rval) type(sprintf_arg_t), intent(out) :: arg real(default), intent(in) :: rval arg%type = ARGTYPE_REAL allocate (arg%rval (1)) arg%rval = rval end subroutine sprintf_arg_init_real - subroutine sprintf_arg_init_str (arg, sval) + module subroutine sprintf_arg_init_str (arg, sval) type(sprintf_arg_t), intent(out) :: arg type(string_t), intent(in) :: sval integer :: i arg%type = ARGTYPE_STR allocate (arg%sval (len (sval) + 1)) do i = 1, len (sval) arg%sval(i) = extract (sval, i, i) end do arg%sval(len (sval) + 1) = c_null_char end subroutine sprintf_arg_init_str @ %def sprintf_arg_init <>= subroutine sprintf_arg_write (arg, unit) type(sprintf_arg_t), intent(in) :: arg integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) select case (arg%type) case (ARGTYPE_NONE) write (u, *) "[none]" case (ARGTYPE_INT) write (u, "(1x,A,1x)", advance = "no") "[int]" write (u, *) arg%ival case (ARGTYPE_REAL) write (u, "(1x,A,1x)", advance = "no") "[real]" write (u, *) arg%rval case (ARGTYPE_STR) write (u, "(1x,A,1x,A)", advance = "no") "[string]", '"' write (u, *) arg%rval, '"' end select end subroutine sprintf_arg_write @ %def sprintf_arg_write @ Return an upper bound for the length of the printed version; in case of strings the result is exact. <>= elemental function sprintf_arg_get_length (arg) result (length) integer :: length type(sprintf_arg_t), intent(in) :: arg select case (arg%type) case (ARGTYPE_INT) length = log10 (real (huge (arg%ival(1)))) + 2 case (ARGTYPE_REAL) length = log10 (real (radix (arg%rval(1))) ** digits (arg%rval(1))) + 8 case (ARGTYPE_STR) length = size (arg%sval) case default length = 0 end select end function sprintf_arg_get_length @ %def sprintf_arg_get_length <>= subroutine sprintf_arg_apply_sprintf (arg, fmt, result, actual_length) type(sprintf_arg_t), intent(in) :: arg character(c_char), dimension(:), intent(in) :: fmt character(c_char), dimension(:), intent(inout) :: result integer, intent(out) :: actual_length integer(c_int) :: ival real(c_double) :: rval select case (arg%type) case (ARGTYPE_NONE) actual_length = sprintf_none (result, fmt) case (ARGTYPE_INT) ival = arg%ival(1) actual_length = sprintf_int (result, fmt, ival) case (ARGTYPE_REAL) rval = arg%rval(1) actual_length = sprintf_double (result, fmt, rval) case (ARGTYPE_STR) actual_length = sprintf_str (result, fmt, arg%sval) case default call msg_bug ("sprintf_arg_apply_sprintf called with illegal type") end select if (actual_length < 0) then write (msg_buffer, *) "Format: '", fmt, "'" call msg_message () write (msg_buffer, *) "Output: '", result, "'" call msg_message () call msg_error ("I/O error in sprintf call") actual_length = 0 end if end subroutine sprintf_arg_apply_sprintf @ %def sprintf_arg_apply_sprintf @ \subsubsection{Container type for the output} There is a procedure which chops the format string into pieces that contain at most one conversion specifier. Pairing this with a [[sprintf_arg]] object, we get the actual input to the [[sprintf]] interface. The type below holds this input and can allocate the output string. <>= type :: sprintf_interface_t private character(c_char), dimension(:), allocatable :: input_fmt type(sprintf_arg_t) :: arg character(c_char), dimension(:), allocatable :: output_str integer :: output_str_len = 0 end type sprintf_interface_t @ %def sprintf_fmt_t <>= subroutine sprintf_interface_init (intf, fmt, arg) type(sprintf_interface_t), intent(out) :: intf type(string_t), intent(in) :: fmt type(sprintf_arg_t), intent(in) :: arg integer :: fmt_len, i fmt_len = len (fmt) allocate (intf%input_fmt (fmt_len + 1)) do i = 1, fmt_len intf%input_fmt(i) = extract (fmt, i, i) end do intf%input_fmt(fmt_len+1) = c_null_char intf%arg = arg allocate (intf%output_str (len (fmt) + sprintf_arg_get_length (arg) + 1)) end subroutine sprintf_interface_init @ %def sprintf_interface_init <>= subroutine sprintf_interface_write (intf, unit) type(sprintf_interface_t), intent(in) :: intf integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, *) "Format string = ", '"', intf%input_fmt, '"' write (u, "(1x,A,1x)", advance = "no") "Argument = " call sprintf_arg_write (intf%arg, unit) if (intf%output_str_len > 0) then write (u, *) "Result string = ", & '"', intf%output_str (1:intf%output_str_len), '"' end if end subroutine sprintf_interface_write @ %def sprintf_interface_write @ Return the output string: <>= function sprintf_interface_get_result (intf) result (string) type(string_t) :: string type(sprintf_interface_t), intent(in) :: intf character(kind = c_char, len = max (intf%output_str_len, 0)) :: buffer integer :: i if (intf%output_str_len > 0) then do i = 1, intf%output_str_len buffer(i:i) = intf%output_str(i) end do string = buffer(1:intf%output_str_len) else string = "" end if end function sprintf_interface_get_result @ %def sprintf_interface_get_result <>= subroutine sprintf_interface_apply_sprintf (intf) type(sprintf_interface_t), intent(inout) :: intf call sprintf_arg_apply_sprintf & (intf%arg, intf%input_fmt, intf%output_str, intf%output_str_len) end subroutine sprintf_interface_apply_sprintf @ %def sprintf_interface_apply_sprintf @ Import the interfaces defined in the previous section: <>= <> @ \subsubsection{Scan the format string} Chop it into pieces that contain one conversion specifier each. The zero-th piece contains the part before the first specifier. Check the specifiers and allow only the subset that we support. Also check for an exact match between conversion specifiers and input arguments. The result is an allocated array of [[sprintf_interface]] object; each one contains a piece of the format string and the corresponding argument. <>= subroutine chop_and_check_format_string (fmt, arg, intf) type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), intent(out), allocatable :: intf integer :: n_args, i type(string_t), dimension(:), allocatable :: split_fmt type(string_t) :: word, buffer, separator integer :: pos, length, l logical :: ok type(sprintf_arg_t) :: arg_null ok = .true. length = 0 n_args = size (arg) allocate (split_fmt (0:n_args)) split_fmt = "" buffer = fmt SCAN_ARGS: do i = 1, n_args FIND_CONVERSION: do call split (buffer, word, "%", separator=separator) if (separator == "") then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too few conversion specifiers in format string") ok = .false.; exit SCAN_ARGS end if split_fmt(i-1) = split_fmt(i-1) // word if (extract (buffer, 1, 1) /= "%") then split_fmt(i) = "%" exit FIND_CONVERSION else split_fmt(i-1) = split_fmt(i-1) // "%" end if end do FIND_CONVERSION pos = verify (buffer, "#0-+ ") ! Flag characters (zero or more) split_fmt(i) = split_fmt(i) // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) pos = verify (buffer, "123456890") ! Field width word = extract (buffer, 1, pos-1) if (len (word) /= 0) then call read_int_from_string (word, len (word), l) length = length + l end if split_fmt(i) = split_fmt(i) // word buffer = remove (buffer, 1, pos-1) if (extract (buffer, 1, 1) == ".") then buffer = remove (buffer, 1, 1) pos = verify (buffer, "1234567890") ! Precision split_fmt(i) = split_fmt(i) // "." // extract (buffer, 1, pos-1) buffer = remove (buffer, 1, pos-1) end if ! Length modifier would come here, but is not allowed select case (char (extract (buffer, 1, 1))) ! conversion specifier case ("d", "i") if (arg(i)%type /= ARGTYPE_INT) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: integer value expected") ok = .false.; exit SCAN_ARGS end if case ("e", "E", "f", "F", "g", "G") if (arg(i)%type /= ARGTYPE_REAL) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: real value expected") ok = .false.; exit SCAN_ARGS end if case ("s") if (arg(i)%type /= ARGTYPE_STR) then call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "argument type mismatch: logical or string value expected") ok = .false.; exit SCAN_ARGS end if case default call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "illegal or incomprehensible conversion specifier") ok = .false.; exit SCAN_ARGS end select split_fmt(i) = split_fmt(i) // extract (buffer, 1, 1) buffer = remove (buffer, 1, 1) end do SCAN_ARGS if (ok) then FIND_EXTRA_CONVERSION: do call split (buffer, word, "%", separator=separator) split_fmt(n_args) = split_fmt(n_args) // word // separator if (separator == "") exit FIND_EXTRA_CONVERSION if (extract (buffer, 1, 1) == "%") then split_fmt(n_args) = split_fmt(n_args) // "%" buffer = remove (buffer, 1, 1) else call msg_message ('"' // char (fmt) // '"') call msg_error ("C-formatting string: " & // "too many conversion specifiers in format string") ok = .false.; exit FIND_EXTRA_CONVERSION end if end do FIND_EXTRA_CONVERSION split_fmt(n_args) = split_fmt(n_args) // buffer allocate (intf (0:n_args)) call sprintf_interface_init (intf(0), split_fmt(0), arg_null) do i = 1, n_args call sprintf_interface_init (intf(i), split_fmt(i), arg(i)) end do else allocate (intf (0)) end if contains subroutine read_int_from_string (word, length, l) type(string_t), intent(in) :: word integer, intent(in) :: length integer, intent(out) :: l character(len=length) :: buffer buffer = word read (buffer, *) l end subroutine read_int_from_string end subroutine chop_and_check_format_string @ %def chop_and_check_format_string @ \subsection{API} <>= public :: sprintf +<>= + module function sprintf (fmt, arg) result (string) + type(string_t) :: string + type(string_t), intent(in) :: fmt + type(sprintf_arg_t), dimension(:), intent(in) :: arg + end function sprintf <>= - function sprintf (fmt, arg) result (string) + module function sprintf (fmt, arg) result (string) type(string_t) :: string type(string_t), intent(in) :: fmt type(sprintf_arg_t), dimension(:), intent(in) :: arg type(sprintf_interface_t), dimension(:), allocatable :: intf integer :: i string = "" call chop_and_check_format_string (fmt, arg, intf) if (size (intf) > 0) then do i = 0, ubound (intf, 1) call sprintf_interface_apply_sprintf (intf(i)) string = string // sprintf_interface_get_result (intf(i)) end do end if end function sprintf @ %def sprintf @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[formats_ut.f90]]>>= <> module formats_ut use unit_tests use formats_uti <> <> contains <> end module formats_ut @ %def formats_ut @ <<[[formats_uti.f90]]>>= <> module formats_uti <> <> use formats <> <> <> contains <> end module formats_uti @ %def formats_ut @ API: driver for the unit tests below. <>= public :: format_test <>= subroutine format_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine format_test @ %def format_test <>= call test (format_1, "format_1", & "check formatting routines", & u, results) <>= public :: format_1 <>= subroutine format_1 (u) integer, intent(in) :: u write (u, "(A)") "*** Test 1: a string ***" write (u, "(A)") call test_run (var_str("%s"), 1, [4], ['abcdefghij'], u) write (u, "(A)") "*** Test 2: two integers ***" write (u, "(A)") call test_run (var_str("%d,%d"), 2, [2, 2], ['42', '13'], u) write (u, "(A)") "*** Test 3: floating point number ***" write (u, "(A)") call test_run (var_str("%8.4f"), 1, [3], ['42567.12345'], u) write (u, "(A)") "*** Test 4: general expression ***" call test_run (var_str("%g"), 1, [3], ['3.1415'], u) contains subroutine test_run (fmt, n_args, type, buffer, unit) type(string_t), intent(in) :: fmt integer, intent(in) :: n_args, unit logical :: lval integer :: ival real(default) :: rval integer :: i type(string_t) :: string type(sprintf_arg_t), dimension(:), allocatable :: arg integer, dimension(n_args), intent(in) :: type character(*), dimension(n_args), intent(in) :: buffer write (unit, "(A,A)") "Format string :", char(fmt) write (unit, "(A,I1)") "Number of args:", n_args allocate (arg (n_args)) do i = 1, n_args write (unit, "(A,I1)") "Argument (type ) = ", type(i) select case (type(i)) case (ARGTYPE_LOG) read (buffer(i), *) lval call sprintf_arg_init (arg(i), lval) case (ARGTYPE_INT) read (buffer(i), *) ival call sprintf_arg_init (arg(i), ival) case (ARGTYPE_REAL) read (buffer(i), *) rval call sprintf_arg_init (arg(i), rval) case (ARGTYPE_STR) call sprintf_arg_init (arg(i), var_str (trim (buffer(i)))) end select end do string = sprintf (fmt, arg) write (unit, "(A,A,A)") "Result: '", char (string), "'" deallocate (arg) end subroutine test_run end subroutine format_1 @ %def format_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{CPU timing} The time is stored in a simple derived type which just holds a floating-point number. <<[[cputime.f90]]>>= <> module cputime <> - use io_units <> - use diagnostics <> <> <> <> + interface +<> + end interface + +end module cputime +@ %def cputime +<<[[cputime_sub.f90]]>>= +<> + +submodule (cputime) cputime_s + + use io_units + use diagnostics + contains <> -end module cputime -@ %def cputime +end submodule cputime_s + +@ %def cputime_s +@ @ The CPU time is a floating-point number with an arbitrary reference time. It is single precision (default real, not [[real(default)]]). It is measured in seconds. <>= public :: time_t <>= type :: time_t private logical :: known = .false. real :: value = 0 contains <> end type time_t @ %def time_t <>= procedure :: write => time_write +<>= + module subroutine time_write (object, unit) + class(time_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine time_write <>= - subroutine time_write (object, unit) + module subroutine time_write (object, unit) class(time_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)", advance="no") "Time in seconds =" if (object%known) then write (u, "(1x,ES10.3)") object%value else write (u, "(1x,A)") "[unknown]" end if end subroutine time_write @ %def time_write @ Set the current time <>= procedure :: set_current => time_set_current +<>= + module subroutine time_set_current (time) + class(time_t), intent(out) :: time + end subroutine time_set_current <>= - subroutine time_set_current (time) + module subroutine time_set_current (time) class(time_t), intent(out) :: time integer :: msecs call system_clock (msecs) time%value = real (msecs) / 1000. time%known = time%value > 0 end subroutine time_set_current @ %def time_set_current @ Assign to a [[real(default]] value. If the time is undefined, return zero. <>= public :: assignment(=) <>= interface assignment(=) module procedure real_assign_time module procedure real_default_assign_time end interface +<>= + pure module subroutine real_assign_time (r, time) + real, intent(out) :: r + class(time_t), intent(in) :: time + end subroutine real_assign_time + pure module subroutine real_default_assign_time (r, time) + real(default), intent(out) :: r + class(time_t), intent(in) :: time + end subroutine real_default_assign_time <>= - pure subroutine real_assign_time (r, time) + pure module subroutine real_assign_time (r, time) real, intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_assign_time - pure subroutine real_default_assign_time (r, time) + pure module subroutine real_default_assign_time (r, time) real(default), intent(out) :: r class(time_t), intent(in) :: time if (time%known) then r = time%value else r = 0 end if end subroutine real_default_assign_time @ %def real_assign_time @ Assign an integer or (single precision) real value to the time object. <>= generic :: assignment(=) => time_assign_from_integer, time_assign_from_real procedure, private :: time_assign_from_integer procedure, private :: time_assign_from_real +<>= + module subroutine time_assign_from_integer (time, ival) + class(time_t), intent(out) :: time + integer, intent(in) :: ival + end subroutine time_assign_from_integer + module subroutine time_assign_from_real (time, rval) + class(time_t), intent(out) :: time + real, intent(in) :: rval + end subroutine time_assign_from_real <>= - subroutine time_assign_from_integer (time, ival) + module subroutine time_assign_from_integer (time, ival) class(time_t), intent(out) :: time integer, intent(in) :: ival time%value = ival time%known = .true. end subroutine time_assign_from_integer - subroutine time_assign_from_real (time, rval) + module subroutine time_assign_from_real (time, rval) class(time_t), intent(out) :: time real, intent(in) :: rval time%value = rval time%known = .true. end subroutine time_assign_from_real @ %def time_assign_from_real @ Add times and compute time differences. If any input value is undefined, the result is undefined. <>= generic :: operator(-) => subtract_times generic :: operator(+) => add_times procedure, private :: subtract_times procedure, private :: add_times +<>= + pure module function subtract_times (t_end, t_begin) result (time) + type(time_t) :: time + class(time_t), intent(in) :: t_end, t_begin + end function subtract_times + pure module function add_times (t1, t2) result (time) + type(time_t) :: time + class(time_t), intent(in) :: t1, t2 + end function add_times <>= - pure function subtract_times (t_end, t_begin) result (time) + pure module function subtract_times (t_end, t_begin) result (time) type(time_t) :: time class(time_t), intent(in) :: t_end, t_begin if (t_end%known .and. t_begin%known) then time%known = .true. time%value = t_end%value - t_begin%value end if end function subtract_times - pure function add_times (t1, t2) result (time) + pure module function add_times (t1, t2) result (time) type(time_t) :: time class(time_t), intent(in) :: t1, t2 if (t1%known .and. t2%known) then time%known = .true. time%value = t1%value + t2%value end if end function add_times @ %def subtract_times @ %def add_times @ Check if a time is known, so we can use it: <>= procedure :: is_known => time_is_known +<>= + module function time_is_known (time) result (flag) + class(time_t), intent(in) :: time + logical :: flag + end function time_is_known <>= - function time_is_known (time) result (flag) + module function time_is_known (time) result (flag) class(time_t), intent(in) :: time logical :: flag flag = time%known end function time_is_known @ %def time_is_known @ We define functions for converting the time into ss / mm:ss / hh:mm:ss / dd:mm:hh:ss. <>= generic :: expand => time_expand_s, time_expand_ms, & time_expand_hms, time_expand_dhms procedure, private :: time_expand_s procedure, private :: time_expand_ms procedure, private :: time_expand_hms procedure, private :: time_expand_dhms +<>= + module subroutine time_expand_s (time, sec) + class(time_t), intent(in) :: time + integer, intent(out) :: sec + end subroutine time_expand_s + module subroutine time_expand_ms (time, min, sec) + class(time_t), intent(in) :: time + integer, intent(out) :: min, sec + end subroutine time_expand_ms + module subroutine time_expand_hms (time, hour, min, sec) + class(time_t), intent(in) :: time + integer, intent(out) :: hour, min, sec + end subroutine time_expand_hms + module subroutine time_expand_dhms (time, day, hour, min, sec) + class(time_t), intent(in) :: time + integer, intent(out) :: day, hour, min, sec + end subroutine time_expand_dhms <>= - subroutine time_expand_s (time, sec) + module subroutine time_expand_s (time, sec) class(time_t), intent(in) :: time integer, intent(out) :: sec if (time%known) then sec = time%value else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_s - subroutine time_expand_ms (time, min, sec) + module subroutine time_expand_ms (time, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: min, sec if (time%known) then if (time%value >= 0) then sec = mod (int (time%value), 60) else sec = - mod (int (- time%value), 60) end if min = time%value / 60 else call msg_bug ("Time: attempt to expand undefined value") end if end subroutine time_expand_ms - subroutine time_expand_hms (time, hour, min, sec) + module subroutine time_expand_hms (time, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: hour, min, sec call time%expand (min, sec) hour = min / 60 if (min >= 0) then min = mod (min, 60) else min = - mod (-min, 60) end if end subroutine time_expand_hms - subroutine time_expand_dhms (time, day, hour, min, sec) + module subroutine time_expand_dhms (time, day, hour, min, sec) class(time_t), intent(in) :: time integer, intent(out) :: day, hour, min, sec call time%expand (hour, min, sec) day = hour / 24 if (hour >= 0) then hour = mod (hour, 24) else hour = - mod (- hour, 24) end if end subroutine time_expand_dhms @ %def time_expand @ Use the above expansions to generate a time string. <>= procedure :: to_string_s => time_to_string_s procedure :: to_string_ms => time_to_string_ms procedure :: to_string_hms => time_to_string_hms procedure :: to_string_dhms => time_to_string_dhms +<>= + module function time_to_string_s (time) result (str) + class(time_t), intent(in) :: time + type(string_t) :: str + end function time_to_string_s + module function time_to_string_ms (time, blank) result (str) + class(time_t), intent(in) :: time + logical, intent(in), optional :: blank + type(string_t) :: str + end function time_to_string_ms + module function time_to_string_hms (time) result (str) + class(time_t), intent(in) :: time + type(string_t) :: str + end function time_to_string_hms + module function time_to_string_dhms (time) result (str) + class(time_t), intent(in) :: time + type(string_t) :: str + end function time_to_string_dhms <>= - function time_to_string_s (time) result (str) + module function time_to_string_s (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s call time%expand (s) write (buffer, "(I0,'s')") s str = trim (buffer) end function time_to_string_s - function time_to_string_ms (time, blank) result (str) + module function time_to_string_ms (time, blank) result (str) class(time_t), intent(in) :: time logical, intent(in), optional :: blank type(string_t) :: str character(256) :: buffer integer :: s, m logical :: x_out x_out = .false. if (present (blank)) x_out = blank call time%expand (m, s) write (buffer, "(I0,'m:',I2.2,'s')") m, abs (s) str = trim (buffer) if (x_out) then str = replace (str, len(str)-1, "X") end if end function time_to_string_ms - function time_to_string_hms (time) result (str) + module function time_to_string_hms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h call time%expand (h, m, s) write (buffer, "(I0,'h:',I2.2,'m:',I2.2,'s')") h, abs (m), abs (s) str = trim (buffer) end function time_to_string_hms - function time_to_string_dhms (time) result (str) + module function time_to_string_dhms (time) result (str) class(time_t), intent(in) :: time type(string_t) :: str character(256) :: buffer integer :: s, m, h, d call time%expand (d, h, m, s) write (buffer, "(I0,'d:',I2.2,'h:',I2.2,'m:',I2.2,'s')") & d, abs (h), abs (m), abs (s) str = trim (buffer) end function time_to_string_dhms @ %def time_to_string @ \subsection{Timer} A timer can measure real (wallclock) time differences. The base type corresponds to the result, i.e., time difference. The object contains two further times for start and stop time. <>= public :: timer_t <>= type, extends (time_t) :: timer_t private logical :: running = .false. type(time_t) :: t1, t2 contains <> end type timer_t @ %def timer_t @ Output. If the timer is running, we indicate this, otherwise write just the result. <>= procedure :: write => timer_write +<>= + module subroutine timer_write (object, unit) + class(timer_t), intent(in) :: object + integer, intent(in), optional :: unit + end subroutine timer_write <>= - subroutine timer_write (object, unit) + module subroutine timer_write (object, unit) class(timer_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%running) then write (u, "(1x,A)") "Time in seconds = [running]" else call object%time_t%write (u) end if end subroutine timer_write @ %def timer_write @ Start the timer: store the current time in the first entry and adapt the status. We forget any previous values. <>= procedure :: start => timer_start +<>= + module subroutine timer_start (timer) + class(timer_t), intent(out) :: timer + end subroutine timer_start <>= - subroutine timer_start (timer) + module subroutine timer_start (timer) class(timer_t), intent(out) :: timer call timer%t1%set_current () timer%running = .true. end subroutine timer_start @ %def timer_start @ Restart the timer: simply adapt the status, keeping the start time. <>= procedure :: restart => timer_restart +<>= + module subroutine timer_restart (timer) + class(timer_t), intent(inout) :: timer + end subroutine timer_restart <>= - subroutine timer_restart (timer) + module subroutine timer_restart (timer) class(timer_t), intent(inout) :: timer if (timer%t1%known .and. .not. timer%running) then timer%running = .true. else call msg_bug ("Timer: restart attempt from wrong status") end if end subroutine timer_restart @ %def timer_start @ Stop the timer: store the current time in the second entry, adapt the status, and compute the elapsed time. <>= procedure :: stop => timer_stop +<>= + module subroutine timer_stop (timer) + class(timer_t), intent(inout) :: timer + end subroutine timer_stop <>= - subroutine timer_stop (timer) + module subroutine timer_stop (timer) class(timer_t), intent(inout) :: timer call timer%t2%set_current () timer%running = .false. call timer%evaluate () end subroutine timer_stop @ %def timer_stop @ Manually set the time (for unit test) <>= procedure :: set_test_time1 => timer_set_test_time1 procedure :: set_test_time2 => timer_set_test_time2 +<>= + module subroutine timer_set_test_time1 (timer, t) + class(timer_t), intent(inout) :: timer + integer, intent(in) :: t + end subroutine timer_set_test_time1 + module subroutine timer_set_test_time2 (timer, t) + class(timer_t), intent(inout) :: timer + integer, intent(in) :: t + end subroutine timer_set_test_time2 <>= - subroutine timer_set_test_time1 (timer, t) + module subroutine timer_set_test_time1 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t1 = t end subroutine timer_set_test_time1 - subroutine timer_set_test_time2 (timer, t) + module subroutine timer_set_test_time2 (timer, t) class(timer_t), intent(inout) :: timer integer, intent(in) :: t timer%t2 = t end subroutine timer_set_test_time2 @ %def timer_set_test_time1 @ %def timer_set_test_time2 @ This is separate, available for the unit test. <>= procedure :: evaluate => timer_evaluate +<>= + module subroutine timer_evaluate (timer) + class(timer_t), intent(inout) :: timer + end subroutine timer_evaluate <>= - subroutine timer_evaluate (timer) + module subroutine timer_evaluate (timer) class(timer_t), intent(inout) :: timer timer%time_t = timer%t2 - timer%t1 end subroutine timer_evaluate @ %def timer_evaluate @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[cputime_ut.f90]]>>= <> module cputime_ut use unit_tests use cputime_uti <> <> contains <> end module cputime_ut @ %def cputime_ut @ <<[[cputime_uti.f90]]>>= <> module cputime_uti <> use cputime <> <> contains <> end module cputime_uti @ %def cputime_ut @ API: driver for the unit tests below. <>= public :: cputime_test <>= subroutine cputime_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine cputime_test @ %def cputime_test @ \subsubsection{Basic tests} Check basic functions of the time object. The part which we can't check is getting the actual time from the system clock, since the output will not be reproducible. However, we can check time formats and operations. <>= call test (cputime_1, "cputime_1", & "time operations", & u, results) <>= public :: cputime_1 <>= subroutine cputime_1 (u) integer, intent(in) :: u type(time_t) :: time, time1, time2 real :: t integer :: d, h, m, s write (u, "(A)") "* Test output: cputime_1" write (u, "(A)") "* Purpose: check time operations" write (u, "(A)") write (u, "(A)") "* Undefined time" write (u, *) call time%write (u) write (u, *) write (u, "(A)") "* Set time to zero" write (u, *) time = 0 call time%write (u) write (u, *) write (u, "(A)") "* Set time to 1.234 s" write (u, *) time = 1.234 call time%write (u) t = time write (u, "(1x,A,F6.3)") "Time as real =", t write (u, *) write (u, "(A)") "* Compute time difference" write (u, *) time1 = 5.33 time2 = 7.55 time = time2 - time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Compute time sum" write (u, *) time = time2 + time1 call time1%write (u) call time2%write (u) call time%write (u) write (u, *) write (u, "(A)") "* Expand time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s write (u, *) write (u, "(A)") "* Expand negative time" write (u, *) time1 = - (((24 + 1) * 60 + 1) * 60 + 1) time2 = - (((3 * 24 + 23) * 60 + 59) * 60 + 59) call time1%expand (s) write (u, 1) "s =", s call time1%expand (m,s) write (u, 1) "ms =", m, s call time1%expand (h,m,s) write (u, 1) "hms =", h, m, s call time1%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s call time2%expand (s) write (u, 1) "s =", s call time2%expand (m,s) write (u, 1) "ms =", m, s call time2%expand (h,m,s) write (u, 1) "hms =", h, m, s call time2%expand (d,h,m,s) write (u, 1) "dhms =", d, h, m, s 1 format (1x,A,1x,4(I0,:,':')) write (u, *) write (u, "(A)") "* String from time" write (u, *) time1 = ((24 + 1) * 60 + 1) * 60 + 1 time2 = ((3 * 24 + 23) * 60 + 59) * 60 + 59 write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Blanking out the last second entry" write (u, "(A)") write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_ms (.true.)) write (u, *) write (u, "(A)") "* String from negative time" write (u, *) time1 = -(((24 + 1) * 60 + 1) * 60 + 1) time2 = -(((3 * 24 + 23) * 60 + 59) * 60 + 59) write (u, "(A)") char (time1%to_string_s ()) write (u, "(A)") char (time1%to_string_ms ()) write (u, "(A)") char (time1%to_string_hms ()) write (u, "(A)") char (time1%to_string_dhms ()) write (u, "(A)") char (time2%to_string_s ()) write (u, "(A)") char (time2%to_string_ms ()) write (u, "(A)") char (time2%to_string_hms ()) write (u, "(A)") char (time2%to_string_dhms ()) write (u, "(A)") write (u, "(A)") "* Test output end: cputime_1" end subroutine cputime_1 @ %def cputime_1 @ \subsubsection{Timer tests} Check a timer object. <>= call test (cputime_2, "cputime_2", & "timer", & u, results) <>= public :: cputime_2 <>= subroutine cputime_2 (u) integer, intent(in) :: u type(timer_t) :: timer write (u, "(A)") "* Test output: cputime_2" write (u, "(A)") "* Purpose: check timer" write (u, "(A)") write (u, "(A)") "* Undefined timer" write (u, *) call timer%write (u) write (u, *) write (u, "(A)") "* Start timer" write (u, *) call timer%start () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer (injecting fake timings)" write (u, *) call timer%stop () call timer%set_test_time1 (2) call timer%set_test_time2 (5) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Restart timer" write (u, *) call timer%restart () call timer%write (u) write (u, *) write (u, "(A)") "* Stop timer again (injecting fake timing)" write (u, *) call timer%stop () call timer%set_test_time2 (10) call timer%evaluate () call timer%write (u) write (u, *) write (u, "(A)") "* Test output end: cputime_2" end subroutine cputime_2 @ %def cputime_2 Index: trunk/src/system/Makefile.am =================================================================== --- trunk/src/system/Makefile.am (revision 8770) +++ trunk/src/system/Makefile.am (revision 8771) @@ -1,238 +1,257 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2021 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## The files in this directory implement OS interactions of WHIZARD ## We create a library which is still to be combined with auxiliary libs. noinst_LTLIBRARIES = libsystem.la check_LTLIBRARIES = libsystem_ut.la COMMON_F90 = \ system_defs.f90 \ signal_interface.c \ sprintf_interface.c \ diagnostics.f90 \ + os_interface.f90 \ formats.f90 \ - cputime.f90 + cputime.f90 MPI_F90 = \ - os_interface.f90_mpi + os_interface_sub.f90_mpi SERIAL_F90 = \ - os_interface.f90_serial + os_interface_sub.f90_serial +SYSTEM_SUBMODULES = \ + diagnostics_sub.f90 \ + formats_sub.f90 \ + cputime_sub.f90 + +SYSTEM_MODULES = \ + system_dependencies.f90 \ + debug_master.f90 \ + $(COMMON_F90) EXTRA_DIST = \ $(COMMON_F90) \ + $(SYSTEM_SUBMODULES) \ $(SERIAL_F90) \ $(MPI_F90) nodist_libsystem_la_SOURCES = \ - system_dependencies.f90 \ - debug_master.f90 \ - os_interface.f90 \ - $(COMMON_F90) + $(SYSTEM_MODULES) \ + $(SYSTEM_SUBMODULES) \ + os_interface_sub.f90 -DISTCLEANFILES = os_interface.f90 +DISTCLEANFILES = os_interface_sub.f90 if FC_USE_MPI -os_interface.f90: os_interface.f90_mpi +os_interface_sub.f90: os_interface_sub.f90_mpi -cp -f $< $@ else -os_interface.f90: os_interface.f90_serial +os_interface_sub.f90: os_interface_sub.f90_serial -cp -f $< $@ endif libsystem_ut_la_SOURCES = \ os_interface_uti.f90 os_interface_ut.f90 \ formats_uti.f90 formats_ut.f90 \ cputime_uti.f90 cputime_ut.f90 ## Omitting this would exclude it from the distribution dist_noinst_DATA = system.nw # Modules and installation # Dump module names into file Modules execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = \ system_dependencies.$(FCMOD) \ debug_master.$(FCMOD) \ system_defs.$(FCMOD) \ cputime.$(FCMOD) \ diagnostics.$(FCMOD) \ formats.$(FCMOD) \ os_interface.$(FCMOD) libsystem_Modules = \ - $(nodist_libsystem_la_SOURCES:.f90=) \ + $(SYSTEM_MODULES:.f90=) \ $(libsystem_ut_la_SOURCES:.f90=) Modules: Makefile @for module in $(libsystem_Modules); do \ echo $$module >> $@.new; \ done @if diff $@ $@.new -q >/dev/null; then \ rm $@.new; \ else \ mv $@.new $@; echo "Modules updated"; \ fi BUILT_SOURCES = Modules ## Fortran module dependencies # Get module lists from other directories module_lists = \ ../basics/Modules \ ../utilities/Modules \ ../testing/Modules $(module_lists): $(MAKE) -C `dirname $@` Modules Module_dependencies.sed: $(nodist_libsystem_la_SOURCES) $(libsystem_ut_la_SOURCES) Module_dependencies.sed: $(module_lists) @rm -f $@ echo 's/, *only:.*//' >> $@ echo 's/, *&//' >> $@ echo 's/, *.*=>.*//' >> $@ echo 's/$$/.lo/' >> $@ for list in $(module_lists); do \ dir="`dirname $$list`"; \ for mod in `cat $$list`; do \ echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \ done \ done DISTCLEANFILES += Module_dependencies.sed # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: Module_dependencies.sed Makefile.depend: $(nodist_libsystem_la_SOURCES) $(libsystem_ut_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -f Module_dependencies.sed; \ done > $@ DISTCLEANFILES += Makefile.depend SUFFIXES = .lo .$(FCMOD) # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FCFLAGS = -I../basics -I../utilities -I../testing +######################################################################## +# For the moment, the submodule dependencies will be hard-coded +diagnostics_sub.lo: diagnostics.lo +os_interface_sub.lo: os_interface.lo +formats_sub.lo: formats.lo +cputime_sub.lo: cputime.lo ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ## MPI if FC_USE_MPI AM_FCFLAGS += $(FCFLAGS_MPI) endif ######################################################################## ## Non-standard targets and dependencies ## (Re)create F90 sources from NOWEB source. if NOWEB_AVAILABLE FILTER = -filter "sed 's/defn MPI:/defn/'" PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw system.stamp: $(PRELUDE) $(srcdir)/system.nw $(POSTLUDE) @rm -f system.tmp @touch system.tmp for src in $(COMMON_F90) $(libsystem_ut_la_SOURCES); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ done + for src in $(SYSTEM_SUBMODULES) $(libsystem_ut_la_SOURCES); do \ + $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \ + done for src in $(SERIAL_F90:.f90_serial=.f90); do \ $(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src'_serial'; \ done for src in $(MPI_F90:.f90_mpi=.f90); do \ $(NOTANGLE) -R[[$$src]] $(FILTER) $^ | $(CPIF) $$src'_mpi'; \ done @mv -f system.tmp system.stamp -$(COMMON_F90) $(SERIAL_F90) $(MPI_F90) $(libsystem_ut_la_SOURCES): system.stamp +$(COMMON_F90) $(SYSTEM_SUBMODULES) $(SERIAL_F90) $(MPI_F90) $(libsystem_ut_la_SOURCES): system.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f system.stamp; \ $(MAKE) $(AM_MAKEFLAGS) system.stamp; \ fi endif ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f *.f90 *.f90_serial *.f90_mpi *.c endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f *.f90 *.f90_serial *.f90_mpi *.c || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f system.stamp system.tmp -rm -f *.$(FCMOD) if FC_SUBMODULES - -rm -f *.smod + -rm -f *.smod *.sub endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup