COBOL CHAR関数とORD関数

COBOL CHAR関数とORD関数

CHAR関数とORD関数を使えば、
COMP系つかわなくても、
COBOL85からBIT操作しようと思えばできたみたい。

汎用機世界では、COBOL関数が封印されているのと、
アセンブラで可能なので、こういうことはしないのです。
＜CHARORD.COB＞
000010
000020 IDENTIFICATION           DIVISION.
000030 PROGRAM-ID.              CNT001.
000040*
000050 ENVIRONMENT                     DIVISION.
000060 CONFIGURATION                   SECTION.
000070 SOURCE-COMPUTER.                COBOL85.
000080 OBJECT-COMPUTER.                COBOL85.
000090*
000100 INPUT-OUTPUT                    SECTION. 
000110  FILE-CONTROL.                
000120     SELECT  OUT01    ASSIGN  TO  "D:\work\OUT_CHAR.dat".
000130     SELECT  IN01     ASSIGN  TO  "D:\work\OUT_CHAR.dat".
000140     SELECT  OUT02    ASSIGN  TO  "D:\work\OUT_ORD.dat".
000150*
000160 DATA                            DIVISION.
000170 FILE                            SECTION.
000180 FD  OUT01.
000190*     BLOCK      CONTAINS  0      RECORD   <=INVALID WORD BLOCK
000200*     LABEL      RECORD   IS      STANDARD.<=INVALID WORD LABEL
000210 01  OUT01-AREA.
000220     05  OUT01-DATA              PIC  X(01).
000230 FD  IN01.
000240 01  IN01-AREA.
000250     05  IN01-DATA               PIC  X(01).
000260 FD  OUT02.
000270*     BLOCK      CONTAINS  0      RECORD   <=INVALID WORD BLOCK
000280*     LABEL      RECORD   IS      STANDARD.<=INVALID WORD LABEL
000290 01  OUT02-AREA.
000300     05  ORD-DATA                PIC  9(03).
000310     05  OUT02-CRLF              PIC  X(02).
000320
000330
000340  WORKING-STORAGE SECTION.
000350  01  IX                          PIC  9(003).
000360******************************************************************
000370  PROCEDURE               DIVISION.
000380*
000390     OPEN         OUTPUT          OUT01.
000400*
000410     MOVE    1                    TO  IX.
000420     PERFORM      256 TIMES
000430         MOVE  FUNCTION  CHAR(IX) TO  OUT01-DATA
000440         WRITE    OUT01-AREA
000450         ADD      1               TO  IX   
000460     END-PERFORM.
000470     CLOSE                        OUT01.
000480
000490*
000500     OPEN         INPUT           IN01.
000510     OPEN         OUTPUT          OUT02. 
000520     PERFORM      256 TIMES
000530          READ  IN01
000540          COMPUTE  ORD-DATA  =  FUNCTION ORD(IN01-DATA)
000550          MOVE    X'0D0A'         TO   OUT02-CRLF
000560          WRITE   OUT02-AREA   
000570     END-PERFORM.
000580*
000590     CLOSE                        IN01.
000600     CLOSE                        OUT02.
000610     GOBACK.

 

COBOL ORD関数を使ってみた。

COBOL ORD関数を使ってみた。

0スタートではなく,1スタート
EXCEL =CODE("A") は、65だが、COBOL ORD関数では、66。
使用することもないと思う。初めて使いました。

EBCDIC EBCDIKでは、結果が変わると思います。
FUJITSU COBOL85使用。

000010 IDENTIFICATION           DIVISION.
000020 PROGRAM-ID.              CNT001.
000030*
000040 ENVIRONMENT                     DIVISION.
000050 CONFIGURATION                   SECTION.
000060 SOURCE-COMPUTER.                COBOL85.
000070 OBJECT-COMPUTER.                COBOL85.
000080*
000090 INPUT-OUTPUT                    SECTION. 
000100  FILE-CONTROL.                
000110*    SELECT  IN01     ASSIGN  TO  "E:\COBDAT\CNT0091.TXT".
000120     SELECT  OUT      ASSIGN  TO  "C:\FSC\TEST\TESTORD\TESTORD.TXT".
000130*
000140 DATA                            DIVISION.
000150 FILE                            SECTION.
000160*FD  IN01.
000170* 01  IN01-AREA.
000180*     05  IN01-REC                PIC  X(01).
000190*
000200 FD  OUT.
000210*     BLOCK      CONTAINS  0      RECORD  
000220*     LABEL      RECORD   IS      STANDARD.
000230 01  OUT-AREA.
000240     05  OUT-QT1                  PIC  X(01).
000250     05  OUT-DATA                 PIC  X(01).
000260     05  OUT-QT2                  PIC  X(01).
000270     05  OUT-EQ                   PIC  X(01).
000280     05  OUT-AAA                  PIC  9(04).
000290     05  OUT-CRLF                 PIC  X(02).
000300*
000310  WORKING-STORAGE SECTION.
000320  01  DATA-A.
000330      05  DATA-9                  PIC  9(004)  COMP
000340                                  OCCURS 256 TIMES.
000350  01  DATA-B      REDEFINES       DATA-A.
000360      05  DATA-CHAR               OCCURS 256 TIMES.
000370          10  DATA-HIG            PIC  X(001).    
000380          10  DATA-LOW            PIC  X(001).
000390*
000400  01  CNT1                        PIC  9(005) VALUE 255.
000410  01  CNT2                        PIC S9(004) COMP-3.
000420  01  CNT3                        PIC S9(004) COMP.
000430*
000440  01  IX                          PIC  9(004) COMP.
000450  01  CNTA                        PIC  9(004) COMP.
000460  01  DISP-AAA                    PIC  9(004).             
000470******************************************************************
000480  PROCEDURE               DIVISION.
000490
000500     DISPLAY      CNT1.
000510     MOVE         CNT1            TO  CNT2 CNT3.
000520     DISPLAY      CNT2.
000530     DISPLAY      CNT3.
000540*
000550     COMPUTE DISP-AAA  =  FUNCTION ORD ("A")
000560     DISPLAY      DISP-AAA        UPON  SYSOUT.
000570*
000580     COMPUTE DISP-AAA  =  FUNCTION ORD-MAX (3.4 5 6.2 9)
000590     DISPLAY      DISP-AAA.
000600*
000610*     OPEN         INPUT           IN01
000620     OPEN         OUTPUT          OUT.
000630*
000640     MOVE         ZERO            TO  CNTA.
000650     PERFORM      VARYING  IX  FROM  1  BY  1
000660                               UNTIL IX  >  256
000670         MOVE     CNTA            TO  DATA-9(IX)
000680         ADD      1               TO  CNTA
000690     END-PERFORM.
000700*
000710     PERFORM      VARYING  IX  FROM  1  BY  1
000720                               UNTIL IX > 256
000730         COMPUTE  DISP-AAA  =  FUNCTION ORD(DATA-LOW(IX))
000740*         DISPLAY  '"' DATA-LOW(IX) '="' DISP-AAA
000750*                                  UPON   SYSOUT
000760         MOVE     SPACE           TO  OUT-AREA
000770         MOVE     '"'             TO  OUT-QT1
000780         MOVE     DATA-LOW(IX)    TO  OUT-DATA
000790         MOVE     '"'             TO  OUT-QT2
000800         MOVE     '='             TO  OUT-EQ
000810         MOVE     DISP-AAA        TO  OUT-AAA
000820         MOVE     X'0D0A'         TO  OUT-CRLF
000830         WRITE                    OUT-AREA
000840     END-PERFORM.
000850*
000860*     CLOSE                        IN01
000870     CLOSE                        OUT.
000880* 
000890     GOBACK.


 

 

" "=0001
" "=0002
""=0003

" "=0033
"!"=0034
"""=0035
"#"=0036
"$"=0037
"%"=0038
"&"=0039
"'"=0040
"("=0041
")"=0042
"*"=0043
"+"=0044
","=0045
"-"=0046
"."=0047
"/"=0048
"0"=0049
"1"=0050
"2"=0051
"3"=0052
"4"=0053
"5"=0054
"6"=0055
"7"=0056
"8"=0057
"9"=0058
":"=0059
";"=0060
"<"=0061
"="=0062
">"=0063
"?"=0064
"@"=0065
"A"=0066
"B"=0067
"C"=0068
"D"=0069
"E"=0070
"F"=0071
"G"=0072
"H"=0073
"I"=0074
"J"=0075
"K"=0076
"L"=0077
"M"=0078
"N"=0079
"O"=0080
"P"=0081
"Q"=0082
"R"=0083
"S"=0084
"T"=0085
"U"=0086
"V"=0087
"W"=0088
"X"=0089
"Y"=0090
"Z"=0091
"["=0092
"\"=0093
"]"=0094
"^"=0095
"_"=0096
"`"=0097
"a"=0098
"b"=0099
"c"=0100
"d"=0101
"e"=0102
"f"=0103
"g"=0104
"h"=0105
"i"=0106
"j"=0107
"k"=0108
"l"=0109
"m"=0110
"n"=0111
"o"=0112
"p"=0113
"q"=0114
"r"=0115
"s"=0116
"t"=0117
"u"=0118
"v"=0119
"w"=0120
"x"=0121
"y"=0122
"z"=0123
"{"=0124
"|"=0125
"}"=0126
"~"=0127
""=0128

" "=0161
"。"=0162
"「"=0163
"」"=0164
"、"=0165
"・"=0166
"ヲ"=0167
"ァ"=0168
"ィ"=0169
"ゥ"=0170
"ェ"=0171
"ォ"=0172
"ャ"=0173
"ュ"=0174
"ョ"=0175
"ッ"=0176
"ー"=0177
"ア"=0178
"イ"=0179
"ウ"=0180
"エ"=0181
"オ"=0182
"カ"=0183
"キ"=0184
"ク"=0185
"ケ"=0186
"コ"=0187
"サ"=0188
"シ"=0189
"ス"=0190
"セ"=0191
"ソ"=0192
"タ"=0193
"チ"=0194
"ツ"=0195
"テ"=0196
"ト"=0197
"ナ"=0198
"ニ"=0199
"ヌ"=0200
"ネ"=0201
"ノ"=0202
"ハ"=0203
"ヒ"=0204
"フ"=0205
"ヘ"=0206
"ホ"=0207
"マ"=0208
"ミ"=0209
"ム"=0210
"メ"=0211
"モ"=0212
"ヤ"=0213
"ユ"=0214
"ヨ"=0215
"ラ"=0216
"リ"=0217
"ル"=0218
"レ"=0219
"ロ"=0220
"ワ"=0221
"ン"=0222
"゛"=0223
"゜"=0224
" "=0225

" "=0255
" "=0256

なんとか理解できました。あるCOBOLロジック。

COBOL General discussion - Difficult recognizable tricks in COBOL -

http://www.tek-tips.com/viewthread.cfm?qid=839069&page=1

のあるロジックを試してみました。少し改変しています。

 IDENTIFICATION            DIVISION.
 PROGRAM-ID                BITONOFF.
*
 DATA                      DIVISION.
 WORKING-STORAGE           SECTION.
 01  WS-WORK-AREAS.
*
*       変更ＢＩＴ位置の指定  X'??'=B'12345678'
*                             左から１～８
     05  BIT-NBR                   PIC  9(04) COMP.
*
*        BIT ON/OFF用データ
*            変更用データから足し引きする為の値
     05  BIT-FLIPPER.
         10  BIT-FLIPPER-NUM       PIC  9(04) COMP VALUE 0.
*
     05  FLD-1.
         10  FILLER                PIC  X(01).
         10  1ST-CHK-BYTE          PIC  X(01).
             88  CHK-BIT-IS-ON     VALUE X'80' THRU X'FF'.
             88  CHK-BIT-IS-OFF    VALUE X'00' THRU X'7F'.
*        確認用データ
     05  CHK-BITS      REDEFINES   FLD-1.
         10  CHK-BITS-NUM          PIC  9(04) COMP.
*
*        変更用データ
     05  CHG-BITS.
         10  CHG-BITS-NUM          PIC  9(04) COMP.
*
*        シフト用テーブル
     05  BIT-SHIFT-VALUES.
*        X'??'=B'12345678'
*                |  |   |---X'80'の位置にするには、掛ける*128
*                |  |-------X'80'の位置にするには、掛ける*008
*                |----------X'80'の位置にするには、掛ける*001
         10  BIT-1                 PIC  9(04) COMP VALUE   1.
         10  BIT-2                 PIC  9(04) COMP VALUE   2.
         10  BIT-3                 PIC  9(04) COMP VALUE   4.
         10  BIT-4                 PIC  9(04) COMP VALUE   8.
         10  BIT-5                 PIC  9(04) COMP VALUE  16.
         10  BIT-6                 PIC  9(04) COMP VALUE  32.
         10  BIT-7                 PIC  9(04) COMP VALUE  64.
         10  BIT-8                 PIC  9(04) COMP VALUE 128.
     05  BIT-SHIFT-TBL REDEFINES   BIT-SHIFT-VALUES.
         10  SHIFT-ENT             PIC  9(04) COMP
                                   OCCURS 8.
*       結果出力用データ
     05  KEKKA                     PIC  X(01).
 01  TBL-HEX.
     05  FILLER                  PIC  X(001)  VALUE  '0'.
     05  FILLER                  PIC  X(004)  VALUE  '0000'.
     05  FILLER                  PIC  X(001)  VALUE  '1'.
     05  FILLER                  PIC  X(004)  VALUE  '0001'.
     05  FILLER                  PIC  X(001)  VALUE  '2'.
     05  FILLER                  PIC  X(004)  VALUE  '0010'.
     05  FILLER                  PIC  X(001)  VALUE  '3'.
     05  FILLER                  PIC  X(004)  VALUE  '0011'.
     05  FILLER                  PIC  X(001)  VALUE  '4'.
     05  FILLER                  PIC  X(004)  VALUE  '0100'.
     05  FILLER                  PIC  X(001)  VALUE  '5'.
     05  FILLER                  PIC  X(004)  VALUE  '0101'.
     05  FILLER                  PIC  X(001)  VALUE  '6'.
     05  FILLER                  PIC  X(004)  VALUE  '0110'.
     05  FILLER                  PIC  X(001)  VALUE  '7'.
     05  FILLER                  PIC  X(004)  VALUE  '0111'.
     05  FILLER                  PIC  X(001)  VALUE  '8'.
     05  FILLER                  PIC  X(004)  VALUE  '1000'.
     05  FILLER                  PIC  X(001)  VALUE  '9'.
     05  FILLER                  PIC  X(004)  VALUE  '1001'.
     05  FILLER                  PIC  X(001)  VALUE  'A'.
     05  FILLER                  PIC  X(004)  VALUE  '1010'.
     05  FILLER                  PIC  X(001)  VALUE  'B'.
     05  FILLER                  PIC  X(004)  VALUE  '1011'.
     05  FILLER                  PIC  X(001)  VALUE  'C'.
     05  FILLER                  PIC  X(004)  VALUE  '1100'.
     05  FILLER                  PIC  X(001)  VALUE  'D'.
     05  FILLER                  PIC  X(004)  VALUE  '1101'.
     05  FILLER                  PIC  X(001)  VALUE  'E'.
     05  FILLER                  PIC  X(004)  VALUE  '1110'.
     05  FILLER                  PIC  X(001)  VALUE  'F'.
     05  FILLER                  PIC  X(004)  VALUE  '1111'.
*
 01  TBL-HEX-R                   REDEFINES    TBL-HEX.
     05  TBLHEX      OCCURS      16  TIMES.
         10  T-HEX               PIC  X(001).
         10  T-BIT               PIC  X(004).
*
 01  CONV-BIT.
     05  CNV-BIT-LV              PIC  X(001).
     05  CNV-BIT-CHR             PIC  X(001).
 01  CONV-BIT-R                  REDEFINES   CONV-BIT.
     05  CNV-BIN                 PIC  9(004) COMP.
*
 01  IX-UP                       PIC  9(004) COMP.
 01  IX-DW                       PIC  9(004) COMP.
*
 01  WK-BIT-EDIT.
     05  WK-BIT-UP               PIC  X(004).
     05  WK-BIT-DW               PIC  X(004).
*
 01  WK-HEX-EDIT.
     05  WK-HEX-UP               PIC  X(001).
     05  WK-HEX-DW               PIC  X(001).
*
*
*
 PROCEDURE                 DIVISION.
*   CHK-BITは対象BIT ON/OFFの確認用
*   CHG-BITは対象BIT ON/OFFの変更用
*    MOVE    your data             TO  CHK-BITS(2:1)
*                                      CHG-BITS(2:1).
*            your dataをX'FF'で試行
     MOVE    X'FF'                 TO  CHK-BITS(2:1)
                                       CHG-BITS(2:1).
     MOVE    LOW-VALUE             TO  CHK-BITS(1:1)
                                       CHG-BITS(1:1).
*
*    X(01)=B'???1????'をOFFしてみる
*    変更BIT位置を指定 X(01)=B'12345678'、
*                   BIT NBR = 4で試行
*    MOVE    BIT NBR               TO  BIT-NBR.
     MOVE    4                     TO  BIT-NBR.
*
*    BIT ON/OFF値初期化
     MOVE    X'00'                 TO  BIT-FLIPPER(1:1)
     MOVE    X'80'                 TO  BIT-FLIPPER(2:1)
*
*    確認用データ
*        対象BITをB'12345678' 1の位置にする
*        この場合X'10'をX'80'にする
     COMPUTE  CHK-BITS-NUM         =   CHK-BITS-NUM
                                   *   SHIFT-ENT(BIT-NBR).
*    BIT ON/OFF用データ
*      BIT ON/OFFを変更BITの場所に合わせる
*      この場合X'80'=B'10000000'をX'10'=B'00010000'
     COMPUTE  BIT-FLIPPER-NUM      =   BIT-FLIPPER-NUM
                                   /   SHIFT-ENT(BIT-NBR).

     EVALUATE TRUE
     WHEN  CHK-BIT-IS-ON
*          変更BITをX'80'位置にした確認用データがＯＮの時
*              CHG-BITの変更BIT ONなので、引く(OFF)する
*
           SUBTRACT  BIT-FLIPPER-NUM   FROM  CHG-BITS-NUM
*
     WHEN  CHK-BIT-IS-OFF
*          変更BITをX'80'位置にした確認用データがＯＦＦの時
*              CHG-BITの変更BIT OFFなので、足す(ON)する
*
           ADD       BIT-FLIPPER-NUM   TO    CHG-BITS-NUM
*
     WHEN  OTHER
           DISPLAY 'HOUSTON WE HAVE A PROBLEM'
           STOP RUN
     END-EVALUATE.
*
*    MOVE  CHG-BITS(2:1)   TO  your receiving area.
     MOVE  CHG-BITS(2:1)   TO  KEKKA
                               CNV-BIT-CHR.
     PERFORM     BIN2HEX-SUB   THRU    BIN2HEX-SUB-EXT.
*
     DISPLAY 'KEKKA="'  KEKKA  '"'   UPON  SYSOUT.
     DISPLAY 'KEKKA="'  WK-HEX-EDIT '-' WK-BIT-EDIT  '"'
                                     UPON  SYSOUT.

     GOBACK.
****************************************************************
*                                                              *
****************************************************************
 BIN2HEX-SUB.
     MOVE        LOW-VALUE       TO      CNV-BIT-LV.
     MOVE        ZERO            TO      IX-UP.
     MOVE        ZERO            TO      IX-DW.
*
     DIVIDE      16              INTO    CNV-BIN
                                 GIVING      IX-UP
                                 REMAINDER   IX-DW
*
     MOVE    T-BIT(IX-UP + 1)    TO      WK-BIT-UP.
     MOVE    T-BIT(IX-DW + 1)    TO      WK-BIT-DW.
*
     MOVE    T-HEX(IX-UP + 1)    TO      WK-HEX-UP.
     MOVE    T-HEX(IX-DW + 1)    TO      WK-HEX-DW.
*
 BIN2HEX-SUB-EXT.
     EXIT.

FUJITSU　COBOL85使用

＜2011/05/18 追記 START＞
IBM汎用機では

CHK-BITS-NUM の COMP を COMP-5にすれば、

000220*        確認用データ
000230     05  CHK-BITS      REDEFINES   FLD-1.
000240         10  CHK-BITS-NUM          PIC  9(04) COMP-5.

BIT-NBR 7,8 を　BIT-NBR 1(X'80')位置に
内容を壊さずにシフトできるので、
このロジックでも7,8位置のBIT ON/OFFは可能になります。

一般的なCOMP系の説明
＠IT（アットマーク・アイティ）
＠IT総合トップ ＞ ＠IT CORE ＞ Coding Edge ＞  これであなたもCOBOLプログラマ 
第2回 これであなたもCOBOLプログラマ
http://www.atmarkit.co.jp/fcoding/articles/cobol/02/cobol02b.html

COMP-5の説明。
http://dai2rou.web.fc2.com/cobol.html
「だいたいこんな感じ」様

S9(桁) ,9(桁)に　COMP-5 をつけた時の数値範囲
http://plaza.rakuten.co.jp/u703331/diary/200705220001/
「さすらいのプログラマ」様

  COMPのみだと
  計算で桁数（この場合４桁）を超えても、桁数に収めて再格納します。

  B"12345678"(数値は位置、実際は1or0)
    1の位置に乗算で左シフトしたとき

    6位置 255 × 032 =  8160 は４桁SAFE
    7位置 255 × 064 = 16320 は５桁OUT
    16320
         00111111-11000000 だが
     6320で格納される
         00011000-10110000 =>9(04) COMP
         内容が壊れます。
    8位置 255 × 128 = 32640 は５桁OUT
    32640
         1111111-10000000 だが
     2640で格納
         00001010-01010000 =>9(04) COMP
         内容が壊れます。
＜END＞

COBOL85でBITシフト

①COBOL85でBITシフト

000010 IDENTIFICATION                  DIVISION.
000020 PROGRAM-ID.                     BITSHIFT.
000030*
000040 ENVIRONMENT                     DIVISION.
000050 INPUT-OUTPUT                    SECTION.
000060 FILE-CONTROL.
000070*    SELECT      INA             ASSIGN      TO  COBIN.  
000080*    SELECT      OUT             ASSIGN      TO  COBOT.
000090*
000100 DATA                            DIVISION.
000110 FILE                            SECTION.
000120*FD  INA
000130*    LABEL       RECORD          IS  STANDARD
000140*    RECORDING   MODE            F.
000150*01  IN-REC                      PIC  X(080).
000160*
000170*FD  INA
000180*    LABEL       RECORD          IS  STANDARD
000190*    RECORDING   MODE            F.
000200*01  OUT-REC                     PIC  X(080).
000210*
000220 WORKING-STORAGE                 SECTION.
000230*
000240 01  TCOMP-A                     PIC  9(004) COMP.
000250 01  FILLER  REDEFINES           TCOMP-A.
000260     05  XBIT-00A                PIC  X(001).
000270     05  XBIT-A                  PIC  X(001).
000280*
000290 01  TCOMP-B                     PIC  9(004) COMP.
000300 01  FILLER  REDEFINES           TCOMP-B.
000310     05  XBIT-00B                PIC  X(001).
000320     05  XBIT-B                  PIC  X(001).
000330*
000340 01  TCOMP-C                     PIC  9(004) COMP.
000350 01  FILLER  REDEFINES           TCOMP-C.
000360     05  XBIT-00C                PIC  X(001).
000370     05  XBIT-C                  PIC  X(001).
000380*
000390 01  TBL-HEX.
000400     05  FILLER                  PIC  X(001)  VALUE  '0'.
000410     05  FILLER                  PIC  X(004)  VALUE  '0000'.
000420     05  FILLER                  PIC  X(001)  VALUE  '1'.
000430     05  FILLER                  PIC  X(004)  VALUE  '0001'.
000440     05  FILLER                  PIC  X(001)  VALUE  '2'.
000450     05  FILLER                  PIC  X(004)  VALUE  '0010'.
000460     05  FILLER                  PIC  X(001)  VALUE  '3'.
000470     05  FILLER                  PIC  X(004)  VALUE  '0011'.
000480     05  FILLER                  PIC  X(001)  VALUE  '4'.
000490     05  FILLER                  PIC  X(004)  VALUE  '0100'.
000500     05  FILLER                  PIC  X(001)  VALUE  '5'.
000510     05  FILLER                  PIC  X(004)  VALUE  '0101'.
000520     05  FILLER                  PIC  X(001)  VALUE  '6'.
000530     05  FILLER                  PIC  X(004)  VALUE  '0110'.
000540     05  FILLER                  PIC  X(001)  VALUE  '7'.
000550     05  FILLER                  PIC  X(004)  VALUE  '0111'.
000560     05  FILLER                  PIC  X(001)  VALUE  '8'.
000570     05  FILLER                  PIC  X(004)  VALUE  '1000'.
000580     05  FILLER                  PIC  X(001)  VALUE  '9'.
000590     05  FILLER                  PIC  X(004)  VALUE  '1001'.
000600     05  FILLER                  PIC  X(001)  VALUE  'A'.
000610     05  FILLER                  PIC  X(004)  VALUE  '1010'.
000620     05  FILLER                  PIC  X(001)  VALUE  'B'.
000630     05  FILLER                  PIC  X(004)  VALUE  '1011'.
000640     05  FILLER                  PIC  X(001)  VALUE  'C'.
000650     05  FILLER                  PIC  X(004)  VALUE  '1100'.
000660     05  FILLER                  PIC  X(001)  VALUE  'D'.
000670     05  FILLER                  PIC  X(004)  VALUE  '1101'.
000680     05  FILLER                  PIC  X(001)  VALUE  'E'.
000690     05  FILLER                  PIC  X(004)  VALUE  '1110'.
000700     05  FILLER                  PIC  X(001)  VALUE  'F'.
000710     05  FILLER                  PIC  X(004)  VALUE  '1111'.
000720*
000730 01  TBL-HEX-R                   REDEFINES    TBL-HEX.
000740     05  TBLHEX      OCCURS      16  TIMES.
000750         10  T-HEX               PIC  X(001).
000760         10  T-BIT               PIC  X(004).
000770*
000780 01  CONV-BIT.
000790     05  CNV-BIT-LV              PIC  X(001).
000800     05  CNV-BIT-CHR             PIC  X(001).
000810 01  CONV-BIT-R                  REDEFINES   CONV-BIT.
000820     05  CNV-BIN                 PIC  9(004) COMP.
000830*
000840 01  IX-UP                       PIC  9(004) COMP.
000850 01  IX-DW                       PIC  9(004) COMP.
000860*
000870 01  WK-BIT-EDIT.
000880     05  WK-BIT-UP               PIC  X(004).
000890     05  WK-BIT-DW               PIC  X(004).
000900*
000910 01  WK-HEX-EDIT.
000920     05  WK-HEX-UP               PIC  X(001).
000930     05  WK-HEX-DW               PIC  X(001).
000940*
000950*01  EOF-FLG                     PIC  X(001)  VALUE '0'.
000960****************************************************************
000970*                                                              *
000980****************************************************************
000990 PROCEDURE                       DIVISION.
001000*    OPEN    INPUT               INA.
001010*            OUTPUT              OUT.
001020*
001030*****MOVE    255                 TO      TCOMP-A.
001040*            ↓ここにSET
001050     MOVE    X'FF'               TO      XBIT-A.
001060     MOVE    LOW-VALUE           TO      XBIT-00A.
001070*
001080     MOVE    XBIT-A              TO      CNV-BIT-CHR.
001090     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001100*
001110     DISPLAY     'XBIT-A="'      XBIT-A  '"'
001120                                 UPON    SYSOUT.
001130     DISPLAY     'XBIT-A="'      WK-HEX-EDIT '-' WK-BIT-EDIT
001140                                 UPON    SYSOUT.
001150*
001160*左シフト
001170     COMPUTE     TCOMP-B =   TCOMP-A     *   16.
001180     MOVE    X'00'               TO      XBIT-00B.
001190     MOVE    XBIT-B              TO      CNV-BIT-CHR.
001200     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001210*
001220     DISPLAY     'XBIT-B="'      XBIT-B  '"'
001230                                 UPON    SYSOUT.
001240     DISPLAY     'XBIT-B="'      WK-HEX-EDIT '-' WK-BIT-EDIT
001250                                 UPON    SYSOUT.
001260*
001270*右シフト
001280     COMPUTE     TCOMP-C =   TCOMP-A     /   16.
001290     MOVE    X'00'               TO      XBIT-00C.
001300     MOVE    XBIT-C              TO      CNV-BIT-CHR.
001310     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001320*
001330     DISPLAY     'XBIT-C="'      XBIT-C  '"'
001340                                 UPON    SYSOUT.
001350     DISPLAY     'XBIT-C="'      WK-HEX-EDIT '-' WK-BIT-EDIT
001360                                 UPON    SYSOUT.
001370*
001380*    CLOSE                      INA.
001390*                               OUT.
001400     GOBACK
001410****************************************************************
001420*                                                              *
001430****************************************************************
001440 BIN2HEX-SUB.
001450     MOVE        LOW-VALUE       TO      CNV-BIT-LV.
001460     MOVE        ZERO            TO      IX-UP.
001470     MOVE        ZERO            TO      IX-DW.
001480*
001490     DIVIDE      16              INTO    CNV-BIN
001500                                 GIVING      IX-UP
001510                                 REMAINDER   IX-DW
001520*
001530     MOVE    T-BIT(IX-UP + 1)    TO      WK-BIT-UP.
001540     MOVE    T-BIT(IX-DW + 1)    TO      WK-BIT-DW.
001550*
001560     MOVE    T-HEX(IX-UP + 1)    TO      WK-HEX-UP.
001570     MOVE    T-HEX(IX-DW + 1)    TO      WK-HEX-DW.
001580*
001590 BIN2HEX-SUB-EXT.
001600     EXIT.
001610

②シフトして空いた所、にBITを立ててみる
　　（件数は、大体X'00'ですが。）

000990 PROCEDURE                       DIVISION.
001000*
001010*右２bitシフトして空いた上位bitに
001020*例えばアクセス件数
001030*      本日　X'00'…50件以下               =000
001040*      本日　X'01'…50件超～100件以下      =064
001050*      本日　X'10'…100件件超～500件以下   =128
001060*      本日　X'11'…500件超                =192
001070* を立てるとする。
001080     MOVE        255             TO      TCOMP-A.
001090     COMPUTE     TCOMP-C =   TCOMP-A     /   4.
001100     COMPUTE     TCOMP-C =   TCOMP-C     +   0
001110     MOVE    X'00'               TO      XBIT-00C.
001120     MOVE    XBIT-C              TO      CNV-BIT-CHR.
001130     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001140*
001150     DISPLAY     '* 本日　X'00'…50件以下               =000'
001160                                 UPON    SYSOUT.
001170     DISPLAY     'XBIT-C='       XBIT-C  '"'
001180                                 UPON    SYSOUT.
001190     DISPLAY     'XBIT-C='       WK-HEX-EDIT '-' WK-BIT-EDIT
001200                                 UPON    SYSOUT.
001210*
001220****************************************************************
001230     COMPUTE     TCOMP-C =   TCOMP-A     /   4.
001240     COMPUTE     TCOMP-C =   TCOMP-C     +  64.
001250     MOVE    X'00'               TO      XBIT-00C.
001260     MOVE    XBIT-C              TO      CNV-BIT-CHR.
001270     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001280*
001290     DISPLAY     '* 本日　X'01'…50件超～100件以下      =064'
001300                                 UPON    SYSOUT.
001310     DISPLAY     'XBIT-C='       XBIT-C  '"'
001320                                 UPON    SYSOUT.
001330     DISPLAY     'XBIT-C='       WK-HEX-EDIT '-' WK-BIT-EDIT
001340                                 UPON    SYSOUT.
001350*
001360****************************************************************
001370     COMPUTE     TCOMP-C =   TCOMP-A     /   4.
001380     COMPUTE     TCOMP-C =   TCOMP-C     + 128.
001390     MOVE    X'00'               TO      XBIT-00C.
001400     MOVE    XBIT-C              TO      CNV-BIT-CHR.
001410     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001420*
001430     DISPLAY     '* 本日　X'10'…100件件超～500件以下   =128'
001440                                 UPON    SYSOUT.
001450     DISPLAY     'XBIT-C='       XBIT-C  '"'
001460                                 UPON    SYSOUT.
001470     DISPLAY     'XBIT-C='       WK-HEX-EDIT '-' WK-BIT-EDIT
001480                                 UPON    SYSOUT.
001490****************************************************************
001500     COMPUTE     TCOMP-C =   TCOMP-A     /   4.
001510     COMPUTE     TCOMP-C =   TCOMP-C     + 192.
001520     MOVE    X'00'               TO      XBIT-00C.
001530     MOVE    XBIT-C              TO      CNV-BIT-CHR.
001540     PERFORM     BIN2HEX-SUB     THRU    BIN2HEX-SUB-EXT.
001550*
001560     DISPLAY     '* 本日　X'11'…500件超                =192'
001570                                 UPON    SYSOUT.
001580     DISPLAY     'XBIT-C='       XBIT-C  '"'
001590                                 UPON    SYSOUT.
001600     DISPLAY     'XBIT-C='       WK-HEX-EDIT '-' WK-BIT-EDIT
001610                                 UPON    SYSOUT.
001620*
001630     GOBACK.

 

＜2011/05/18 追記 START＞
左６シフト *  64
左７シフト * 128
は内容が壊れます。
  COMPだと
  計算で範囲を超えても、桁数に収めて再格納します。
  左５シフト *  32
          255 × 032 =  8160 は４桁SAFE
  左６シフト *  64
          255 × 064 = 16320 は５桁OUT
    16320
         00111111-11000000 だが
     6320で格納される
         00011000-10110000 =>9(04) COMP
         内容が壊れます。
  左７シフト * 128
         255 × 128 = 32640 は５桁OUT
    32640
         1111111-10000000 だが
     2640で格納
         00001010-01010000 =>9(04) COMP
         内容が壊れます。
＜END＞

 

COBOL BIT操作 その４

＜その４＞

　　　＜その１＞の別法
C'11110000'(８バイト)  を  X'F0'(1バイト)

C'00110001'(８バイト)  を  X'31'(1バイト)

にします。

000010*BIT形式のキャラクタ８バイトを１バイトにする。
000020 IDENTIFICATION                  DIVISION.
000030 PROGRAM-ID.                     TEST10.
000040 ENVIRONMENT                     DIVISION.
000050 INPUT-OUTPUT SECTION.
000060 FILE-CONTROL.
000070     SELECT  IN-FILE     ASSIGN  TO  'TEST10.IN.DAT'.
000080     SELECT  OUT-FILE   ?ASSIGN  TO  'TEST10.OUT.DAT'.
000090 DATA                            DIVISION.
000100 FILE SECTION.
000110 FD  IN-FILE.
000120 01  IN-REC.
000130     05  IN-DATA.
000131         10 IN-DATA-64           PIC X(002).
000132         10 IN-DATA-16           PIC X(002).
000133         10 IN-DATA-04           PIC X(002).
000134         10 IN-DATA-01           PIC X(002).
000140     05  IN-CRLF                 PIC X(002).
000150*
000160 FD  OUT-FILE.
000170 01  OUT-REC.
000180     05  OUT-DATA                PIC X(001).
000190*
000200 WORKING-STORAGE SECTION.
000210*
000220 01  WORK-AREA.
000230     05  WORK-CHAR8.
000240         10  W-CHAR              PIC  X(001)  OCCURS 8.
000250*
000260     05  WORK-HEX                PIC  9(004)  COMP.
000270*
000280 01  HEX-CHANGE-BEFORE           PIC  9(004) COMP.
000290 01  HEX-CHG-AFT     REDEFINES   HEX-CHANGE-BEFORE.
000300     05  FILLER                  PIC  X(001).
000310     05  HEX-CHANGE-AFTER        PIC  X(001).
000320*
000330 01  END-FLG                     PIC  X(001)  VALUE '0'.
000340*
000350 01  WK-CURRENT-STA              PIC  X(021).
000351 01  WK-CURRENT-END              PIC  X(021).
000352*
000353 PROCEDURE                       DIVISION.
000360 MAIN-CONTROL.
000370*
000380     MOVE    FUNCTION    CURRENT-DATE    TO  WK-CURRENT-STA.
000381     PERFORM                     INIT-RTN.
000390*
000400     PERFORM     UNTIL   END-FLG =  "1"
000410         PERFORM                 MAIN-RTN
000420     END-PERFORM.
000430*
000440     PERFORM                     TERM-RTN.
000450*
000451     MOVE   FUNCTION     CURRENT-DATE    TO  WK-CURRENT-END.
000452*
000453     DISPLAY   'E N D='  WK-CURRENT-END  UPON  SYSOUT.
000454     DISPLAY   'START='  WK-CURRENT-STA  UPON  SYSOUT.
000455*
000460     STOP RUN.
000470*
000480******************************************************************
000490*                                                                *
000500******************************************************************
000510 INIT-RTN.
000520     OPEN    INPUT               IN-FILE.
000530     OPEN    OUTPUT              OUT-FILE.
000540*
000550     PERFORM                     READ-RTN.
000560*
000570******************************************************************
000580*                                                                *
000590******************************************************************
000600 MAIN-RTN.
000610*
000620     MOVE        IN-DATA         TO      WORK-CHAR8.
000630     MOVE        ZERO            TO      WORK-HEX.
000640*
000641*
000650     IF          IN-DATA-64      =       '00'
000660             ADD         0       TO      WORK-HEX
000670     ELSE
000690       IF        IN-DATA-64      =       '01'
000691             ADD        64       TO      WORK-HEX
000692       ELSE
000693         IF      IN-DATA-64      =       '10'
000700             ADD       128       TO      WORK-HEX
000701         ELSE
000702           IF    IN-DATA-64      =       '11'
000703             ADD       192       TO      WORK-HEX
000704           END-IF
000705         END-IF
000706       END-IF
000707     END-IF.
000710*
000711*
000712     IF          IN-DATA-16      =       '00'
000713             ADD         0       TO      WORK-HEX
000714     ELSE
000715       IF        IN-DATA-16      =       '01'
000716             ADD        16       TO      WORK-HEX
000717       ELSE
000718         IF      IN-DATA-16      =       '10'
000719             ADD        32       TO      WORK-HEX
000720         ELSE
000721           IF    IN-DATA-16      =       '11'
000722             ADD        48       TO      WORK-HEX
000723           END-IF
000724         END-IF
000725       END-IF
000726     END-IF.
000727*
000728*
000729     IF          IN-DATA-04      =       '00'
000730             ADD         0       TO      WORK-HEX
000731     ELSE
000732       IF        IN-DATA-04      =       '01'
000733             ADD         4       TO      WORK-HEX
000734       ELSE
000735         IF      IN-DATA-04      =       '10'
000736             ADD         8       TO      WORK-HEX
000737         ELSE
000738           IF    IN-DATA-04      =       '11'
000739             ADD        12       TO      WORK-HEX
000740           END-IF
000741         END-IF
000742       END-IF
000743     END-IF.
000744*
000745     IF          IN-DATA-01      =       '00'
000746             ADD         0       TO      WORK-HEX
000747     ELSE
000748       IF        IN-DATA-01      =       '01'
000749             ADD         1       TO      WORK-HEX
000750       ELSE
000751         IF      IN-DATA-01      =       '10'
000752             ADD         2       TO      WORK-HEX
000753         ELSE
000754           IF    IN-DATA-04      =       '11'
000755             ADD         3       TO      WORK-HEX
000756           END-IF
000757         END-IF
000758       END-IF
000759     END-IF.
000761*
001200*
001210     MOVE    WORK-HEX            TO      HEX-CHANGE-BEFORE.
001220     WRITE   OUT-REC             FROM    HEX-CHANGE-AFTER.
001230*
001240     PERFORM                     READ-RTN.
001250*
001260******************************************************************
001270*                                                                *
001280******************************************************************
001290 READ-RTN.
001300     READ    IN-FILE     AT  END
001310         MOVE    '1'             TO      END-FLG
001320     END-READ.
001330*
001340******************************************************************
001350*                                                                *
001360******************************************************************
001370 TERM-RTN.
001380     CLOSE                       IN-FILE
001390                                 OUT-FILE.