prism_abort.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISM_Abort
!
! !INTERFACE:
!
      subroutine prism_abort ( comp_id, file, mesg )
!
! !USES:
!
      use PRISM, only : PRISM_UNDEFINED, dummy_interface => prism_abort
!
      use PSMILe

      implicit none
!
! !INPUT PARAMETERS:
!
      Character(len=*), Intent(In) :: mesg

!     Message provided by the application developer

      Character(len=*), Intent(In) :: file

!     Subroutine or file from which prism_abort has been called.
!
!
! !INPUT/OUTPUT PARAMETERS:
!
      Integer, Intent(InOut)       :: comp_id

!     Component ID from which prism_abort has been called.

!
! !LOCAL VARIABLES
!
      integer :: ila_args(PSMILe_trans_Header_length)
      integer :: ierror
!
!
! !DESCRIPTION:
!
!     Best attempt to abort all tasks of the current PRISM application
!
! !REVISION HISTORY:

!   Date      Programmer   Description
! ----------  ----------   -----------
! 01.12.03      H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: prism_abort.F90 2939 2011-02-03 12:13:10Z redler $
! $Author: redler $
!
  Character(len=len_cvs_string), save :: mycvs = 
      '$Id: prism_abort.F90 2939 2011-02-03 12:13:10Z redler $'
!
!----------------------------------------------------------------------
!
! 1st Send the header message to the transformer
!
      ila_args(1) = PSMILe_trans_Abort
      ila_args(2) = global_rank
      ila_args(3) = 1
      ila_args(4) = Appl%sequence_number
      ila_args(5) = Appl%rank

      call psmile_trs_inform(ila_args, PRISMdrv_root, ierror)
!
! 2nd Clear write buffer
!
      call psmile_flushstd

! 3rd Check comp_id and print out information

      if ( comp_id /= PRISM_UNDEFINED ) then

         if (comp_id < 1 .or. &
              comp_id > Number_of_Comps_allocated) then
             print *, trim(ch_id), 'prism_abort : comp_id (out of range)'
             comp_id = PRISM_UNDEFINED
         endif

         if (Comps(comp_id)%status == PSMILe_status_free) then
            print *, trim(ch_id), 'prism_abort : comp_id (not active)'
            comp_id = PRISM_UNDEFINED
         endif

      endif

      print *
      print *, '********************************************************'
      print *, '       Trying to abort the coupled application          '
      print *, '********************************************************'
      print *
      print *, ' prism_abort called from routine ', trim(file)

      if ( comp_id == PRISM_UNDEFINED ) then
         print *, ' from unkown component (odd comp_id for prism_abort)'
      else
         print *, ' in component ', trim(Comps(comp_id)%comp_name)
      endif

      print *
      print *, trim(mesg)
      print *
      print *, ' Name of aborting application is ', trim(Appl%name)
      print *, ' Rank within global set is  ', global_rank
      print *, ' Rank within application is ', Appl%rank
      print *, ' Rank within component is   ', Comps(comp_id)%rank
      print *, '********************************************************'

! 4th flush write buffer

      call psmile_flushstd

! 5th shut down MPI processes
!
!     MPI_Abort is now called by the transformer
!     call MPI_Abort ( comm_global, 1, ierror )

      end subroutine prism_abort