logging_base.f90

Go to the documentation of this file.

!#############################################################################
!#                                                                           #
!# fosite - 3D hydrodynamical simulation program                             #
!# module: common_types.f90                                                  #
!#                                                                           #
!# Copyright (C) 2006-2014                                                   #
!# Tobias Illenseer <tillense@astrophysik.uni-kiel.de>                       #
!#                                                                           #
!# This program 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 of the License, or (at     #
!# your option) any later version.                                           #
!#                                                                           #
!# This program 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, GOOD TITLE or        #
!# NON INFRINGEMENT.  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.                 #
!#                                                                           #
!#############################################################################

!----------------------------------------------------------------------------!
!----------------------------------------------------------------------------!
MODULE logging_base_mod
#ifdef PARALLEL
#ifdef HAVE_MPI_MOD
  USE mpi
#endif
#endif
  IMPLICIT NONE
#ifdef PARALLEL
#ifdef HAVE_MPIF_H
  include 'mpif.h'
#endif
#endif
  !--------------------------------------------------------------------------!
  PRIVATE
  TYPE logging_base
    PRIVATE
    INTEGER           :: mod_type
    CHARACTER(LEN=32) :: mod_name
    INTEGER, PUBLIC   :: err
    LOGICAL           :: isinitialized = .false. 
    INTEGER, POINTER  :: myrank => null()        
    INTEGER, POINTER  :: ppnum => null()         
    LOGICAL, POINTER  :: parinit => null()       
  CONTAINS
    PROCEDURE :: initlogging
    final     :: finalize
    PROCEDURE :: gettype
    PROCEDURE :: getname
    PROCEDURE :: getrank
    PROCEDURE :: getnumprocs
    PROCEDURE :: initialized
    PROCEDURE :: info
    PROCEDURE :: warning
    PROCEDURE :: error
  END TYPE logging_base
  ! these variables should be the same for all objects
  ! of the current process
#ifdef PARALLEL
  INTEGER, SAVE          :: default_mpi_real = mpi_real              
  INTEGER, SAVE          :: default_mpi_2real = mpi_2real            
  INTEGER, SAVE          :: default_mpi_complex = mpi_double_complex 
  REAL, PARAMETER        :: dummy   = 1.0
#endif
  REAL, SAVE             :: nan_default_real
  INTEGER, PARAMETER     :: stderr  = 0
  INTEGER, PARAMETER     :: stdout  = 6
  INTEGER, SAVE, TARGET  :: myrank  = 0
  INTEGER, SAVE, TARGET  :: ppnum   = 1
  LOGICAL, SAVE, TARGET  :: parinit = .false.                        
  CHARACTER(LEN=1), SAVE :: prefix  = ' '
  !--------------------------------------------------------------------------!
  PUBLIC ::                 &
       ! types
       logging_base,        &
#ifdef PARALLEL
       default_mpi_real,    &
       default_mpi_2real,   &
       default_mpi_complex, &
#endif
       nan_default_real, &
       setprefix
  !--------------------------------------------------------------------------!

CONTAINS

  SUBROUTINE initlogging(this,t,n)
    use, INTRINSIC :: ieee_arithmetic
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(INOUT) :: this
    INTEGER                            :: t
    CHARACTER(LEN=*)                   :: n
    !------------------------------------------------------------------------!
    INTENT(IN)                         :: t,n
    !------------------------------------------------------------------------!
    this%mod_type = t
    this%mod_name = n
    this%myrank => myrank
    this%ppnum => ppnum
    this%parinit => parinit
#ifdef PARALLEL
    IF (.NOT.parinit) THEN
       CALL mpi_comm_rank(mpi_comm_world,this%myrank,this%err)
       CALL mpi_comm_size(mpi_comm_world,this%ppnum,this%err)
       this%parinit = .true.
       ! determine the default MPI data type for real numbers
       SELECT CASE (selected_real_kind(precision(dummy)))
       CASE(4)
          default_mpi_real = mpi_real4
          default_mpi_2real = mpi_2real
       CASE(8)
          default_mpi_real = mpi_real8
          default_mpi_2real = mpi_2double_precision
       CASE DEFAULT
          CALL warning(this,"InitCommon","Cannot determine default MPI real types.")
       END SELECT
    END IF
#endif
    nan_default_real    = ieee_value(nan_default_real,ieee_quiet_nan)
    this%err = 0
    this%isinitialized  = .true.
  END SUBROUTINE initlogging


  SUBROUTINE finalize(this)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    TYPE(logging_base), INTENT(INOUT) :: this
    !------------------------------------------------------------------------!
    this%isinitialized  = .false.
  END SUBROUTINE finalize


  PURE FUNCTION gettype(this) RESULT(t)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN) :: this
    INTEGER                         :: t
    !------------------------------------------------------------------------!
    t = this%mod_type
  END FUNCTION gettype


  SUBROUTINE setprefix(val)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CHARACTER(LEN=1), INTENT(IN) :: val
    !------------------------------------------------------------------------!
    prefix = val
  END SUBROUTINE setprefix


  PURE FUNCTION getname(this) RESULT(n)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN) :: this
    CHARACTER(LEN=32)               :: n
    !------------------------------------------------------------------------!
    n = this%mod_name
  END FUNCTION getname


  PURE FUNCTION getrank(this) RESULT(r)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN) :: this
    INTEGER                         :: r
    !------------------------------------------------------------------------!
    r = this%myrank
  END FUNCTION getrank


  PURE FUNCTION getnumprocs(this) RESULT(p)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN) :: this
    INTEGER                         :: p
    !------------------------------------------------------------------------!
    p = this%ppnum
  END FUNCTION getnumprocs


  PURE FUNCTION initialized(this) RESULT(i)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN) :: this
    LOGICAL                         :: i
    !------------------------------------------------------------------------!
    i = this%isinitialized
#ifdef PARALLEL
    IF (ASSOCIATED(this%parinit)) THEN
      i = i.AND.this%parinit
    ELSE
      i = .false.
    END IF
#endif
  END FUNCTION initialized


  SUBROUTINE info(this,msg,rank,node_info,tostderr)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN)  :: this
    CHARACTER(LEN=*), INTENT(IN)     :: msg
    INTEGER, OPTIONAL, INTENT(IN)    :: rank
    LOGICAL, OPTIONAL, INTENT(IN)    :: node_info
    LOGICAL, OPTIONAL, INTENT(IN)    :: tostderr
    !------------------------------------------------------------------------!
#ifdef PARALLEL
    INTEGER :: ierr
#endif
    INTEGER :: print_rank,output_unit
    LOGICAL :: print_node_info
    !------------------------------------------------------------------------!
    IF (PRESENT(rank)) THEN
       print_rank = rank
    ELSE
       print_rank = 0
    END IF
    IF (PRESENT(node_info)) THEN
       print_node_info = node_info
    ELSE
       print_node_info = .false.
    END IF
    ! output unit for printing, defaults to STDOUT
    output_unit = stdout
    IF (PRESENT(tostderr)) THEN
       IF (tostderr) output_unit = stderr ! print on STDERR if requested
    ENDIF
#ifdef PARALLEL
    IF (.NOT.parinit) CALL mpi_comm_rank(mpi_comm_world,myrank,ierr)
#endif
    ! use "myrank" here instead of "this%myrank"
    ! because "this" might be uninitialized
    IF (myrank.EQ.print_rank) THEN
      WRITE (output_unit,'(A)',advance='NO') prefix
#ifdef PARALLEL
      IF (print_node_info) &
        WRITE (output_unit,'(A,I4.4,A)',advance='NO') "NODE [", myrank, "] "
#endif
      WRITE (output_unit,'(A)') trim(msg)
      ! Flush the output buffer, to make sure it is written even if the
      ! program is invoked from a batch system.
      ! This is Fortran 2003 standard! In Fortran 90/95 flush is implemented
      ! as a subroutine, hence one needs a CALL statement, i.e.,
      ! CALL FLUSH(output_unit)
      FLUSH(output_unit)
    END IF
  END SUBROUTINE info


  SUBROUTINE warning(this,modproc,msg,rank)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN) :: this
    CHARACTER(LEN=*), INTENT(IN)    :: modproc
    CHARACTER(LEN=*), INTENT(IN)    :: msg
    INTEGER, OPTIONAL, INTENT(IN)   :: rank
    !------------------------------------------------------------------------!
     CALL info(this,"WARNING in " // trim(modproc) // ": " // trim(msg),&
               rank,node_info=.true.,tostderr=.true.)
  END SUBROUTINE warning


  SUBROUTINE error(this,modproc,msg,rank,node_info)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(logging_base), INTENT(IN)  :: this
    CHARACTER(LEN=*), INTENT(IN)     :: modproc
    CHARACTER(LEN=*), INTENT(IN)     :: msg
    INTEGER, OPTIONAL, INTENT(IN)    :: rank
    LOGICAL, OPTIONAL, INTENT(IN)    :: node_info
    !------------------------------------------------------------------------!
#ifdef PARALLEL
    INTEGER :: ierr
#endif
    !------------------------------------------------------------------------!
    CALL info(this,"ERROR in " // trim(modproc) // ": " // trim(msg),&
         rank=rank,node_info=node_info,tostderr=.true.)
    ! abort execution
#ifdef PARALLEL
    CALL mpi_abort(mpi_comm_world,1,ierr)
#else
    stop 99
#endif
  END SUBROUTINE error

END MODULE logging_base_mod