**************************************************************************
      * DBG043R3: Character to Number conversion
      * Copyright (C) 2000  Martin Rowe   <martin@dbg400.net>
      *
      * This program is free software; you can redistribute it and/or modify
      * it under the terms of the GNU General Public License as published by
      * the Free Software Foundation; either version 2 of the License, or
      * (at your option) any later version.
      *
      * This program is distributed in the hope that it will be useful,
      * but WITHOUT ANY WARRANTY; without even the implied warranty of
      * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      * GNU General Public License for more details.
      *
      * You should have received a copy of the GNU General Public License
      * along with this program; if not, write to the Free Software Foundation,
      * Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
      **************************************************************************
      *  DESCRIPTION: Character to number conversion
      *  Convert a numeric string (held somewhere in a 16 alpha field) to a 15,5
      *  number. Leading/trailing blanks are handled, as is the decimal point if
      *  found. Conversion stops at the first embedded blank found (in which
      *  case the string parm is set to '*WARNING'. If non numeric data is found
      *  in the first portion of the string, the result will be zero, and the
      *  string parm is set to '*ERROR'. If a negative sign is found anywhere
      *  in the string, the number is assumed to be negative.
      *  Note. THE LR INDICATOR IS NOT SET ON IN THIS PGM.
      **************************************************************************
     H        1   Y
      **************************************************************************
     I              'ABCDEFGHIJKLMNOPQR'  C         LTRS
     I              '##################'  C         DROP
      **************************************************************************
     C           *ENTRY    PLIST
     C                     PARM           P#CHAR 16
     C                     PARM           P#DEC  155
      **************************************************************************
      *  Field initialisation
     C                     MOVE *BLANKS   @STRNG 16        Working string
     C                     MOVE *BLANKS   @FLD16 16        Right adjusted string
     C                     MOVE *BLANKS   @LFT16 16        Left adjusted string
     C                     MOVE *BLANKS   @STORE 16        Store after -ve check
     C                     MOVE *OFF      @NEGVL  1        Negative indicator
     C                     Z-ADD0         @S      20       String start position
     C                     Z-ADD0         @R      20       Required leading ' 's
     C                     Z-ADD0         @LEN    20       String length
     C                     Z-ADD0         @E      20       String end position
     C                     Z-ADD0         @DEC    20       Decimal point
     C                     MOVE *BLANKS   @DECFL 15        Alpha decimal portion
     C                     MOVE *ZEROS    @ZEROS 15        Decimal trailing 0's
     C                     Z-ADD0         @NBR10 100       Whole number portion
     C                     Z-ADD0         @DEC05  55       Decimal portion
      **************************************************************************
      *  Swap letters for # symbol as a single letter (from A to R) can be a
      *  valid number - according to TESTN. Bizarre, isn't it.
     C           LTRS:DROP XLATEP#CHAR    @STRNG
      *  Determine if negative sign used
     C           '-':' '   XLATE@STRNG    @STORE
B001 C           @STORE    IFNE @STRNG
     C                     MOVE @STORE    @STRNG
     C                     MOVE *ON       @NEGVL
E001 C                     ENDIF
      *  Determine start of number in string (first non-blank element)
     C           ' '       CHECK@STRNG    @S             70
      *  Non-blanks found, so start adjustment
B001 C           *IN70     IFEQ *ON
      *  Left adjust field to start off (substring from start of non-blank data)
     C           17        SUB  @S        @LEN
     C           @LEN      SUBST@STRNG:@S @LFT16
     C                     MOVE @LFT16    @STRNG
      *  Look for end of 'numeric' string (first embedded blank - same thing)
     C           ' '       SCAN @STRNG    @E             70
      *  If trailing blanks found
B002 C           *IN70     IFEQ *ON
      *  Is trailing blank an embedded blank?? (look for data after the blank)
     C           ' '       CHECK@STRNG:@E                72
      *  Yes, it is, so set warning flag
B003 C           *IN72     IFEQ *ON
     C                     MOVEL'*WARNING'P#CHAR    P
      *  Just extract first part of field before embedded blank and use that
     C           @E        SUB  1         @LEN
     C           @LEN      SUBST@STRNG:1  @LFT16    P
     C                     MOVE @LFT16    @STRNG
E003 C                     ENDIF
      *  Process resultant string
      *  Check if decimal point in string
     C           '.'       SCAN @STRNG    @DEC           71
      *  Yes, it has
B003 C           *IN71     IFEQ *ON
      *  Assume number has a decimal fraction & treat accordingly
      *  (Field of 123.45 or .876 format)
B004 C           @DEC      IFLE @E
     C           @E        OREQ 0
      *  By subtracting position of decimal point from the result
      *  result field length (plus 1) the number of leading blanks
      *  required to create a whole number string is obtained
     C           17        SUB  @DEC      @R
      *  Now add those leading blanks to 'numeric' string (holding field)
     C                     MOVE *BLANKS   @STORE
     C                     CAT  @STRNG:@R @STORE
      *  Now deal with decimal portion
     C           @DEC      ADD  1         @R
     C           17        SUB  @R        @LEN
B005 C           @DEC      IFLT 16
     C           @LEN      SUBST@STRNG:@R @DECFL
     C                     CAT  @ZEROS:0  @DECFL
E005 C                     ENDIF
      *  Move 'holding field' back
     C                     MOVE @STORE    @FLD16
E004 C                     ENDIF
      *  Otherwise process as a whole number only
      *  (Field of 12345 format)
X003 C                     ELSE
      *  By subtracting position of first trailing blank from the
      *  result field length (plus 1) the number of leading blanks
      *  required is obtained.
     C           17        SUB  @E        @R
      *  Now add those leading blanks to 'numeric' string
     C                     CAT  @STRNG:@R @FLD16
E003 C                     ENDIF
      *  Otherwise no adjustment required - just a straightforward move
      *  (Field of 1234567890123456 format - all positions used - unlikely)
X002 C                     ELSE
     C                     MOVE @STRNG    @FLD16
E002 C                     ENDIF
      *  Otherwise indicate error - non numeric data (blanks)
X001 C                     ELSE
     C                     MOVEL'*ERROR'  P#CHAR    P
E001 C                     ENDIF
      **************************************************************************
      *  Final check of Whole & Decimal portions
      *  Check that string is valid to put in numeric field
     C                     TESTN          @FLD16     707070
B001 C           *IN70     IFEQ *ON
     C                     MOVE @FLD16    @NBR10
      *  Check that string is valid to put in numeric field
     C                     TESTN          @DECFL     717171
B002 C           *IN71     IFEQ *ON
     C                     MOVEL@DECFL    @DEC05
      *  Add whole number and decimal portions to exit parameter
     C           @NBR10    ADD  @DEC05    P#DEC
      *  If negative sign at start or end of field, then make field negative
B003 C           @NEGVL    IFEQ *ON
     C                     Z-SUBP#DEC     P#DEC
E003 C                     ENDIF
      *  Otherwise indicate error - non numeric data
X002 C                     ELSE
     C                     MOVEL'*ERROR'  P#CHAR    P
E002 C                     ENDIF
      *  Otherwise indicate error - non numeric data
X001 C                     ELSE
     C                     MOVEL'*ERROR'  P#CHAR    P
E001 C                     ENDIF
      *  EXIT
     C                     RETRN
      *****************************************************************