000010 IDENTIFICATION DIVISION.
000020*******************************************************************
000030* *
000040* SJIS TO NEC(INTERNAL(E)) << SJ2NEC >> *
000050* UPDATE : 93/11/25 *
000060*******************************************************************
000070 PROGRAM-ID. SJ2NEC.
000080 ENVIRONMENT DIVISION.
000090 CONFIGURATION SECTION.
000100 SOURCE-COMPUTER. NEC.
000110 OBJECT-COMPUTER. NEC.
000120 INPUT-OUTPUT SECTION.
000130 FILE-CONTROL.
000140 SELECT CIFNEC ASSIGN TO CIFNEC-MSD.
000150 SELECT CIFSJIS ASSIGN TO CIFSJIS-MSD.
000160*
000170 DATA DIVISION.
000180 FILE SECTION.
000190*
000200 FD CIFNEC LABEL RECORD IS STANDARD
000210 BLOCK CONTAINS 16 RECORDS
000220 VALUE OF IDENTIFICATION "CIFNEC".
000230 01 CIFNEC-REC PIC X(80).
000240*
000250 FD CIFSJIS LABEL RECORD IS STANDARD
000260 BLOCK CONTAINS 16 RECORDS
000270 VALUE OF IDENTIFICATION "CIFSJIS".
000280 01 CIFSJIS-REC PIC X(80).
000290*
000300*
000310**************************************************************
000320 WORKING-STORAGE SECTION.
000330**************************************************************
000340 01 WORK-AREA.
000350 03 END-FLG PIC X(03) VALUE SPACE.
000360 01 KASAN PIC 9(5).
000370 01 KASAN2 PIC 9(5).
000380 01 EVEN PIC 9(5).
000390 01 DAI PIC 9(5).
000400 01 CNV-AREA.
000410 03 C1 PIC X(1) OCCURS 256 INDEXED BY C1-IDX.
000420 01 CHKK-AREA.
000430 03 FILLER PIC X(1) VALUE LOW-VALUE.
000440 03 CHKK PIC X(1).
000450 01 CHKK2-AREA REDEFINES CHKK-AREA.
000460 03 CHKK2 USAGE COMP-1.
000470 01 CHKT-AREA.
000480 03 FILLER PIC X(1) VALUE LOW-VALUE.
000490 03 CHKT PIC X(1).
000500 01 CHKT2-AREA REDEFINES CHKT-AREA.
000510 03 CHKT2 USAGE COMP-1.
000520 01 CNV-NUMB PIC 9(4).
000530 01 EJ-TBL.
000540 03 FILLER PIC X(16)
000550 VALUE ""000102039C09867F978D8E0B0C0D0E0F"".
000560 03 FILLER PIC X(16)
000570 VALUE ""101112139D0A08871819928F1C1D1E1F"".
000580 03 FILLER PIC X(16)
000590 VALUE ""808182838485171B88898A8B8C050607"".
000600 03 FILLER PIC X(16)
000610 VALUE ""909116939495960498999A9B14159E1A"".
000620 03 FILLER PIC X(16)
000630 VALUE ""20A1A2A3A4A5A6A7A8A95B2E3C282B21"".
000640 03 FILLER PIC X(16)
000650 VALUE ""26AAABACADAEAF61B0625D5C2A293B5E"".
000660 03 FILLER PIC X(16)
000670 VALUE ""2D2F636465666768696A7C2C255F3E3F"".
000680 03 FILLER PIC X(16)
000690 VALUE ""6B6C6D6E6F70717273603A2340273D22"".
000700 03 FILLER PIC X(16)
000710 VALUE ""74B1B2B3B4B5B6B7B8B9BA75BBBCBDBE"".
000720 03 FILLER PIC X(16)
000730 VALUE ""BFC0C1C2C3C4C5C6C7C8C97677CACBCC"".
000740 03 FILLER PIC X(16)
000750 VALUE ""787ECDCECFD0D1D2D3D4D579D6D7D8D9"".
000760 03 FILLER PIC X(16)
000770 VALUE ""7AA0E0E1E2E3E4E5E6E7DADBDCDDDEDF"".
000780 03 FILLER PIC X(16)
000790 VALUE ""7B414243444546474849E8E9EAEBECED"".
000800 03 FILLER PIC X(16)
000810 VALUE ""7D4A4B4C4D4E4F505152EEEFF0F1F2F3"".
000820 03 FILLER PIC X(16)
000830 VALUE ""249F535455565758595AF4F5F6F7F8F9"".
000840 03 FILLER PIC X(16)
000850 VALUE ""30313233343536373839FAFBFCFDFEFF"".
000860 01 JE-TBL.
000870 03 FILLER PIC X(16)
000880 VALUE ""00010203372D2E2F1605150B0C0D0E0F"".
000890 03 FILLER PIC X(16)
000900 VALUE ""101112133C3D322618193F271C1D1E1F"".
000910 03 FILLER PIC X(16)
000920 VALUE ""404F7F7BE06C507D4D5D5C4E6B604B61"".
000930 03 FILLER PIC X(16)
000940 VALUE ""F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F"".
000950 03 FILLER PIC X(16)
000960 VALUE ""7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6"".
000970 03 FILLER PIC X(16)
000980 VALUE ""D7D8D9E2E3E4E5E6E7E8E94A5B5A5F6D"".
000990 03 FILLER PIC X(16)
001000 VALUE ""79575962636465666768697071727374"".
001010 03 FILLER PIC X(16)
001020 VALUE ""75767778808B9B9CA0ABB0C06AD0A107"".
001030 03 FILLER PIC X(16)
001040 VALUE ""202122232425061728292A2B2C090A1B"".
001050 03 FILLER PIC X(16)
001060 VALUE ""30311A333435360838393A3B04143EE1"".
001070 03 FILLER PIC X(16)
001080 VALUE ""B1414243444546474849515253545556"".
001090 03 FILLER PIC X(16)
001100 VALUE ""588182838485868788898A8C8D8E8F90"".
001110 03 FILLER PIC X(16)
001120 VALUE ""9192939495969798999A9D9E9FA2A3A4"".
001130 03 FILLER PIC X(16)
001140 VALUE ""A5A6A7A8A9AAACADAEAFBABBBCBDBEBF"".
001150 03 FILLER PIC X(16)
001160 VALUE ""B2B3B4B5B6B7B8B9CACBCCCDCECFDADB"".
001170 03 FILLER PIC X(16)
001180 VALUE ""DCDDDEDFEAEBECEDEEEFFAFBFCFDFEFF"".
001190**************************************************************
001200 PROCEDURE DIVISION.
001210**************************************************************
001220 HAJIME.
001230 PERFORM INIT-RTN THRU INIT-EXT.
001240 PERFORM MAIN-RTN THRU MAIN-EXT
001250 UNTIL END-FLG = "END".
001260 PERFORM END-RTN THRU END-EXT.
001270**************************************************************
001280* 初期処理
001290**************************************************************
001300 INIT-RTN.
001310 OPEN INPUT CIFSJIS.
001320 OPEN OUTPUT CIFNEC.
001330 INITIALIZE WORK-AREA.
001340 INIT-EXT.
001350 EXIT.
001360**************************************************************
001370* 主 処理
001380**************************************************************
001390 MAIN-RTN.
001400 READ CIFSJIS AT END MOVE "END" TO END-FLG
001410 GO TO MAIN-EXT.
001420 MOVE 80 TO CNV-NUMB.
001430 MOVE CIFSJIS-REC TO CNV-AREA.
001440 PERFORM JE-RTN THRU JE-EXT.
001450 MOVE CNV-AREA TO CIFNEC-REC.
001460 WRITE CIFNEC-REC.
001470 MAIN-EXT.
001480 EXIT.
001490**************************************************************
001500* 終了処理
001510**************************************************************
001520 END-RTN.
001530 CLOSE CIFNEC CIFSJIS.
001540 STOP RUN.
001550 END-EXT.
001560 EXIT.
001570**************************************************************
001580* NEC-INTERNAL(E) TO SIFT-JIS
001590**************************************************************
001600 EJ-RTN.
001610 CALL "CBLCODE" USING CNV-AREA CNV-NUMB EJ-TBL.
001620 SET C1-IDX TO 1.
001630 EJ1-RTN.
001640 MOVE ZERO TO CHKK2
001650 CHKT2
001660 KASAN
001670 KASAN2
001680 EVEN
001690 DAI.
001700 MOVE C1(C1-IDX) TO CHKK.
001710 IF CHKK2 < 96 GO TO EJ3-RTN
001720 ELSE IF CHKK2 < 125 MOVE 81 TO KASAN
001730 ELSE IF CHKK2 > 223 MOVE 112 TO KASAN
001740 ELSE IF CHKK2 > 159 GO TO EJ3-RTN
001750 ELSE IF CHKK2 > 127 MOVE 80 TO KASAN
001760 ELSE IF CHKK2 = 126 MOVE 143 TO CHKK2
001770 MOVE 1 TO EVEN
001780 GO TO EJ2-RTN
001790 ELSE GO TO EJ3-RTN.
001800 DIVIDE 2 INTO CHKK2 GIVING CHKK2 REMAINDER EVEN.
001810 COMPUTE CHKK2 = CHKK2 + KASAN.
001820 EJ2-RTN.
001830 MOVE C1(C1-IDX + 1) TO CHKT.
001840 IF CHKT2 > 95 MOVE 1 TO DAI
001850 ELSE MOVE 0 TO DAI.
001860 COMPUTE CHKT2 = CHKT2 + 31 + DAI - DAI * EVEN + 95 * EVEN.
001870 MOVE CHKK TO C1(C1-IDX).
001880 MOVE CHKT TO C1(C1-IDX + 1).
001890 SET C1-IDX UP BY 2.
001900 IF C1-IDX < CNV-NUMB GO TO EJ1-RTN.
001910 GO TO EJ4-RTN.
001920 EJ3-RTN.
001930 SET C1-IDX UP BY 1.
001940 IF C1-IDX < CNV-NUMB GO TO EJ1-RTN.
001950 EJ4-RTN.
001960 CALL "CBLCODE" USING CNV-AREA CNV-NUMB JE-TBL.
001970 EJ-EXT.
001980 EXIT.
001990**************************************************************
002000* SIFT-JIS TO NEC-INTERNAL(E)
002010**************************************************************
002020 JE-RTN.
002030 CALL "CBLCODE" USING CNV-AREA CNV-NUMB EJ-TBL.
002040 SET C1-IDX TO 1.
002050 JE1-RTN.
002060 MOVE ZERO TO CHKK2
002070 CHKT2
002080 KASAN
002090 KASAN2
002100 EVEN
002110 DAI.
002120 MOVE C1(C1-IDX) TO CHKK.
002130 IF CHKK2 < 96 GO TO JE4-RTN
002140 ELSE IF CHKK2 < 127 GO TO JE3-RTN
002150 ELSE IF CHKK2 < 129 GO TO JE4-RTN
002160 ELSE IF CHKK2 > 239 GO TO JE4-RTN
002170 ELSE IF CHKK2 > 223 MOVE 112 TO KASAN
002180 ELSE IF CHKK2 > 159 GO TO JE4-RTN
002190 ELSE IF CHKK2 > 143 MOVE 80 TO KASAN
002200 ELSE MOVE 81 TO KASAN
002210 IF CHKK2 = 143 MOVE 1 TO DAI.
002220 MOVE C1(C1-IDX + 1) TO CHKT.
002230 IF CHKT2 < 127 MOVE 31 TO KASAN2
002240 MOVE 0 TO EVEN
002250 ELSE IF CHKT2 < 159 MOVE 32 TO KASAN2
002260 MOVE 0 TO EVEN
002270 ELSE MOVE 126 TO KASAN2
002280 MOVE 1 TO EVEN.
002290 JE2-RTN.
002300 COMPUTE CHKK2 = (CHKK2 - KASAN) * 2 + EVEN + EVEN * DAI.
002310 COMPUTE CHKT2 = CHKT2 - KASAN2.
002320 MOVE CHKK TO C1(C1-IDX).
002330 MOVE CHKT TO C1(C1-IDX + 1).
002340 SET C1-IDX UP BY 2.
002350 IF C1-IDX < CNV-NUMB GO TO JE1-RTN.
002360 GO TO JE5-RTN.
002370 JE3-RTN.
002380 COMPUTE CHKK2 = CHKK2 - 32.
002390 MOVE CHKK TO C1(C1-IDX).
002400 JE4-RTN.
002410 SET C1-IDX UP BY 1.
002420 IF C1-IDX < CNV-NUMB GO TO JE1-RTN.
002430 JE5-RTN.
002440 CALL "CBLCODE" USING CNV-AREA CNV-NUMB JE-TBL.
002450 JE-EXT.
002460 EXIT.
---------------------------------------------------------------------------