psmile_error_common.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: psmile_error_common 
!
! !INTERFACE:

      subroutine psmile_error_common ( ierror, char_string, ierrp, nerrp, &
                                file, line )
!
! !USES:
!
      use psmile_common, dummy_interface => psmile_error_common

      implicit none

#include "prism.inc"

!
! !INPUT PARAMETERS:
!
      integer, Intent (In)                :: ierror
!
!     PRISM error code
!
      character(len=*), Intent(In)        :: char_string
! 
!     Character parameter to the error code
!
      integer, Intent (In)                :: nerrp
!
!     Number of error parameters
!
      integer, Intent (In)                :: ierrp (nerrp)
!
!     Error parameters for the error code
!
      character(len=*), Intent(In)        :: file
!
!     File name in which the error code was generated
!
      integer, Intent (In)                :: line
!
!     Line number in "file" at which error code was generated
!
! !LOCAL VARIABLES
!
      integer                             :: ierr, lenstr
      integer                             :: char_len
      character(len=MPI_MAX_ERROR_STRING) :: error_string
      logical                             :: abort

      character(len=16)                   :: ch_rank
      integer                             :: ipos
!
! !DESCRIPTION:
!
! Subroutine PSMILe_Error prints error messages.
!
! \begin{verbatim}
! Error classes:
!
!     PRISM_Error_MPI <= ierror <= 10 : Error in a MPI routine
!        string    = Name of the MPI routine
!        ierrp (1) = MPI error code
!
!        ierror = PRISM_Error_MPI :
!                 General MPI error
!        ierror = PRISM_Error_Send :
!                 Error in a MPI_Send/MPI_Isend routine
!                 ierrp (2) = Destination
!                 ierrp (3) = Tag
!        ierror = PRISM_Error_Recv :
!                 Error in a MPI_Recv/MPI_Irecv routine
!                 ierrp (2) = Source
!                 ierrp (3) = Tag
!
!     PRISM_Error_Parameter <= ierror : Error in a PSMILe routine
!
!        ierror = PRISM_Error_Parameter :
!                 Parameter is insufficient
!                    string = Name of parameter
!                    ierrp (1) = Current value
!                    ierrp (2) = Required value
!
!        ierror = PRISM_Error_Initialized :
!                 PRISM environment is not initialized.
!        ierror = PRISM_Error_Alloc :
!                 Error in Allocate
!        ierror = PRISM_Error_Internal : Internal error
! \end{verbatim}
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! (01.12.03   R. Redler    created psmile_error.F90)
! 2005-06     J. Ghattas   created from psmile_error.F90
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_error_common.F90 2706 2010-11-04 15:33:32Z hanke $
!  $Autor$
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_error_common.F90 2706 2010-11-04 15:33:32Z hanke $'
!
!----------------------------------------------------------------------
!
!   Flush Output
!
      call psmile_flushstd
!
      abort = .true.
!
!   Write initial line containing the id and the location
!
      ipos = 0
      lenstr = len_trim (char_string)
      call psmile_int2char ( Appl%rank, ch_rank, ipos)

      write (*, 9990) ch_rank(1:ipos), trim(Appl%name), file, line

!   Error in a MPI routine

      if ( PRISM_Error_MPI <= ierror .and. ierror <= 10 ) then
         call MPI_Error_string ( ierrp(1), error_string, char_len, ierr)
         write (*, 1010) char_string(1:lenstr), error_string(1:char_len)

         if (ierror == PRISM_Error_Send) then
            write (*, 1020) ierrp (2), ierrp (3)
         else if (ierror == PRISM_Error_Recv) then
            write (*, 1030) ierrp (2), ierrp (3)
         else if (nerrp > 1) then
            write (*, 1090) ierrp (2:nerrp)
         endif

!   Error in a PSMILe routine

      else if (ierror == PRISM_Error_Parameter) then

         write (*, 1110) char_string(1:lenstr), ierrp (1), ierrp (2)

      else if (ierror == PRISM_Error_Alloc) then

         write (*, 1130) char_string(1:lenstr), ierrp (2)

      else if (ierror == PRISM_Error_Dealloc) then

         write (*, 1140) char_string(1:lenstr)

         abort = .false.

      else if (ierror == PRISM_Error_Arg) then

         write (*, 1150) char_string(1:lenstr), ierrp (1)

         abort = .true.

      else if (ierror == PRISM_Error_Invalid_Arg) then

         write (*, 1160) char_string(1:lenstr)

         abort = .true.

      else if (ierror == PRISM_Error_Arglist) then

         write (*, 1190) char_string(1:lenstr), ierrp (:)

         abort = .true.

      else

!   unknown error code

         write (*, 9980) ierror, char_string(1:lenstr), nerrp
         write (*, 9970) ierrp
      endif

      call psmile_flushstd

!   Abort entire application ?

      if (abort) call PSMILe_Abort

!----------------------------------------------------------------------------
!   Formats
!----------------------------------------------------------------------------

! MPI errors

1010  format (1x, 'Error in MPI routine ', a, ': Error message :', a)
1020  format (1x, 'Error occured in Send to process', i4, ' using tag', i5)
1030  format (1x, 'Error occured in Receive from process', i4, ' using tag', i5)
1090  format (1x, 'Error parameters:', (1x, 10(i7, :, ',')))

! PSMILe errors

1110  format (1x, 'Value of parameter ', a, ' is insufficient.', &
             /1x, 'Current value:', i5, '; should be ', i6)
1130  format (1x, 'Cannot allocate ', a, &
                  '. Number of data items to be allocated was', i9)
1140  format (1x, 'Cannot deallocate ', a, '.')
1150  format (1x, 'Argument ', a, ' is out of range.', &
             /1x, 'Current value:', i5)
1160  format (1x, 'Argument ', a, ' is invalid.')

1190  format (1x, 'Error in argument list: ', a, (1x, 10(i7, :, ',')))


! Error in Grid definition
! statt id namen drucken


!  General formats

9970  format (1x, 10i7)
9980  format (1x, 'Unknown error code', i4, '; string ', a, '; nerrp', i3)
9990  format (1x, '[', a, '] PSMILe: Error in component: ', a, &
                  '; File ', a, ': line', i6 )
end subroutine psmile_error_common