Quelle  getnum.cob   Sprache: Cobol

       IDENTIFICATION DIVISION.
      *
       PROGRAM-ID.    GETNUMT.
      *
       DATE-WRITTEN.  04/04/90.
      *
      *    MODIFIED   10/18/97.
      *
      *        *******************************
      *        *                             *
      *        *     Judson D. McClendon     *
      *        *     Sun Valley Systems      *
      *        *     329 37th Court N.E.     *
      *        *     Birmingham, AL 35215    *
      *        *        205-853-8440         *
      *        *                             *
      *        *******************************
      *
       ENVIRONMENT DIVISION.
      *
       CONFIGURATION SECTION.
      *
       INPUT-OUTPUT SECTION.
      *
       FILE-CONTROL.
      *
       I-O-CONTROL.
      *
       DATA DIVISION.
      *
       FILE SECTION.
      *
      *
       WORKING-STORAGE SECTION.
      *
       77  WS-ESCAPE-FLAG              PIC  9(01)     COMP VALUE 0.
       77  WS-ERR-MSG                  PIC  X(30)     VALUE SPACES.
      *
      ******************************************************************
      *                                                                *
      *               N U M B E R   W O R K   A R E A                  *
      *                                                                *
      ******************************************************************
      *
       01  NUMBER-WORK-AREA.
           03  NW-NBR-ERROR-FLAG       PIC  9(01).
           03  NW-WORK-NBR.
               05  NW-WORK-CHAR        OCCURS 25 TIMES
                                       INDEXED BY NW-WX
                                                  NW-WLIM.
                   07  NW-WORK-DIGIT       PIC  9(01).
           03  NW-DEC-PLACES           PIC  9(02).
           03  NW-BLD-SIGN             PIC S9(01).
           03  NW-BLD-NBR              PIC  9(12)V9(06).
           03  NW-BLD-NBR-SPLIT        REDEFINES NW-BLD-NBR.
               05  NW-BLD-INTEGER          PIC  9(12).
               05  NW-BLD-DECIMAL          PIC V9(06).
                   88  NW-RESULT-INTEGER               VALUE ZERO.
               05  NW-BLD-DEC-DIGITS       REDEFINES NW-BLD-DECIMAL.
                   07  NW-BLD-DEC-DIGIT        OCCURS 6 TIMES
                                               INDEXED BY NW-BDX
                                                          NW-BDLIM
                                                   PIC  9(01).
           03  NW-EXTRACTED-NBR        PIC S9(12)V9(06).
      *
       SCREEN SECTION.
      *
      *
      *                     I N P U T   S C R E E N
      *
       01  INPUT-SCREEN
               FOREGROUND-COLOR 7
               BACKGROUND-COLOR 0.
           03  BLANK SCREEN
               LINE 01  COLUMN 31  VALUE "G E T N U M B E R".
      *
           03  LINE 03  COLUMN 01  VALUE "Enter Number: ".
           03  PIC  X(25)          USING NW-WORK-NBR.
      *
      *
      *                    O U T P U T   S C R E E N
      *
       01  OUTPUT-SCREEN
               FOREGROUND-COLOR 7
               BACKGROUND-COLOR 0.
      *
           03  LINE 05  COLUMN 01  VALUE " Result: ".
           03  PIC  -(13).9(06)    FROM  NW-EXTRACTED-NBR.
           03           COLUMN 41
               PIC  X(30)          FROM  WS-ERR-MSG.
      /
       PROCEDURE DIVISION.
      *
      *
      *             C O N T R O L   S E C T I O N
      *
       000000-CONTROL.
      *
           MOVE SPACES TO NW-WORK-NBR.
           DISPLAY INPUT-SCREEN.
      *
           PERFORM 000100-PROCESS
              THRU 000100-EXIT
               UNTIL (WS-ESCAPE-FLAG = 1).
      *
       000000-EXIT.
           STOP RUN.
      *
      *                    P R O C E S S
      *
       000100-PROCESS.
      *
           ACCEPT INPUT-SCREEN
               ON ESCAPE
                   MOVE 1 TO WS-ESCAPE-FLAG
                   GO TO 000100-EXIT.
      *
           PERFORM 003000-GET-NBR
              THRU 003000-EXIT.
      *
           IF (NW-NBR-ERROR-FLAG = 1)
               MOVE "NUMBER INVALID" TO WS-ERR-MSG
           ELSE
               MOVE SPACES           TO WS-ERR-MSG.
      *
           DISPLAY OUTPUT-SCREEN.
      *
       000100-EXIT.
           EXIT.
      *
      ******************************************************************
      *                                                                *
      *                      G E T   N U M B E R                       *
      *                                                                *
      *                      Judson D. McClendon                       *
      *                      Sun Valley Systems                        *
      *                      329 37th Court NE                         *
      *                      Birmingham, AL 35215                      *
      *                         205/853-8440                           *
      *                                                                *
      *    CONVERTS A NUMBER IN FREE FORMAT DISPLAY FORM:              *
      *        FOR EXAMPLE:                                            *
      *                                                                *
      *            "999,999,999,999.999999 "                           *
      *            "-999,999,999,999.999999"                           *
      *            "              -23.61   "                           *
      *            "                      4"                           *
      *            "0                      "                           *
      *            "    .000001            "                           *
      *            "0000000000123456789.10-"                           *
      *            "                       "  BLANK IS VALID = 0       *
      *                                                                *
      *    INTO FIXED NUMERIC FORM:                                    *
      *                                                                *
      *        PIC S9(12)V9(06)                                        *
      *                                                                *
      *                                                                *
      *    USAGE:  MOVE <FREE FORM NUMBER> TO NW-WORK-NBR.             *
      *            PERFORM 003000-GET-NBR                              *
      *               THRU 003000-EXIT.                                *
      *                                                                *
      *    RESULT: NW-NBR-ERROR-FLAG = 0 INPUT IS A VALID NUMBER       *
      *                                1 INPUT NOT A VALID NUMBER      *
      *                                                                *
      *       IF NW-NBR-ERROR-FLAG = 0 THEN:                           *
      *                                                                *
      *            NW-EXTRACTED-NBR  = NUMBER AS:  PIC S9(12)V9(06)    *
      *                                                                *
      *            NW-DEC-PLACES     = NUMBER OF DIGITS TO THE RIGHT   *
      *                                OF THE DECIMAL POINT (0=NONE)   *
      *                                                                *
      *            NW-BLD-SIGN       = +1 OR -1 AS:  PIC S9(01)        *
      *                                                                *
      *            NW-BLD-INTEGER    = INTEGER DIGITS AS:  PIC  9(12)  *
      *                                                                *
      *            NW-BLD-DECIMAL    = DECIMAL DIGITS AS:  PIC V9(06)  *
      *                                                                *
      ******************************************************************
      *
       003000-GET-NBR.
      *
           MOVE 0      TO NW-NBR-ERROR-FLAG.
           MOVE ZERO   TO NW-EXTRACTED-NBR.
      *
           MOVE 0      TO NW-DEC-PLACES.
           MOVE ZERO   TO NW-BLD-NBR.
           MOVE +1     TO NW-BLD-SIGN.
           SET NW-BDX  TO 1.
           SET NW-WLIM TO 25.
      *
      *  ** LOCATE LEFTMOST DIGIT OF NUMBER **
      *
           SET NW-WX  TO 1.
           SEARCH NW-WORK-CHAR
               WHEN NW-WORK-CHAR(NW-WX) NOT = SPACE
                   PERFORM 003010-DECODE-NBR
                      THRU 003010-EXIT.
      *
           IF (NW-WORK-NBR NOT = SPACES)
               MOVE 1 TO NW-NBR-ERROR-FLAG
           ELSE
               COMPUTE NW-EXTRACTED-NBR = NW-BLD-NBR * NW-BLD-SIGN.
      *
       003000-EXIT.
           EXIT.
      *
      *
      *                     DECODE NUMBER
      *
       003010-DECODE-NBR.
      *
           IF (NW-WORK-CHAR(NW-WX) = "-")
               MOVE -1    TO NW-BLD-SIGN
               MOVE SPACE TO NW-WORK-CHAR(NW-WX)
               SET NW-WX UP BY 1.
      *
           PERFORM 003020-GET-INT-PART
              THRU 003020-EXIT
                UNTIL (NW-WX > NW-WLIM).
      *
            SET NW-DEC-PLACES TO NW-BDX.
            SUBTRACT 1 FROM NW-DEC-PLACES.
      *
       003010-EXIT.
           EXIT.
      *
      *
      *               GET INTEGER PART OF NUMBER
      *
       003020-GET-INT-PART.
      *
           IF (NW-WORK-CHAR(NW-WX) NUMERIC)
               IF (NW-BLD-INTEGER > 99999999999)
                   SET NW-WX TO NW-WLIM
               ELSE
                   COMPUTE NW-BLD-INTEGER =
                       NW-BLD-INTEGER * 10 + NW-WORK-DIGIT(NW-WX)
                   MOVE SPACE TO NW-WORK-CHAR(NW-WX)
           ELSE
               IF (NW-WORK-CHAR(NW-WX) = ".")
                   MOVE SPACES TO NW-WORK-CHAR(NW-WX)
                   SET NW-WX UP BY 1
                   PERFORM 003030-GET-DEC-PART
                      THRU 003030-EXIT
                        UNTIL (NW-WX > NW-WLIM)
               ELSE
                   IF (NW-WORK-CHAR(NW-WX) = ",")
                       MOVE SPACE TO NW-WORK-CHAR(NW-WX)
                   ELSE
                       SET NW-WX TO NW-WLIM.
      *
           SET NW-WX UP BY 1.
      *
       003020-EXIT.
           EXIT.
      *
      *
      *               GET DECIMAL PART OF NUMBER
      *
       003030-GET-DEC-PART.
      *
           IF (NW-WORK-CHAR(NW-WX) NUMERIC)
               IF (NW-BDX > 6)
                   SET NW-WX  TO NW-WLIM
               ELSE
                   MOVE NW-WORK-DIGIT(NW-WX) TO NW-BLD-DEC-DIGIT(NW-BDX)
                   MOVE SPACES TO NW-WORK-CHAR(NW-WX)
                   SET NW-BDX UP BY 1
           ELSE
               IF (NW-WORK-CHAR(NW-WX) = "-")
                   MOVE -1    TO NW-BLD-SIGN
                   MOVE SPACE TO NW-WORK-CHAR(NW-WX)
                   SET NW-WX  TO NW-WLIM
               ELSE
                   SET NW-WX  TO NW-WLIM.
      *
           SET NW-WX UP BY 1.
      *
       003030-EXIT.
           EXIT.