prism_message.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, CERFACS, Toulouse, France.
00003 ! Copyright 2006-2010, SGI Germany, Munich, Germany.
00004 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00005 ! All rights reserved. Use is subject to OASIS4 license terms.
00006 !-----------------------------------------------------------------------
00007 !BOP
00008 !
00009 ! !ROUTINE: PRISM_Message
00010 !
00011 ! !INTERFACE:
00012 
00013       subroutine prism_message ( comp_id, string )
00014 !
00015 ! !USES:
00016 !
00017       use PRISM, dummy_interface => prism_message
00018 !
00019       use PSMILe
00020 
00021       implicit none
00022 !
00023 ! !INPUT PARAMETERS:
00024 !
00025       Integer, Intent(In)            :: comp_id
00026       Character (len=*), Intent(In)  :: string
00027 
00028 !     Message to be printed.
00029 !
00030 !
00031 ! !LOCAL VARIABLES
00032 !
00033     character(len=16) :: ch_rank
00034     integer           :: ipos
00035     integer           :: id
00036 !
00037 ! !DESCRIPTION:
00038 !
00039 ! Subroutine prism_message prints a message.
00040 !
00041 ! !REVISION HISTORY:
00042 !   Date      Programmer   Description
00043 ! ----------  ----------   -----------
00044 ! 01.12.03    R. Redler    created
00045 ! 03.10.27    R. Redler    comp_id added
00046 !
00047 !EOP
00048 !----------------------------------------------------------------------
00049 !
00050 ! $Id: prism_message.F90 2325 2010-04-21 15:00:07Z valcke $
00051 ! $Author: valcke $
00052 !
00053   Character(len=len_cvs_string), save :: mycvs = 
00054       '$Id: prism_message.F90 2325 2010-04-21 15:00:07Z valcke $'
00055 !
00056 !----------------------------------------------------------------------
00057 
00058 ! Clear write buffer
00059 
00060       call psmile_flushstd
00061 
00062 ! 1st Check comp_id and print out information
00063 
00064       if ( comp_id /= PRISM_UNDEFINED ) then
00065 
00066          if (comp_id < 1 .or. &
00067               comp_id > Number_of_Comps_allocated) then
00068              print *, trim(ch_id), 'prism_message: comp_id (out of range)'
00069              id = PRISM_UNDEFINED
00070          endif
00071 
00072          if (Comps(comp_id)%status == PSMILe_status_free) then
00073             print *, trim(ch_id), 'prism_message: comp_id (not active)'
00074             id = PRISM_UNDEFINED
00075          endif
00076 
00077       endif
00078 
00079 
00080 ! 2nd flush write buffer
00081 
00082       call psmile_flushstd
00083 
00084       ipos = 0
00085       call psmile_int2char ( Appl%rank, ch_rank, ipos)
00086 
00087       if ( id == PRISM_UNDEFINED ) then
00088          write (*, 9990) ch_rank(1:ipos), 'UNKNOWN ', trim (string)
00089       else
00090          write (*, 9990) ch_rank(1:ipos), trim(Comps(comp_id)%comp_name), trim (string)
00091       endif
00092 
00093       call psmile_flushstd
00094 
00095 9990  format (1x, '[', a, '] PRISM message from component: ', a, &
00096              /1x, a)
00097 
00098       end subroutine prism_message