MI Algorithm for Password Encryption -- MI400

There has been some discussion of machine efficiency. Below
I show an example of people efficiency in the sense that MI
can be used to describe an intricate algorithm in an under-
standable way. An added benefit is that the description is
machine executable and is in fact used as is in PentaSafe's
Password Manager.

The source for the password encryption is
http://www.ietf.org/internet-drafts/draft-ietf-tn3270e-tn5250e-05.txt

Here is the detailed algorithm as contained in the above URL:

   1. Padded_PW = Left justified user password padded to the right
      with '40'X to 8 bytes.
      The users password must be left justified in an 8 byte
      variable and padded to the right with '40'X up to an 8 byte
      length.  If the users password is 8 bytes in length, no
      padding would occur.  For computing password substitutes for
      passwords of length 9 and 10 see section "Handling passwords
      of length 9 and 10" below.  Passwords less than 1 byte or
      greater than 10 bytes in length are not valid.  Please note,
      if password is not in EBCDIC, it must be converted to EBCDIC
      uppercase.   2. XOR_PW = Padded_PW xor '5555555555555555'X
      The padded password is Exclusive OR'ed with 8 bytes of '55'X.

   3. SHIFT_RESULT = XOR_PW << 1
      The entire 8 byte result is shifted 1 bit to the left; the
      leftmost bit value is discarded, and the rightmost bit value
      is cleared to 0.

   4. PW_TOKEN = DES_ECB_mode(SHIFT_RESULT,   /* key  */
                              userID_in_EBCDIC_uppercase /* data */ )
      This shifted result is used as key to the Data Encryption
      Standard (Federal Information Processing Standards 46-2 [17])
      to encipher the user identifier.  When the user identifier is
      less than 8 bytes, it is left justified in an 8 byte variable
      and padded to the right with '40'X.  When the user identifier
      is 9 or 10 bytes, it is first padded to the right with '40'X
      to a length of 10 bytes.  Then bytes 9 and 10 are "folded"
      into bytes 1-8 using the following algorithm:

        Bit 0 is the high-order bit (i.e. has value of '80'X).
        Byte 1, bits 0 and 1 are replaced with byte 1, bits 0 and 1
        Exclusive OR'ed with byte 9, bits 0 and 1.
        Byte 2, bits 0 and 1 are replaced with byte 2, bits 0 and 1
        Exclusive OR'ed with byte 9, bits 2 and 3.
        Byte 3, bits 0 and 1 are replaced with byte 3, bits 0 and 1
        Exclusive OR'ed with byte 9, bits 4 and 5.
        Byte 4, bits 0 and 1 are replaced with byte 4, bits 0 and 1
        Exclusive OR'ed with byte 9, bits 6 and 7.
        Byte 5, bits 0 and 1 are replaced with byte 5, bits 0 and 1
        Exclusive OR'ed with byte 10, bits 0 and 1.
        Byte 6, bits 0 and 1 are replaced with byte 6, bits 0 and 1
        Exclusive OR'ed with byte 10, bits 2 and 3.
        Byte 7, bits 0 and 1 are replaced with byte 7, bits 0 and 1
        Exclusive OR'ed with byte 10, bits 4 and 5.
        Byte 8, bits 0 and 1 are replaced with byte 8, bits 0 and 1
        Exclusive OR'ed with byte 10, bits 6 and 7.

Here is the MI program:

DCL DD USER-NAME  CHAR(10); /* IN  */
DCL DD PASSWORD   CHAR(10); /* IN  */
DCL DD ENCRYPTED  CHAR(16); /* OUT */

DCL DD CONTROL CHAR(32);
    DCL DD CTRL-FUNCTION CHAR(2) DEF(CONTROL) POS(1) INIT(X'0002');
    DCL DD CTRL-SIZE      BIN(2) DEF(CONTROL) POS(3) INIT(8);
    DCL DD CTRL-OPTION   CHAR(1) DEF(CONTROL) POS(5) INIT(X'00');
    DCL DD DES-KEY       CHAR(8) DEF(CONTROL) POS(6);

DCL DD PWD CHAR(16);  /* PASSWORD  */
DCL SPCPTR .CRYPT INIT(CRYPT); DCL DD CRYPT CHAR(16);  /* ENCRYPTED */
DCL SPCPTR .USER  INIT(USER);  DCL DD USER  CHAR(10);  /* USER NAME */

DCL CON CONDITIONING CHAR(8) INIT(X'5555555555555555');

DCL DD  SHIFTS CHAR(8) INIT(X'0002040600020406');
DCL DD  SHIFT         BIN(2) UNSGND    INIT(0);
    DCL DD SHIFT-LOW CHAR(1) DEF(SHIFT) POS(2);

DCL DD  FROMS  CHAR(8) INIT(X'090909090A0A0A0A');
DCL DD  FROM          BIN(2)           INIT(0);
    DCL DD FROM-LOW  CHAR(1) DEF(FROM)  POS(2);

DCL DD POSN  BIN(2);
DCL DD WORK CHAR(1);
    . . . 
    CPYBLA      USER, USER-NAME;
    CPYBLAP     PWD , PASSWORD , " ";
    CPYBREP     CRYPT,     X'40';
    CMPBLA(B)   PWD (9:1), X'40'/EQ(DONE);
    CMPBLA(B)   USER(9:1), X'40'/NHI(ENCRYPT);

    CPYNV       POSN, 8; 
FOLD-USER-NAME:
    CPYBLA      FROM-LOW , FROMS (POSN:1);
    CPYBLA      SHIFT-LOW, SHIFTS(POSN:1);
    CPYBTLLS    WORK, USER(FROM:1), SHIFT;
    AND(S)      WORK, X'C0'; /* extract 2 bits */
    XOR(S)      USER(POSN:1), WORK;
    SUBN(SB)    POSN, 1/NZER(FOLD-USER-NAME);

ENCRYPT:
    CPYNV       POSN, 1;
    CMPBLA(B)   PWD(9:1), X'40'/EQ(ENCRYPT-BLOCK);
    ADDN(S)     POSN, 8;  /* if long password */
ENCRYPT-BLOCK:
    XOR         DES-KEY, PWD(POSN:8), CONDITIONING;
    ADDLC(S)    DES-KEY, DES-KEY;
    CIPHER     .CRYPT, CONTROL, .USER;
    CPYBLA      CRYPT(POSN:8), CRYPT(1:8);
    SUBN(SB)    POSN, 8/HI(ENCRYPT-BLOCK);
DONE:
    CPYBLA      ENCRYPTED, CRYPT;

+---
| This is the MI Programmers Mailing List!
| To submit a new message, send your mail to MI400@midrange.com.
| To subscribe to this list send email to MI400-SUB@midrange.com.
| To unsubscribe from this list send email to MI400-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: dr2@cssas400.com
+---