var/external/bufr/jstnum.f

   1       SUBROUTINE JSTNUM(STR,SIGN,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    JSTNUM
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE REMOVES ALL LEADING BLANKS FROM A CHARACTER
   9 C   STRING CONTAINING AN ENCODED INTEGER VALUE.  IF THE VALUE HAS A
  10 C   LEADING SIGN CHARACTER ('+' OR '-'), THEN THIS CHARACTER IS ALSO
  11 C   REMOVED AND IS RETURNED SEPARATELY WITHIN SIGN.  IF THE RESULTANT
  12 C   STRING CONTAINS ANY NON-NUMERIC CHARACTERS, THAN AN APPROPRIATE
  13 C   CALL IS MADE TO TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY)
  17 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  18 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  19 C                           ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY)
  20 C 2002-05-14  J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE
  21 C                           PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS
  22 C                           THEN REMOVED BECAUSE IT WAS JUST A DUMMY
  23 C                           ROUTINE WITH ENTRIES)
  24 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  25 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  26 C                           INTERDEPENDENCIES
  27 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  28 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  29 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  30 C                           ABNORMALLY OR UNUSUAL THINGS HAPPEN
  31 C 2009-04-21  J. ATOR    -- USE ERRWRT
  32 C
  33 C USAGE:    CALL JSTNUM (STR, SIGN, IRET)
  34 C   INPUT ARGUMENT LIST:
  35 C     STR      - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE
  36 C
  37 C   OUTPUT ARGUMENT LIST:
  38 C     STR      - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS
  39 C                AND SIGN CHARACTER REMOVED
  40 C     SIGN     - CHARACTER*1: SIGN OF ENCODED INTEGER VALUE:
  41 C                     '+' = positive value
  42 C                     '-' = negative value
  43 C     IRET     - INTEGER: RETURN CODE:
  44 C                       0 = normal return
  45 C                      -1 = encoded value within STR was not an integer
  46 C
  47 C REMARKS:
  48 C    THIS ROUTINE CALLS:        BORT     ERRWRT   STRNUM
  49 C    THIS ROUTINE IS CALLED BY: ELEMDX
  50 C                               Normally not called by any application
  51 C                               programs but it could be.
  52 C
  53 C ATTRIBUTES:
  54 C   LANGUAGE: FORTRAN 77
  55 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  56 C
  57 C$$$
  58
  59       CHARACTER*(*) STR
  60
  61       CHARACTER*128 ERRSTR
  62       CHARACTER*1  SIGN
  63
  64       COMMON /QUIET / IPRT
  65
  66 C-----------------------------------------------------------------------
  67 C-----------------------------------------------------------------------
  68
  69       IRET = 0
  70
  71       IF(STR.EQ.' ') GOTO 900
  72
  73       LSTR = LEN(STR)
  74 2     IF(STR(1:1).EQ.' ') THEN
  75          STR  = STR(2:LSTR)
  76          GOTO 2
  77       ENDIF
  78       IF(STR(1:1).EQ.'+') THEN
  79          STR  = STR(2:LSTR)
  80          SIGN = '+'
  81       ELSEIF(STR(1:1).EQ.'-') THEN
  82          STR  = STR(2:LSTR)
  83          SIGN = '-'
  84       ELSE
  85          SIGN = '+'
  86       ENDIF
  87
  88       CALL STRNUM(STR,NUM)
  89       IF(NUM.LT.0) THEN
  90          IF(IPRT.GE.0) THEN
  91       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
  92       ERRSTR = 'BUFRLIB: JSTNUM: ENCODED VALUE WITHIN RESULTANT '//
  93      .    'CHARACTER STRING (' // STR // ') IS NOT AN INTEGER - '//
  94      .    'RETURN WITH IRET = -1'
  95       CALL ERRWRT(ERRSTR)
  96       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
  97       CALL ERRWRT(' ')
  98          ENDIF
  99          IRET = -1
 100       ENDIF
 101
 102 C  EXITS
 103 C  -----
 104
 105       RETURN
 106 900   CALL BORT('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT '//
 107      . 'ALLOWED')
 108       END