base_routines.f90

Go to the documentation of this file.

MODULE base_routines

  USE constants
  USE kinds
  USE iso_c_binding
  USE iso_varying_string
  USE machine_constants 

  IMPLICIT NONE

  PRIVATE

  !Module parameters

  INTEGER(INTG), PARAMETER :: max_output_lines=500
  INTEGER(INTG), PARAMETER :: max_output_width=132

  INTEGER(INTG), PARAMETER :: general_output_type=1
  INTEGER(INTG), PARAMETER :: diagnostic_output_type=2
  INTEGER(INTG), PARAMETER :: timing_output_type=3
  INTEGER(INTG), PARAMETER :: error_output_type=4
  INTEGER(INTG), PARAMETER :: warning_output_type=5
  INTEGER(INTG), PARAMETER :: help_output_type=6

  INTEGER(INTG), PARAMETER :: echo_file_unit=10
  INTEGER(INTG), PARAMETER :: diagnostics_file_unit=11
  INTEGER(INTG), PARAMETER :: timing_file_unit=12
  INTEGER(INTG), PARAMETER :: learn_file_unit=13
  INTEGER(INTG), PARAMETER :: io1_file_unit=21
  INTEGER(INTG), PARAMETER :: io2_file_unit=22
  INTEGER(INTG), PARAMETER :: io3_file_unit=23
  INTEGER(INTG), PARAMETER :: io4_file_unit=24
  INTEGER(INTG), PARAMETER :: io5_file_unit=25
  INTEGER(INTG), PARAMETER :: temporary_file_unit=80
  INTEGER(INTG), PARAMETER :: open_comfile_unit=90
  INTEGER(INTG), PARAMETER :: start_read_comfile_unit=90
  INTEGER(INTG), PARAMETER :: stop_read_comfile_unit=99

  INTEGER(INTG), PARAMETER :: all_diag_type=1
  INTEGER(INTG), PARAMETER :: in_diag_type=2
  INTEGER(INTG), PARAMETER :: from_diag_type=3

  INTEGER(INTG), PARAMETER :: all_timing_type=1
  INTEGER(INTG), PARAMETER :: in_timing_type=2
  INTEGER(INTG), PARAMETER :: from_timing_type=3

  !Module types

  TYPE routine_list_item_type
    CHARACTER(LEN=63) :: name
    INTEGER(INTG) :: number_of_invocations
    REAL(SP) :: total_inclusive_cpu_time
    REAL(SP) :: total_inclusive_system_time
    REAL(SP) :: total_exclusive_cpu_time
    REAL(SP) :: total_exclusive_system_time
    TYPE(routine_list_item_type), POINTER :: next_routine
  END TYPE routine_list_item_type

  TYPE routine_list_type
    TYPE(routine_list_item_type), POINTER :: head
  END TYPE routine_list_type

  TYPE routine_stack_item_type
    CHARACTER(LEN=63) :: name
    REAL(SP) :: inclusive_cpu_time
    REAL(SP) :: inclusive_system_time
    REAL(SP) :: exclusive_cpu_time
    REAL(SP) :: exclusive_system_time
    LOGICAL :: diagnostics
    LOGICAL :: timing
    TYPE(routine_list_item_type), POINTER :: routine_list_item
    TYPE(routine_stack_item_type), POINTER :: previous_routine
  END TYPE routine_stack_item_type

  TYPE routine_stack_type
    TYPE(routine_stack_item_type), POINTER :: stack_pointer
  END TYPE routine_stack_type

  !Module variables

  INTEGER(INTG), SAVE :: my_computational_node_number
  INTEGER(INTG), SAVE :: number_of_computational_nodes
  INTEGER(INTG), ALLOCATABLE :: cmiss_random_seeds(:)
  LOGICAL, SAVE :: diagnostics
  LOGICAL, SAVE :: diagnostics1
  LOGICAL, SAVE :: diagnostics2
  LOGICAL, SAVE :: diagnostics3
  LOGICAL, SAVE :: diagnostics4
  LOGICAL, SAVE :: diagnostics5
  LOGICAL, SAVE :: diagnostics_level1
  LOGICAL, SAVE :: diagnostics_level2
  LOGICAL, SAVE :: diagnostics_level3
  LOGICAL, SAVE :: diagnostics_level4
  LOGICAL, SAVE :: diagnostics_level5
  LOGICAL, SAVE :: diag_all_subroutines
  LOGICAL, SAVE :: diag_from_subroutine
  LOGICAL, SAVE :: diag_file_open
  LOGICAL, SAVE :: diag_or_timing
  LOGICAL, SAVE :: echo_output
  LOGICAL, SAVE :: timing
  LOGICAL, SAVE :: timing_summary
  LOGICAL, SAVE :: timing_all_subroutines
  LOGICAL, SAVE :: timing_from_subroutine
  LOGICAL, SAVE :: timing_file_open
  CHARACTER(LEN=MAXSTRLEN), SAVE :: op_string(max_output_lines)
  TYPE(routine_list_type), SAVE :: diag_routine_list
  TYPE(routine_list_type), SAVE :: timing_routine_list
  TYPE(routine_stack_type), SAVE :: routine_stack

  !Interfaces

  INTERFACE

!!!!NOTE: This module needs to call the c cputime function directly in order to avoid a circular module loop when timer uses
!!!!      base_routines.

    SUBROUTINE cputimer(RETURN_TIME, TIME_TYPE, ERR, CERROR) BIND(C,NAME="CPUTimer")
      USE iso_c_binding
      REAL(C_DOUBLE), INTENT(OUT) :: RETURN_TIME
      INTEGER(C_INT), INTENT(IN) :: TIME_TYPE
      INTEGER(C_INT), INTENT(OUT) :: ERR
      CHARACTER(C_CHAR), INTENT(OUT) :: CERROR(*)
    END SUBROUTINE cputimer

  END INTERFACE

  INTERFACE baseroutinesfinalise
    MODULE PROCEDURE base_routines_finalise
  END INTERFACE baseroutinesfinalise

  INTERFACE baseroutinesinitialise
    MODULE PROCEDURE base_routines_initialise
  END INTERFACE baseroutinesinitialise

  INTERFACE computationalnodenumbersset
    MODULE PROCEDURE computational_node_numbers_set
  END INTERFACE computationalnodenumbersset

  INTERFACE diagnosticsseton
    MODULE PROCEDURE diagnostics_set_on
  END INTERFACE diagnosticsseton

  INTERFACE diagnosticssetoff
    MODULE PROCEDURE diagnostics_set_off
  END INTERFACE diagnosticssetoff

  INTERFACE extract_error_message
    MODULE PROCEDURE extract_error_message_c
    MODULE PROCEDURE extract_error_message_vs
  END INTERFACE extract_error_message

  INTERFACE extracterrormessage
    MODULE PROCEDURE extract_error_message_c
    MODULE PROCEDURE extract_error_message_vs
  END INTERFACE extracterrormessage

  INTERFACE flag_error
    MODULE PROCEDURE flag_error_c
    MODULE PROCEDURE flag_error_vs
  END INTERFACE flag_error
  
  INTERFACE flag_warning
    MODULE PROCEDURE flag_warning_c
    MODULE PROCEDURE flag_warning_vs
  END INTERFACE flag_warning

  ! Allow using FlagError and FlagWarning etc, as we shift to the new code style

  INTERFACE flagerror
    MODULE PROCEDURE flag_error_c
    MODULE PROCEDURE flag_error_vs
  END INTERFACE flagerror

  INTERFACE flagwarning
    MODULE PROCEDURE flag_warning_c
    MODULE PROCEDURE flag_warning_vs
  END INTERFACE flagwarning

  INTERFACE outputseton
    MODULE PROCEDURE output_set_on
  END INTERFACE outputseton

  INTERFACE outputsetoff
    MODULE PROCEDURE output_set_off
  END INTERFACE outputsetoff

  INTERFACE randomseedsget
    MODULE PROCEDURE random_seeds_get
  END INTERFACE randomseedsget

  INTERFACE randomseedssizeget
    MODULE PROCEDURE random_seeds_size_get
  END INTERFACE randomseedssizeget

  INTERFACE randomseedsset
    MODULE PROCEDURE random_seeds_set
  END INTERFACE randomseedsset

  INTERFACE timingseton
    MODULE PROCEDURE timing_set_on
  END INTERFACE timingseton

  INTERFACE timingsetoff
    MODULE PROCEDURE timing_set_off
  END INTERFACE timingsetoff

  INTERFACE timingsummaryoutput
    MODULE PROCEDURE timing_summary_output
  END INTERFACE timingsummaryoutput

  INTERFACE write_error
    MODULE PROCEDURE writeerror
  END INTERFACE write_error

  INTERFACE writestr
    MODULE PROCEDURE write_str
  END INTERFACE writestr

  PUBLIC general_output_type,diagnostic_output_type,timing_output_type,error_output_type,help_output_type

  PUBLIC diagnostics1,diagnostics2,diagnostics3,diagnostics4,diagnostics5

  PUBLIC all_diag_type,in_diag_type,from_diag_type

  PUBLIC open_comfile_unit,start_read_comfile_unit,stop_read_comfile_unit,temporary_file_unit

  PUBLIC all_timing_type,in_timing_type,from_timing_type

  PUBLIC learn_file_unit,io1_file_unit,io2_file_unit,io3_file_unit,io4_file_unit,io5_file_unit

  PUBLIC cmiss_random_seeds
  
  PUBLIC op_string

  PUBLIC base_routines_finalise,base_routines_initialise

  PUBLIC baseroutinesfinalise,baseroutinesinitialise
  
  PUBLIC computational_node_numbers_set

  PUBLIC computationalnodenumbersset

  PUBLIC diagnostics_set_on,diagnostics_set_off

  PUBLIC diagnosticsseton,diagnosticssetoff

  PUBLIC enters,errors,exits

  PUBLIC extract_error_message

  PUBLIC extracterrormessage
  
  PUBLIC flag_error,flag_warning

  PUBLIC flagerror,flagwarning
  
  PUBLIC output_set_off,output_set_on

  PUBLIC outputseton,outputsetoff

  PUBLIC random_seeds_get,random_seeds_size_get,random_seeds_set

  PUBLIC randomseedsget,randomseedssizeget,randomseedsset

  PUBLIC timing_set_on,timing_set_off
  
  PUBLIC timingseton,timingsetoff
  
  PUBLIC timing_summary_output

  PUBLIC timingsummaryoutput
   
  PUBLIC write_error

  PUBLIC writeerror
  
  PUBLIC write_str

  PUBLIC writestr

CONTAINS

  !
  !================================================================================================================================
  !

  SUBROUTINE enters(NAME,ERR,ERROR,*)

    !Argument variables
    CHARACTER(LEN=*), INTENT(IN) :: NAME
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    CHARACTER(C_CHAR) :: CERROR(maxstrlen)
    REAL(DP) :: ENTERS_CPU_TIME,ENTERS_SYSTEM_TIME
    LOGICAL :: FINISHED
    TYPE(routine_list_item_type), POINTER :: LIST_ROUTINE_PTR
    TYPE(routine_stack_item_type), POINTER :: NEW_ROUTINE_PTR,ROUTINE_PTR

    IF(diag_or_timing) THEN
      !$OMP CRITICAL(ENTERS_1)
      ALLOCATE(new_routine_ptr,stat=err)
      IF(err/=0) CALL flagerror("Could not allocate new routine stack item.",err,error,*999)
      new_routine_ptr%DIAGNOSTICS=.false.
      new_routine_ptr%TIMING=.false.
      new_routine_ptr%NAME=name(1:len_trim(name))
      IF(ASSOCIATED(routine_stack%STACK_POINTER)) THEN
        new_routine_ptr%PREVIOUS_ROUTINE=>routine_stack%STACK_POINTER
        routine_stack%STACK_POINTER=>new_routine_ptr
      ELSE
        NULLIFY(new_routine_ptr%PREVIOUS_ROUTINE)
        routine_stack%STACK_POINTER=>new_routine_ptr
      ENDIF
      routine_ptr=>routine_stack%STACK_POINTER
      NULLIFY(routine_ptr%ROUTINE_LIST_ITEM)
      IF(diagnostics) THEN
        IF(diag_all_subroutines) THEN !turn diagnostics on in all subroutines
          routine_ptr%DIAGNOSTICS=.true.
        ELSE !diagnostics on in selected subroutines
          finished=.false.
          list_routine_ptr=>diag_routine_list%HEAD
          DO WHILE(ASSOCIATED(list_routine_ptr).AND..NOT.finished)
            IF(list_routine_ptr%NAME(1:len_trim(list_routine_ptr%NAME))== &
                & routine_ptr%NAME(1:len_trim(routine_ptr%NAME))) THEN
              routine_ptr%DIAGNOSTICS=.true.
              routine_ptr%ROUTINE_LIST_ITEM=>list_routine_ptr
              finished=.true.
            ELSE
              list_routine_ptr=>list_routine_ptr%NEXT_ROUTINE
            ENDIF
          ENDDO
          IF(diag_from_subroutine) THEN
            IF(ASSOCIATED(routine_ptr%PREVIOUS_ROUTINE)) THEN
              IF(routine_ptr%PREVIOUS_ROUTINE%DIAGNOSTICS) routine_ptr%DIAGNOSTICS=.true.
            ENDIF
          ENDIF
        ENDIF
        IF(routine_ptr%DIAGNOSTICS) THEN
          diagnostics1=diagnostics_level1
          diagnostics2=diagnostics_level2
          diagnostics3=diagnostics_level3
          diagnostics4=diagnostics_level4
          diagnostics5=diagnostics_level5
        ELSE
          diagnostics1=.false.
          diagnostics2=.false.
          diagnostics3=.false.
          diagnostics4=.false.
          diagnostics5=.false.
        ENDIF
        IF(routine_ptr%DIAGNOSTICS) THEN
          WRITE(op_string,'("*** Enters: ",A)') name(1:len_trim(name))
          CALL write_str(diagnostic_output_type,err,error,*999)
        ELSE IF(ASSOCIATED(routine_ptr%PREVIOUS_ROUTINE)) THEN
          !CPB 16/05/2007 Only show the calls if we have level 3 diagnostics or higher
          IF(diagnostics3) THEN
            IF(routine_ptr%PREVIOUS_ROUTINE%DIAGNOSTICS) THEN
              WRITE(op_string,'("*** Calls : ",A)') name(1:len_trim(name))
              CALL write_str(diagnostic_output_type,err,error,*999)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF(timing) THEN
        CALL cputimer(enters_cpu_time,1,err,cerror)
        CALL cputimer(enters_system_time,2,err,cerror)
        routine_ptr%INCLUSIVE_CPU_TIME=REAL(enters_cpu_time,sp)
        routine_ptr%INCLUSIVE_SYSTEM_TIME=REAL(enters_system_time,sp)
        routine_ptr%EXCLUSIVE_CPU_TIME=0.0_sp
        routine_ptr%EXCLUSIVE_SYSTEM_TIME=0.0_sp
        IF(timing_all_subroutines) THEN
          routine_ptr%TIMING=.true.
        ELSE
          finished=.false.
          list_routine_ptr=>timing_routine_list%HEAD
          DO WHILE(ASSOCIATED(list_routine_ptr).AND..NOT.finished)
            IF(list_routine_ptr%NAME(1:len_trim(list_routine_ptr%NAME))== &
                & routine_ptr%NAME(1:len_trim(routine_ptr%NAME))) THEN
              routine_ptr%TIMING=.true.
              routine_ptr%ROUTINE_LIST_ITEM=>list_routine_ptr
              finished=.true.
            ELSE
              list_routine_ptr=>list_routine_ptr%NEXT_ROUTINE
            ENDIF
          ENDDO
          IF(timing_from_subroutine) THEN
            IF(ASSOCIATED(routine_ptr%PREVIOUS_ROUTINE)) THEN
              IF(routine_ptr%PREVIOUS_ROUTINE%TIMING) routine_ptr%TIMING=.true.
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      !$OMP END CRITICAL(ENTERS_1)
    ENDIF

    RETURN
999 RETURN 1
  END SUBROUTINE enters

  !
  !================================================================================================================================
  !

  SUBROUTINE errors(NAME,ERR,ERROR)

    !Argument variables
    CHARACTER(LEN=*), INTENT(IN) :: NAME
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(INOUT) :: ERROR
    !Local variables
    TYPE(varying_string) :: LOCAL_ERROR
 
    IF(err==0) err=1
    !CPB 20/02/07 aix compiler does not like varying strings so split the concatenate statement up into two statements
    local_error=error//error_separator_constant
    error=local_error//name(1:len_trim(name))

    RETURN

  END SUBROUTINE errors

  !
  !================================================================================================================================
  !

  SUBROUTINE exits(NAME)

    !Argument variables
    CHARACTER(LEN=*), INTENT(IN) :: NAME
    !Local variables
    CHARACTER(C_CHAR) :: CERROR(maxstrlen)
    INTEGER(INTG) :: ERR
    REAL(DP) :: EXITS_CPU_TIME,EXITS_SYSTEM_TIME
    TYPE(varying_string) :: ERROR
    TYPE(routine_stack_item_type), POINTER :: PREVIOUS_ROUTINE_PTR,ROUTINE_PTR

    IF(diag_or_timing) THEN
      !$OMP CRITICAL(EXITS_1)
      routine_ptr=>routine_stack%STACK_POINTER
      IF(ASSOCIATED(routine_ptr)) THEN
        previous_routine_ptr=>routine_ptr%PREVIOUS_ROUTINE
        IF(diagnostics) THEN
          IF(routine_ptr%DIAGNOSTICS) THEN
            WRITE(op_string,'("*** Exits : ",A)') name(1:len_trim(name))
            CALL write_str(diagnostic_output_type,err,error,*999)
          ENDIF
          IF(ASSOCIATED(previous_routine_ptr)) THEN
            IF(previous_routine_ptr%DIAGNOSTICS) THEN
              diagnostics1=diagnostics_level1
              diagnostics2=diagnostics_level2
              diagnostics3=diagnostics_level3
              diagnostics4=diagnostics_level4
              diagnostics5=diagnostics_level5
            ELSE
              diagnostics1=.false.
              diagnostics2=.false.
              diagnostics3=.false.
              diagnostics4=.false.
              diagnostics5=.false.
            ENDIF
          ENDIF
        ENDIF

        IF(timing) THEN
          CALL cputimer(exits_cpu_time,1,err,cerror)
          CALL cputimer(exits_system_time,2,err,cerror)
          routine_ptr%INCLUSIVE_CPU_TIME=abs(REAL(exits_cpu_time,sp)-ROUTINE_PTR%INCLUSIVE_CPU_TIME)
          routine_ptr%INCLUSIVE_SYSTEM_TIME=abs(REAL(exits_system_time,sp)-ROUTINE_PTR%INCLUSIVE_SYSTEM_TIME)
          IF(ASSOCIATED(previous_routine_ptr)) THEN
            previous_routine_ptr%EXCLUSIVE_CPU_TIME=previous_routine_ptr%EXCLUSIVE_CPU_TIME+routine_ptr%INCLUSIVE_CPU_TIME
            previous_routine_ptr%EXCLUSIVE_SYSTEM_TIME=previous_routine_ptr%EXCLUSIVE_SYSTEM_TIME+routine_ptr%INCLUSIVE_SYSTEM_TIME
          ENDIF
          IF(ASSOCIATED(routine_ptr%ROUTINE_LIST_ITEM)) THEN
            routine_ptr%ROUTINE_LIST_ITEM%NUMBER_OF_INVOCATIONS=routine_ptr%ROUTINE_LIST_ITEM%NUMBER_OF_INVOCATIONS+1
            routine_ptr%ROUTINE_LIST_ITEM%TOTAL_INCLUSIVE_CPU_TIME=routine_ptr%ROUTINE_LIST_ITEM%TOTAL_INCLUSIVE_CPU_TIME+ &
              & routine_ptr%INCLUSIVE_CPU_TIME
            routine_ptr%ROUTINE_LIST_ITEM%TOTAL_INCLUSIVE_SYSTEM_TIME=routine_ptr%ROUTINE_LIST_ITEM%TOTAL_INCLUSIVE_SYSTEM_TIME+ &
              & routine_ptr%INCLUSIVE_SYSTEM_TIME
            IF(ASSOCIATED(previous_routine_ptr)) THEN
              IF(ASSOCIATED(previous_routine_ptr%ROUTINE_LIST_ITEM)) THEN
                previous_routine_ptr%ROUTINE_LIST_ITEM%TOTAL_EXCLUSIVE_CPU_TIME=previous_routine_ptr%ROUTINE_LIST_ITEM% &
                  & total_exclusive_cpu_time+previous_routine_ptr%EXCLUSIVE_CPU_TIME
                previous_routine_ptr%ROUTINE_LIST_ITEM%TOTAL_EXCLUSIVE_SYSTEM_TIME=previous_routine_ptr%ROUTINE_LIST_ITEM% &
                  & total_exclusive_system_time+previous_routine_ptr%EXCLUSIVE_SYSTEM_TIME
              ENDIF
            ENDIF
          ENDIF
          IF(routine_ptr%TIMING) THEN
            IF(.NOT.timing_summary) THEN
              WRITE(op_string,'("*** Timing : ",A)') name(1:len_trim(name))
              CALL write_str(timing_output_type,err,error,*999)
              IF(ASSOCIATED(routine_ptr%ROUTINE_LIST_ITEM)) THEN
                WRITE(op_string,'("***    Number of invocations: ",I10)') routine_ptr%ROUTINE_LIST_ITEM%NUMBER_OF_INVOCATIONS
                CALL write_str(timing_output_type,err,error,*999)
                WRITE(op_string,'("***    Routine times:  Call Inclusive   Call Exclusive   Total Inclusive   Average Inclusive")')
                CALL write_str(timing_output_type,err,error,*999)
                WRITE(op_string,'("***    CPU       (s):  ",E14.6,"   ",E14.6,"   ",E15.6,"   ",E17.6)')  &
                  & routine_ptr%INCLUSIVE_CPU_TIME,routine_ptr%INCLUSIVE_CPU_TIME-routine_ptr%EXCLUSIVE_CPU_TIME, &
                  & routine_ptr%ROUTINE_LIST_ITEM%TOTAL_INCLUSIVE_CPU_TIME,routine_ptr%ROUTINE_LIST_ITEM% &
                  & total_inclusive_cpu_time/REAL(routine_ptr%routine_list_item%number_of_invocations,sp)
                CALL write_str(timing_output_type,err,error,*999)
                WRITE(op_string,'("***    System    (s):  ",E14.6,"   ",E14.6,"   ",E15.6,"   ",E17.6)')  &
                  & routine_ptr%INCLUSIVE_SYSTEM_TIME,routine_ptr%INCLUSIVE_SYSTEM_TIME-routine_ptr%EXCLUSIVE_SYSTEM_TIME, &
                  & routine_ptr%ROUTINE_LIST_ITEM%TOTAL_INCLUSIVE_SYSTEM_TIME,routine_ptr%ROUTINE_LIST_ITEM% &
                  & total_inclusive_system_time/REAL(routine_ptr%routine_list_item%number_of_invocations,sp)
                CALL write_str(timing_output_type,err,error,*999)
              ELSE
                WRITE(op_string,'("***    Routine times:  Call Inclusive   Call Exclusive")')
                CALL write_str(timing_output_type,err,error,*999)
                WRITE(op_string,'("***    CPU       (s):  ",E14.6,"   ",E14.6)')  &
                  & routine_ptr%INCLUSIVE_CPU_TIME,routine_ptr%INCLUSIVE_CPU_TIME-routine_ptr%EXCLUSIVE_CPU_TIME
                CALL write_str(timing_output_type,err,error,*999)
                WRITE(op_string,'("***    System    (s):  ",E14.6,"   ",E14.6)')  &
                  & routine_ptr%INCLUSIVE_SYSTEM_TIME,routine_ptr%INCLUSIVE_SYSTEM_TIME-routine_ptr%EXCLUSIVE_SYSTEM_TIME
                CALL write_str(timing_output_type,err,error,*999)
              ENDIF
            ENDIF
          ENDIF
        ENDIF

        IF(ASSOCIATED(previous_routine_ptr)) THEN
          routine_stack%STACK_POINTER=>previous_routine_ptr
        ELSE
          NULLIFY(routine_stack%STACK_POINTER)
        ENDIF

        !Delete the routine pointer
        DEALLOCATE(routine_ptr)

        !ELSE ERROR????
      ENDIF
      !$OMP END CRITICAL(EXITS_1)
    ENDIF

999 RETURN
  END SUBROUTINE exits

  !
  !================================================================================================================================
  !

#include "macros.h"

  SUBROUTINE computational_node_numbers_set(MY_NODE_NUMBER,NUMBER_OF_NODES,ERR,ERROR,*)

    !Argument variables
    INTEGER(INTG), INTENT(IN) :: MY_NODE_NUMBER
    INTEGER(INTG), INTENT(IN) :: NUMBER_OF_NODES
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables

    enters("COMPUTATIONAL_NODE_NUMBERS_SET",err,error,*999)

    IF(number_of_nodes>0) THEN
      IF(my_node_number>=0.AND.my_node_number<=number_of_nodes-1) THEN        
        my_computational_node_number=my_node_number
        number_of_computational_nodes=number_of_nodes        
      ELSE
        CALL flagerror("Invalid node number.",err,error,*999)
      ENDIF
    ELSE
       CALL flagerror("Invalid number of nodes.",err,error,*999)
    ENDIF
    
    exits("COMPUTATIONAL_NODE_NUMBERS_SET")
    RETURN 
999 errorsexits("COMPUTATIONAL_NODE_NUMBERS_SET",err,error)
    RETURN 1
  END SUBROUTINE computational_node_numbers_set

  !
  !================================================================================================================================
  !

  SUBROUTINE extract_error_message_vs(ERROR_MESSAGE,ERR,ERROR,*)

    !Argument variables
    TYPE(varying_string), INTENT(OUT) :: ERROR_MESSAGE
    INTEGER(INTG), INTENT(IN) :: ERR
    TYPE(varying_string), INTENT(IN) :: ERROR
    !Local Variables
    INTEGER(INTG) :: POSITION

    position=index(error,error_separator_constant)
    error_message=extract(error,1,position-1)

    RETURN
  END SUBROUTINE extract_error_message_vs

  !
  !================================================================================================================================
  !

  SUBROUTINE extract_error_message_c(ERROR_MESSAGE,ERR,ERROR,*)

    !Argument variables
    CHARACTER(LEN=*), INTENT(OUT) :: ERROR_MESSAGE
    INTEGER(INTG), INTENT(IN) :: ERR
    TYPE(varying_string), INTENT(IN) :: ERROR
    !Local Variables
    INTEGER(INTG) :: POSITION

    position=index(error,error_separator_constant)
    error_message=extract(error,1,position-1)

    RETURN
  END SUBROUTINE extract_error_message_c

  !
  !================================================================================================================================
  !

  SUBROUTINE flag_error_c(STRING,ERR,ERROR,*)

    !Argument variables
    CHARACTER(LEN=*), INTENT(IN) :: STRING
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    INTEGER(INTG) :: STRING_LENGTH

    IF(err==0) err=1
    string_length=len_trim(string)
    error=string(1:string_length)

    RETURN 1
  END SUBROUTINE flag_error_c

  !
  !================================================================================================================================
  !

  SUBROUTINE flag_error_vs(STRING,ERR,ERROR,*)

    !Argument variables
    TYPE(varying_string), INTENT(IN) :: STRING
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables

    IF(err==0) err=1
    error=string

    RETURN 1
  END SUBROUTINE flag_error_vs

  !
  !================================================================================================================================
  !

  SUBROUTINE flag_warning_c(STRING,ERR,ERROR,*)

    !Argument variables
    CHARACTER(LEN=*), INTENT(IN) :: STRING
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables

    IF(number_of_computational_nodes>1) THEN
      WRITE(op_string,'(">>WARNING (",I0,"): ",A)') my_computational_node_number,string
    ELSE
      WRITE(op_string,'(">>WARNING: ",A)') string
    ENDIF
    CALL write_str(warning_output_type,err,error,*999)

    RETURN 
999 errors("FLAG_WARNING_C",err,error)
    RETURN 1
    
  END SUBROUTINE flag_warning_c

  !
  !================================================================================================================================
  !

  SUBROUTINE flag_warning_vs(STRING,ERR,ERROR,*)

    !Argument variables
    TYPE(varying_string), INTENT(IN) :: STRING
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables

    IF(number_of_computational_nodes>1) THEN
      WRITE(op_string,'(">>WARNING (",I0,"): ",A)') my_computational_node_number,char(string)
    ELSE
      WRITE(op_string,'(">>WARNING: ",A)') char(string)
    ENDIF
    CALL write_str(warning_output_type,err,error,*999)

    RETURN 
999 errors("FLAG_WARNING_VS",err,error)
    RETURN 1
    
  END SUBROUTINE flag_warning_vs

  !
  !================================================================================================================================
  !

  SUBROUTINE base_routines_finalise(ERR,ERROR,*)

    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables

    err=0
    error=""
    !Deallocate the random seeds
    IF(ALLOCATED(cmiss_random_seeds)) DEALLOCATE(cmiss_random_seeds)
    
    RETURN 
999 RETURN 1
  END SUBROUTINE base_routines_finalise

  !
  !================================================================================================================================
  !

  SUBROUTINE base_routines_initialise(ERR,ERROR,*)
    
    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    INTEGER(INTG) :: i,j,RANDOM_SEEDS_SIZE,TIME(8)

    err=0
    error=""
    my_computational_node_number=0
    number_of_computational_nodes=1
    diagnostics=.false.
    diagnostics1=.false.
    diagnostics2=.false.
    diagnostics3=.false.
    diagnostics4=.false.
    diagnostics5=.false.
    diagnostics_level1=.false.
    diagnostics_level2=.false.
    diagnostics_level3=.false.
    diagnostics_level4=.false.
    diagnostics_level5=.false.
    diag_all_subroutines=.true.
    diag_from_subroutine=.false.
    diag_file_open=.false.
    diag_or_timing=.false.
    echo_output=.false.
    timing=.false.
    timing_summary=.false.
    timing_all_subroutines=.true.
    timing_from_subroutine=.false.
    timing_file_open=.false.
    !Initialise loose tolerance here rather than in constants.f90
    loose_tolerance=sqrt(epsilon(1.0_dp))
    loose_tolerance_sp=sqrt(epsilon(1.0_sp))
    !Setup the random seeds based on the time
    CALL random_seed(size=random_seeds_size)
    ALLOCATE(cmiss_random_seeds(random_seeds_size),stat=err)
    IF(err/=0) CALL flagerror("Could not allocate random seeds.",err,error,*999)
    cmiss_random_seeds(1:random_seeds_size)=[(i,i=1,random_seeds_size)]
    CALL date_and_time(values=time)
    cmiss_random_seeds(1)=3600000*time(5)+60000*time(6)+1000*time(7)+time(8)
    CALL random_seed(put=cmiss_random_seeds)

    !Initialise OP_STRING
    SELECT CASE(machine_os)
    CASE(vms_os)
      DO i=1,max_output_lines
        op_string(i)(1:1)=char(0)
      ENDDO !i
    CASE(irix_os,linux_os,aix_os)
      DO i=1,max_output_lines
        DO j=1,maxstrlen
          op_string(i)(j:j)=' '
        ENDDO !j
      ENDDO !i
    CASE(windows_os)
      DO i=1,max_output_lines
        op_string(i)(1:1)=char(0)
      ENDDO !i
    CASE DEFAULT
      CALL flagerror("Operating system not implemented.",err,error,*999)
    END SELECT

    !Initialise diagnostics and tracing
    NULLIFY(routine_stack%STACK_POINTER)
    NULLIFY(diag_routine_list%HEAD)
    NULLIFY(timing_routine_list%HEAD)

    RETURN 
999 RETURN 1
  END SUBROUTINE base_routines_initialise

  !
  !================================================================================================================================
  !

  SUBROUTINE diagnostics_set_off(ERR,ERROR,*)

    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    TYPE(routine_list_item_type), POINTER :: NEXT_ROUTINE,ROUTINE

    enters("DIAGNOSTICS_SET_OFF",err,error,*999)

    IF(diagnostics) THEN
      IF(diag_file_open) THEN
        diag_file_open=.false.
        CLOSE(unit=diagnostics_file_unit)
      ENDIF
      IF(diag_all_subroutines) THEN
        diag_all_subroutines=.false.
      ELSE
        routine=>diag_routine_list%HEAD
        DO WHILE(ASSOCIATED(routine))
          next_routine=>routine%NEXT_ROUTINE
          DEALLOCATE(routine)
          routine=>next_routine
        ENDDO
        NULLIFY(diag_routine_list%HEAD)
        diag_from_subroutine=.false.
      ENDIF
      diagnostics_level1=.false.
      diagnostics_level2=.false.
      diagnostics_level3=.false.
      diagnostics_level4=.false.
      diagnostics_level5=.false.
      diagnostics1=.false.
      diagnostics2=.false.
      diagnostics3=.false.
      diagnostics4=.false.
      diagnostics5=.false.
      diagnostics=.false.
      diag_or_timing=timing
    ELSE
      CALL flagerror("Diagnositics is not on.",err,error,*999)
    ENDIF

    exits("DIAGNOSTICS_SET_OFF")
    RETURN
999 errorsexits("DIAGNOSTICS_SET_OFF",err,error)
    RETURN 1
  END SUBROUTINE diagnostics_set_off

  !
  !================================================================================================================================
  !

  SUBROUTINE diagnostics_set_on(DIAG_TYPE,LEVEL_LIST,DIAG_FILENAME,ROUTINE_LIST,ERR,ERROR,*)

    !Argument variables
    INTEGER(INTG), INTENT(IN) :: DIAG_TYPE
    INTEGER(INTG), INTENT(IN) :: LEVEL_LIST(:)
    CHARACTER(LEN=*), INTENT(IN) :: DIAG_FILENAME
    CHARACTER(LEN=*), INTENT(IN) :: ROUTINE_LIST(:)
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    INTEGER(INTG) :: i,LEVEL
    CHARACTER(LEN=MAXSTRLEN) :: FILENAME
    TYPE(routine_list_item_type), POINTER :: NEXT_ROUTINE,PREVIOUS_ROUTINE,ROUTINE
 
    NULLIFY(routine)
    
    enters("DIAGNOSTICS_SET_ON",err,error,*999)

    IF(len_trim(diag_filename)>=1) THEN
      IF(diag_file_open) CLOSE(unit=diagnostics_file_unit)
      IF(number_of_computational_nodes>1) THEN
        WRITE(filename,'(A,".diag.",I0)') diag_filename(1:len_trim(diag_filename)),my_computational_node_number
      ELSE
        filename=diag_filename(1:len_trim(diag_filename))//".diag"
      ENDIF
      OPEN(unit=diagnostics_file_unit,file=filename(1:len_trim(filename)),status="UNKNOWN",iostat=err)
      IF(err/=0) CALL flagerror("Could not open diagnostics file.",err,error,*999)
      diag_file_open=.true.
    ENDIF
    SELECT CASE(diag_type)
    CASE(all_diag_type)
      diag_all_subroutines=.true.
    CASE(in_diag_type,from_diag_type)
      diag_all_subroutines=.false.
      diag_from_subroutine=diag_type==from_diag_type
      IF(ASSOCIATED(diag_routine_list%HEAD)) THEN
        routine=>diag_routine_list%HEAD
        DO WHILE(ASSOCIATED(routine))
          next_routine=>routine%NEXT_ROUTINE
          DEALLOCATE(routine)
          routine=>next_routine
        ENDDO
        NULLIFY(diag_routine_list%HEAD)
      ENDIF
      ALLOCATE(routine,stat=err)
      IF(err/=0) CALL flagerror("Could not allocate routine list item.",err,error,*999)
      routine%NAME=routine_list(1)
      previous_routine=>routine
      NULLIFY(routine%NEXT_ROUTINE)
      diag_routine_list%HEAD=>routine
      DO i=2,SIZE(routine_list,1)
        ALLOCATE(routine,stat=err)
        IF(err/=0) CALL flagerror("Could not allocate routine list item.",err,error,*999)
        routine%NAME=routine_list(i)
        NULLIFY(routine%NEXT_ROUTINE)
        previous_routine%NEXT_ROUTINE=>routine
        previous_routine=>routine
      ENDDO !i
    CASE DEFAULT
      CALL flagerror("Invalid diagnostic type.",err,error,*999)
    END SELECT
    DO i=1,SIZE(level_list,1)
      level=level_list(i)
      SELECT CASE(level)
      CASE(1)
        diagnostics_level1=.true.
      CASE(2)
        diagnostics_level2=.true.
      CASE(3)
        diagnostics_level3=.true.
      CASE(4)
        diagnostics_level4=.true.
      CASE(5)
        diagnostics_level5=.true.
      CASE DEFAULT
        CALL flagerror("Invalid diagnostic level.",err,error,*999)
      END SELECT
    ENDDO !i
    diagnostics=.true.
    diag_or_timing=.true.

    exits("DIAGNOSTICS_SET_ON")
    RETURN
999 IF(diag_file_open) THEN
      CLOSE(unit=diagnostics_file_unit)
      diag_file_open=.false.
    ENDIF
    routine=>diag_routine_list%HEAD
    DO WHILE(ASSOCIATED(routine))
      next_routine=>routine%NEXT_ROUTINE
      DEALLOCATE(routine)
      routine=>next_routine
    ENDDO
    NULLIFY(diag_routine_list%HEAD)
    diag_all_subroutines=.false.
    diag_from_subroutine=.false.
    diagnostics_level1=.false.
    diagnostics_level2=.false.
    diagnostics_level3=.false.
    diagnostics_level4=.false.
    diagnostics_level5=.false.
    diagnostics=.false.
    diag_or_timing=timing
    errorsexits("DIAGNOSTICS_SET_ON",err,error)
    RETURN 1
  END SUBROUTINE diagnostics_set_on

  !
  !================================================================================================================================
  !

  SUBROUTINE output_set_off(ERR,ERROR,*)

    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables

    enters("OUTPUT_SET_OFF",err,error,*999)

    IF(echo_output) THEN
      echo_output=.false.
      CLOSE(unit=echo_file_unit)
    ELSE
      CALL flagerror("Write output is not on.",err,error,*999)
    ENDIF

    exits("OUTPUT_SET_OFF")
    RETURN
999 errorsexits("OUTPUT_SET_OFF",err,error)
    RETURN 1
  END SUBROUTINE output_set_off

  !
  !================================================================================================================================
  !

  SUBROUTINE output_set_on(ECHO_FILENAME,ERR,ERROR,*)

    !Argument variables
    CHARACTER(LEN=*), INTENT(IN) :: ECHO_FILENAME
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    CHARACTER(LEN=MAXSTRLEN) :: FILENAME

    enters("OUTPUT_SET_ON",err,error,*999)

    IF(echo_output) THEN
      CALL flagerror("Write output is already on.",err,error,*999)
    ELSE
      IF(number_of_computational_nodes>1) THEN
        WRITE(filename,'(A,".out.",I0)') echo_filename(1:len_trim(echo_filename)),my_computational_node_number        
      ELSE
        filename=echo_filename(1:len_trim(echo_filename))//".out"
      ENDIF
      OPEN(unit=echo_file_unit,file=filename(1:len_trim(filename)),status="UNKNOWN",iostat=err)
      IF(err/=0) CALL flagerror("Could not open write output file.",err,error,*999)
      echo_output=.true.
    ENDIF

    exits("OUTPUT_SET_ON")
    RETURN
999 errorsexits("OUTPUT_SET_ON",err,error)
    RETURN 1
  END SUBROUTINE output_set_on

  !
  !================================================================================================================================
  !

  SUBROUTINE random_seeds_get(RANDOM_SEEDS,ERR,ERROR,*)
  
    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: RANDOM_SEEDS(:)
    INTEGER(INTG), INTENT(INOUT) :: ERR
    TYPE(varying_string), INTENT(INOUT) :: ERROR
    !Local Variables
    CHARACTER(LEN=MAXSTRLEN) :: LOCAL_ERROR
    
    enters("RANDOM_SEEDS_GET",err,error,*999)

    IF(SIZE(random_seeds,1)>=SIZE(cmiss_random_seeds,1)) THEN
      random_seeds(1:SIZE(cmiss_random_seeds,1))=cmiss_random_seeds(1:SIZE(cmiss_random_seeds,1))
    ELSE
      WRITE(local_error,'("The size of the supplied random seeds array of ",I2," is too small. The size must be >= ",I2,".")') &
        & SIZE(random_seeds,1),SIZE(cmiss_random_seeds,1)
      CALL flagerror(local_error,err,error,*999)
    ENDIF
    
    exits("RANDOM_SEED_GET")
    RETURN
999 errorsexits("RANDOM_SEEDS_GET",err,error)
    RETURN 1
  END SUBROUTINE random_seeds_get

  !
  !================================================================================================================================
  !

  SUBROUTINE random_seeds_size_get(RANDOM_SEEDS_SIZE,ERR,ERROR,*)
  
    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: RANDOM_SEEDS_SIZE
    INTEGER(INTG), INTENT(INOUT) :: ERR
    TYPE(varying_string), INTENT(INOUT) :: ERROR
    !Local Variables

    enters("RANDOM_SEEDS_SIZE_GET",err,error,*999)

    random_seeds_size=SIZE(cmiss_random_seeds,1)
    
    exits("RANDOM_SEED_SIZE_GET")
    RETURN
999 errorsexits("RANDOM_SEEDS_SIZE_GET",err,error)
    RETURN 1
  END SUBROUTINE random_seeds_size_get

  !
  !================================================================================================================================
  !

  SUBROUTINE random_seeds_set(RANDOM_SEEDS,ERR,ERROR,*)
  
    !Argument variables
    INTEGER(INTG), INTENT(IN) :: RANDOM_SEEDS(:)
    INTEGER(INTG), INTENT(INOUT) :: ERR
    TYPE(varying_string), INTENT(INOUT) :: ERROR
    !Local Variables
    
    enters("RANDOM_SEEDS_SET",err,error,*999)

    IF(SIZE(random_seeds,1)>SIZE(cmiss_random_seeds,1)) THEN
      cmiss_random_seeds(1:SIZE(cmiss_random_seeds,1))=random_seeds(1:SIZE(cmiss_random_seeds,1))
    ELSE
      cmiss_random_seeds(1:SIZE(random_seeds,1))=random_seeds(1:SIZE(random_seeds,1))
    ENDIF

    exits("RANDOM_SEEDS_SET")
    RETURN
999 errorsexits("RANDOM_SEEDS_SET",err,error)
    RETURN 1
  END SUBROUTINE random_seeds_set

  !
  !================================================================================================================================
  !

  SUBROUTINE timing_set_off(ERR,ERROR,*)

   !Argument variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    TYPE(routine_list_item_type), POINTER :: NEXT_ROUTINE,ROUTINE

    enters("TIMING_SET_OFF",err,error,*999)

    IF(timing) THEN
      IF(timing_file_open) THEN
        timing_file_open=.false.
        CLOSE(unit=timing_file_unit)
      ENDIF
      IF(timing_all_subroutines) THEN
        timing_all_subroutines=.false.
      ELSE
        routine=>timing_routine_list%HEAD
        DO WHILE(ASSOCIATED(routine))
          next_routine=>routine%NEXT_ROUTINE
          DEALLOCATE(routine)
          routine=>next_routine
        ENDDO
        NULLIFY(timing_routine_list%HEAD)
        timing_from_subroutine=.false.
      ENDIF
      timing_summary=.false.
      timing=.false.
      diag_or_timing=diagnostics
    ELSE
      CALL flagerror("Timing is not on.",err,error,*999)
    ENDIF

    exits("TIMING_SET_OFF")
    RETURN
999 errorsexits("TIMING_SET_OFF",err,error)
    RETURN 1
  END SUBROUTINE timing_set_off

  !
  !================================================================================================================================
  !

  SUBROUTINE timing_set_on(TIMING_TYPE,TIMING_SUMMARY_FLAG,TIMING_FILENAME,ROUTINE_LIST,ERR,ERROR,*)

    !Argument variables
    INTEGER(INTG), INTENT(IN) :: TIMING_TYPE
    LOGICAL, INTENT(IN) :: TIMING_SUMMARY_FLAG
    CHARACTER(LEN=*), INTENT(IN) :: TIMING_FILENAME
    CHARACTER(LEN=*), INTENT(IN) :: ROUTINE_LIST(:)
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    INTEGER(INTG) :: i
    CHARACTER(LEN=MAXSTRLEN) :: FILENAME
    TYPE(routine_list_item_type), POINTER :: NEXT_ROUTINE,PREVIOUS_ROUTINE,ROUTINE
 
    enters("TIMING_SET_ON",err,error,*999)

    NULLIFY(routine)
    IF(len_trim(timing_filename)>=1) THEN
      IF(timing_file_open) CLOSE(unit=timing_file_unit)
      IF(number_of_computational_nodes>1) THEN
        WRITE(filename,'(A,".timing.",I0)') timing_filename(1:len_trim(timing_filename)),my_computational_node_number
      ELSE
        filename=timing_filename(1:len_trim(timing_filename))//".timing"
      ENDIF
      OPEN(unit=timing_file_unit,file=filename(1:len_trim(filename)),status="UNKNOWN",iostat=err)
      IF(err/=0) CALL flagerror("Could not open timing file.",err,error,*999)
      timing_file_open=.true.
    ENDIF
    SELECT CASE(timing_type)
    CASE(all_timing_type)
      timing_all_subroutines=.true.
    CASE(in_timing_type,from_timing_type)
      timing_all_subroutines=.false.
      timing_from_subroutine=timing_type==from_timing_type
      IF(ASSOCIATED(timing_routine_list%HEAD)) THEN
        routine=>timing_routine_list%HEAD
        DO WHILE(ASSOCIATED(routine))
          next_routine=>routine%NEXT_ROUTINE
          DEALLOCATE(routine)
          routine=>next_routine
        ENDDO
        NULLIFY(timing_routine_list%HEAD)
      ENDIF
      ALLOCATE(routine,stat=err)
      IF(err/=0) CALL flagerror("Could not allocate routine list item.",err,error,*999)
      routine%NAME=routine_list(1)
      previous_routine=>routine
      NULLIFY(routine%NEXT_ROUTINE)
      timing_routine_list%HEAD=>routine
      routine%NUMBER_OF_INVOCATIONS=0
      routine%TOTAL_INCLUSIVE_CPU_TIME=0.0_sp
      routine%TOTAL_INCLUSIVE_SYSTEM_TIME=0.0_sp
      routine%TOTAL_EXCLUSIVE_CPU_TIME=0.0_sp
      routine%TOTAL_EXCLUSIVE_SYSTEM_TIME=0.0_sp
      DO i=2,SIZE(routine_list,1)
        ALLOCATE(routine,stat=err)
        IF(err/=0) CALL flagerror("Could not allocate routine list item.",err,error,*999)
        routine%NAME=routine_list(i)
        NULLIFY(routine%NEXT_ROUTINE)
        previous_routine%NEXT_ROUTINE=>routine
        previous_routine=>routine
        routine%NUMBER_OF_INVOCATIONS=0
        routine%TOTAL_INCLUSIVE_CPU_TIME=0.0_sp
        routine%TOTAL_INCLUSIVE_CPU_TIME=0.0_sp
        routine%TOTAL_EXCLUSIVE_CPU_TIME=0.0_sp
        routine%TOTAL_EXCLUSIVE_CPU_TIME=0.0_sp
      ENDDO !i
    CASE DEFAULT
      CALL flagerror("Invalid timing type.",err,error,*999)
    END SELECT
    timing_summary=timing_summary_flag
    timing=.true.
    diag_or_timing=.true.

    exits("TIMING_SET_ON")
    RETURN
999 IF(timing_file_open) THEN
      CLOSE(unit=timing_file_unit)
      timing_file_open=.false.
    ENDIF
    routine=>timing_routine_list%HEAD
    DO WHILE(ASSOCIATED(routine))
      next_routine=>routine%NEXT_ROUTINE
      DEALLOCATE(routine)
      routine=>next_routine
    ENDDO
    NULLIFY(timing_routine_list%HEAD)
    timing_all_subroutines=.false.
    timing_from_subroutine=.false.
    timing=.false.
    diag_or_timing=diagnostics
    errorsexits("TIMING_SET_ON",err,error)
    RETURN 1
  END SUBROUTINE timing_set_on

  !
  !================================================================================================================================
  !

  SUBROUTINE timing_summary_output(ERR,ERROR,*)    

    !Argument variables
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local variables
    TYPE(routine_list_item_type), POINTER :: ROUTINE_PTR

    NULLIFY(routine_ptr)
    
    enters("TIMING_SUMMARY_OUTPUT",err,error,*999)

    IF(timing) THEN
      WRITE(op_string,'("*** Timing Summary: ")') 
      CALL write_str(timing_output_type,err,error,*999)
      routine_ptr=>timing_routine_list%HEAD
      DO WHILE(ASSOCIATED(routine_ptr))
        WRITE(op_string,'("*** Routine : ",A)') trim(routine_ptr%NAME)
        CALL write_str(timing_output_type,err,error,*999)
        WRITE(op_string,'("***    Number of invocations: ",I10)') routine_ptr%NUMBER_OF_INVOCATIONS
        CALL write_str(timing_output_type,err,error,*999)
        WRITE(op_string,'("***    Routine times: Total Exclusive  Total Inclusive  Average Exclusive  Average Inclusive")')
        CALL write_str(timing_output_type,err,error,*999)
        IF(routine_ptr%NUMBER_OF_INVOCATIONS==0) THEN
          WRITE(op_string,'("***    CPU       (s):  ",E14.6,"   ",E14.6,"     ",E14.6,"     ",E14.6)')  &
            & routine_ptr%TOTAL_EXCLUSIVE_CPU_TIME,routine_ptr%TOTAL_INCLUSIVE_CPU_TIME, &
            & REAL(ROUTINE_PTR%NUMBER_OF_INVOCATIONS,SP),REAL(routine_ptr%number_of_invocations,sp)
          CALL write_str(timing_output_type,err,error,*999)
          WRITE(op_string,'("***    System    (s):  ",E14.6,"   ",E14.6,"     ",E14.6,"     ",E14.6)')  &
            & routine_ptr%TOTAL_EXCLUSIVE_SYSTEM_TIME,routine_ptr%TOTAL_INCLUSIVE_SYSTEM_TIME, &
            & REAL(ROUTINE_PTR%NUMBER_OF_INVOCATIONS,SP),REAL(routine_ptr%number_of_invocations,sp)
          CALL write_str(timing_output_type,err,error,*999)
        ELSE
          WRITE(op_string,'("***    CPU       (s):  ",E14.6,"   ",E14.6,"     ",E14.6,"     ",E14.6)')  &
            & routine_ptr%TOTAL_EXCLUSIVE_CPU_TIME,routine_ptr%TOTAL_INCLUSIVE_CPU_TIME, &
            & routine_ptr%TOTAL_EXCLUSIVE_CPU_TIME/REAL(ROUTINE_PTR%NUMBER_OF_INVOCATIONS,SP), &
            & ROUTINE_PTR%TOTAL_INCLUSIVE_CPU_TIME/REAL(ROUTINE_PTR%NUMBER_OF_INVOCATIONS,SP)
          CALL WRITE_STR(timing_output_type,err,error,*999)
          WRITE(op_string,'("***    System    (s):  ",E14.6,"   ",E14.6,"     ",E14.6,"     ",E14.6)')  &
            & routine_ptr%TOTAL_EXCLUSIVE_SYSTEM_TIME,routine_ptr%TOTAL_INCLUSIVE_SYSTEM_TIME, &
            & routine_ptr%TOTAL_EXCLUSIVE_SYSTEM_TIME/REAL(ROUTINE_PTR%NUMBER_OF_INVOCATIONS,SP), &
            & ROUTINE_PTR%TOTAL_INCLUSIVE_SYSTEM_TIME/REAL(ROUTINE_PTR%NUMBER_OF_INVOCATIONS,SP)
          CALL WRITE_STR(timing_output_type,err,error,*999)
        ENDIF
        routine_ptr=>routine_ptr%NEXT_ROUTINE
      ENDDO
    ELSE
      CALL flagerror("Timing is not on.",err,error,*999)
    ENDIF

    exits("TIMING_SUMMARY_OUTPUT")
    RETURN
999 errorsexits("TIMING_SUMMARY_OUTPUT",err,error)
    RETURN 1
  END SUBROUTINE timing_summary_output

 !
  !================================================================================================================================
  !

  SUBROUTINE writeerror(err,error,*)
  
    !Argument variables
    INTEGER(INTG), INTENT(INOUT) :: err
    TYPE(varying_string), INTENT(INOUT) :: error
    !Local Variables
    INTEGER(INTG) :: endPosition,errorStringLength,indent,lastSpacePosition,localErr,position,startStringLength
    CHARACTER(LEN=MAXSTRLEN) :: indentString=">>"
    CHARACTER(LEN=MAXSTRLEN) :: startString
    TYPE(varying_string) :: localError,localError2

    indent=2
    IF(number_of_computational_nodes>1) THEN
      WRITE(startstring,'(A,A,I0,A,X,I0,A)') indentstring(1:indent),"ERROR (",my_computational_node_number,"):", &
        & err,":"
      startstringlength=len_trim(startstring)
    ELSE
      WRITE(startstring,'(A,A,X,I0,A)') indentstring(1:indent),"ERROR: ",err,":"
      startstringlength=len_trim(startstring)
    ENDIF
    position=index(error,error_separator_constant)
    errorstringlength=position-1
    localerror=extract(error,1,errorstringlength)
    DO WHILE(errorstringlength+startstringlength+1>max_output_width)
      endPosition=MAX_OUTPUT_WIDTH-startStringLength-1
      lastspaceposition=index(extract(localerror,1,endposition)," ",back=.true.)
      IF(lastspaceposition/=0) endposition=lastspaceposition-1
      WRITE(op_string,'(A,X,A)') startstring(1:startstringlength),char(extract(localerror,1,endposition))
      CALL write_str(error_output_type,localerr,localerror2,*999)
      localerror=adjustl(extract(localerror,endposition+1,len_trim(localerror)))
      errorstringlength=len_trim(localerror)
      startstring=" "
    ENDDO !not finished
    WRITE(op_string,'(A,X,A)') startstring(1:startstringlength),char(localerror)
    CALL write_str(error_output_type,localerr,localerror2,*999)
    !CPB 20/02/07 aix compiler does not like varying strings so split the remove statement up into two statements
    localerror=remove(error,1,position)
    error=localerror
    position=index(error,error_separator_constant)
    indent=indent+2
    DO WHILE(position/=0)
      WRITE(op_string,'(A)') indentstring(1:indent)//char(extract(error,1,position-1))
      CALL write_str(error_output_type,localerr,localerror2,*999)
      !CPB 20/02/07 aix compiler does not like varying strings so split the remove statement up into two statements
      localerror=remove(error,1,position)
      error=localerror
      position=index(error,error_separator_constant)
      indent=indent+2
    ENDDO
    WRITE(op_string,'(A)') indentstring(1:indent)//char(error)
    CALL write_str(error_output_type,localerr,localerror2,*999)

    RETURN
    !Don't return an error code here otherwise we will get into a circular loop
999 RETURN 
  END SUBROUTINE writeerror

  !
  !================================================================================================================================
  !

  SUBROUTINE write_str(ID,ERR,ERROR,*)


!!!!NOTE: No enters or exits is used here to avoid an infinite loop
!!!!NOTE: This routine is, in general, OS dependent but needs to be defined here so that an module loop is avoided when MACHINE
!!!!      module routines need to use this module.

    !Argument Variables
    INTEGER(INTG), INTENT(IN) :: ID
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    !Local Variables
    INTEGER(INTG) :: END_LINE(max_output_lines),i,j,LENGTH,NUMBER_BLANKS,NUMBER_RECORDS

    !Calculate number of records in OP_STRING
    SELECT CASE(machine_os)
    CASE(vms_os)
      i=1 
      DO WHILE(op_string(i)(1:1)/=char(0).AND.i<max_output_lines)
        i=i+1
      ENDDO
      number_records=i-1
    CASE(irix_os,linux_os,aix_os)
      i=1
      number_blanks=0
      DO WHILE(i<max_output_lines.AND.number_blanks<2)
        i=i+1
        length=len_trim(op_string(i))
        IF(length==0) THEN
          number_blanks=number_blanks+1
        ELSE
          number_blanks=0
        ENDIF
      ENDDO
      number_records=i-number_blanks
    CASE(windows_os)
      i=1 
      DO WHILE(op_string(i)(1:1)/=char(0).AND.i<max_output_lines)
        i=i+1
      ENDDO
      number_records=i-1
    CASE DEFAULT
      CALL flagerror("Operating system not implemented.",err,error,*999)
    END SELECT

    DO i=1,number_records
      END_LINE(i)=LEN_TRIM(OP_STRING(i))
    ENDDO !i

    IF(diag_file_open.AND.id==diagnostic_output_type) THEN
      DO i=1,number_records
        IF(end_line(i)<=max_output_width) THEN
          WRITE(diagnostics_file_unit,'(A)') op_string(i)(1:end_line(i))
        ELSE IF(end_line(i)>max_output_width.AND.end_line(i)<=maxstrlen) THEN
          WRITE(diagnostics_file_unit,'(A)') op_string(i)(1:max_output_width)
          WRITE(diagnostics_file_unit,'(A)') op_string(i)(max_output_width+1:end_line(i))
        ELSE
          WRITE(diagnostics_file_unit,'(A)') op_string(i)(1:max_output_width)
          WRITE(diagnostics_file_unit,'(A)') op_string(i)(max_output_width+1:maxstrlen)
        ENDIF
      ENDDO !i
    ELSE IF(timing_file_open.AND.id==timing_output_type) THEN
      DO i=1,number_records
        IF(end_line(i)<=max_output_width) THEN
          WRITE(timing_file_unit,'(A)') op_string(i)(1:end_line(i))
        ELSE IF(end_line(i)>max_output_width.AND.end_line(i)<=maxstrlen) THEN
          WRITE(timing_file_unit,'(A)') op_string(i)(1:max_output_width)
          WRITE(timing_file_unit,'(A)') op_string(i)(max_output_width+1:end_line(i))
        ELSE
          WRITE(timing_file_unit,'(A)') op_string(i)(1:max_output_width)
          WRITE(timing_file_unit,'(A)') op_string(i)(max_output_width+1:maxstrlen)
        ENDIF
      ENDDO !i
    ELSE
      IF(id<=9) THEN !not file output
        DO i=1,number_records
          IF(end_line(i)<=max_output_width) THEN
            WRITE(*,'(A)') op_string(i)(1:end_line(i))
          ELSE IF(end_line(i)>max_output_width.AND.end_line(i)<=maxstrlen) THEN
            WRITE(*,'(A)') op_string(i)(1:max_output_width)
            WRITE(*,'(A)') op_string(i)(max_output_width+1:end_line(i))
          ELSE
            WRITE(*,'(A)') op_string(i)(1:max_output_width)
            WRITE(*,'(A)') op_string(i)(max_output_width+1:maxstrlen)
          ENDIF
        ENDDO !i
      ELSE !file output
        DO i=1,number_records
          WRITE(id,'(A)') op_string(i)(1:end_line(i))
        ENDDO !i
      ENDIF

      !Echo strings to output file if required

      IF(echo_output) THEN
        DO i=1,number_records
          IF(end_line(i)<=max_output_width) THEN
            WRITE(echo_file_unit,'(A)') op_string(i)(1:end_line(i))
          ELSE IF(end_line(i)>max_output_width.AND.end_line(i)<=maxstrlen) THEN
            WRITE(echo_file_unit,'(A)') op_string(i)(1:max_output_width)
            WRITE(echo_file_unit,'(A)') op_string(i)(max_output_width+1:end_line(i))
          ELSE
            WRITE(echo_file_unit,'(A)') op_string(i)(1:max_output_width)
            WRITE(echo_file_unit,'(A)') op_string(i)(max_output_width+1:maxstrlen)
          ENDIF
        ENDDO !i
      ENDIF
    ENDIF

    !Reset OP_STRING
    SELECT CASE(machine_os)
    CASE(vms_os)
      DO i=1,number_records
        op_string(i)(1:1)=char(0)
      ENDDO !i
    CASE(irix_os,linux_os,aix_os)
      DO i=1,number_records
        DO j=1,maxstrlen
          op_string(i)(j:j)=' '
        ENDDO !j
      ENDDO !i
    CASE(windows_os)
      DO i=1,number_records
        op_string(i)(1:1)=char(0)
      ENDDO !i
    CASE DEFAULT
      CALL flagerror("Operating system not implemented.",err,error,*999)
    END SELECT

    RETURN
999 errorsexits("WRITE_STR",err,error)
  END SUBROUTINE write_str

  !
  !================================================================================================================================
  !

END MODULE base_routines