external/fftpack/fftpack5/xerfft.F

   1 subroutine xerfft ( srname, info )
   2
   3 !*****************************************************************************80
   4 !
   5 !! XERFFT is an error handler for the FFTPACK routines.
   6 !
   7 !  Discussion:
   8 !
   9 !    XERFFT is an error handler for FFTPACK version 5.0 routines.
  10 !    It is called by an FFTPACK 5.0 routine if an input parameter has an
  11 !    invalid value.  A message is printed and execution stops.
  12 !
  13 !    Installers may consider modifying the stop statement in order to
  14 !    call system-specific exception-handling facilities.
  15 !
  16 !
  17 !    Copyright (C) 1995-2004, Scientific Computing Division,
  18 !    University Corporation for Atmospheric Research
  19 !
  20 !  Modified:
  21 !
  22 !    27 March 2009
  23 !
  24 !  Author:
  25 !
  26 !    Paul Swarztrauber
  27 !    Richard Valent
  28 !
  29 !  Reference:
  30 !
  31 !    Paul Swarztrauber,
  32 !    Vectorizing the Fast Fourier Transforms,
  33 !    in Parallel Computations,
  34 !    edited by G. Rodrigue,
  35 !    Academic Press, 1982.
  36 !
  37 !    Paul Swarztrauber,
  38 !    Fast Fourier Transform Algorithms for Vector Computers,
  39 !    Parallel Computing, pages 45-63, 1984.
  40 !
  41 !  Parameters:
  42 !
  43 !    Input, character ( len = * ) SRNAME, the name of the calling routine.
  44 !
  45 !    Input, integer ( kind = 4 ) INFO, an error code.  When a single invalid
  46 !    parameter in the parameter list of the calling routine has been detected,
  47 !    INFO is the position of that parameter.  In the case when an illegal
  48 !    combination of LOT, JUMP, N, and INC has been detected, the calling
  49 !    subprogram calls XERFFT with INFO = -1.
  50 !
  51   implicit none
  52
  53   integer ( kind = 4 ) info
  54   character ( len = * ) srname
  55   character ( len = 256 ) err_mesg
  56
  57 #if ( VAR4D != 1)
  58   call wrf_message ( 'XERFFT - Fatal error!' )
  59 #else
  60   call da_wrf_message ( 'XERFFT - Fatal error!' )
  61 #endif
  62
  63   if ( 1 <= info ) then
  64     write ( err_mesg , '(a,a,a,i3,a)') '  On entry to ', trim ( srname ), &
  65       ' parameter number ', info, ' had an illegal value.'
  66   else if ( info == -1 ) then
  67     write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
  68       ' parameters LOT, JUMP, N and INC are inconsistent.'
  69   else if ( info == -2 ) then
  70     write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
  71       ' parameter L is greater than LDIM.'
  72   else if ( info == -3 ) then
  73     write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
  74       ' parameter M is greater than MDIM.'
  75   else if ( info == -5 ) then
  76     write( err_mesg , '(a,a,a,a)') '  Within ', trim ( srname ), &
  77       ' input error returned by lower level routine.'
  78   else if ( info == -6 ) then
  79     write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
  80       ' parameter LDIM is less than 2*(L/2+1).'
  81   end if
  82
  83 #if ( VAR4D != 1)
  84   call wrf_error_fatal ( err_mesg )
  85 #else
  86   call da_wrf_error_fatal ( err_mesg )
  87 #endif
  88
  89 end