home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / CODE3_4.ZIP / PCCODE3.FOR < prev    next >
Encoding:
Text File  |  1986-12-01  |  15.8 KB  |  653 lines
  1. $NODEBUG
  2. $NOFLOATCALLS
  3. $STRICT
  4. $PAGE
  5.       PROGRAM PCCODE3
  6. C
  7. C     ********************************************************
  8. C     *                                                      *
  9. C     *     PC-CODE3 PORTABLE CRYPTOGRAPHY        v6.2a      *
  10. C     *     (c) COPYRIGHT RICHARD NOLEN COLVARD   Apr-86     *
  11. C     *         COMMERCIAL RIGHTS RESERVED                   *
  12. C     *                                                      *
  13. C     *         MICROSOFT  FORTRAN-77 V3.30                  *
  14. C     *                                                      *
  15. C     ********************************************************
  16. C
  17.       INTEGER*2   IERR,ILOW,IHIGH,NKEYS,J,K,M,IFREQ,KLEN
  18.       INTEGER*2   RANGE,RESULT,RANGE2,IA,IR,ISEC,SIZE99
  19.       INTEGER*4   KEYS(999),HASHER,JHASH
  20.       CHARACTER*1 IYES,ITRANS,IHDR,IHASH,TEXT(512)
  21.       CHARACTER*1 ICODE,IKEY,IINP,IOUT,TEMP(72)
  22.       CHARACTER*21 VERSION,VERS
  23. C
  24. C
  25.       PARAMETER (SIZE99=80)
  26. C
  27. C
  28.       DATA IERR / 0 /
  29.       DATA TEXT / 512 * ' '/
  30.       DATA KEYS / 999 * 0 /
  31.       DATA HASHER / 0 /
  32.       DATA VERSION / '$PC-CODE3 V6.2 APR-86' /
  33. C
  34. C
  35.    5  FORMAT(1X)
  36.    6  FORMAT(1X,/)
  37.       WRITE(*,6)
  38.       WRITE(*,10)
  39.   10  FORMAT(10X,'PC-CODE3  PORTABLE CRYPTO-SYSTEM  v6.2B',//)
  40.   20  FORMAT(10X,'(c) Copyright R. Nolen COLVARD Company 1986')
  41.   22  FORMAT(10X,'    Commercial Rights Reserved')
  42.   24  FORMAT(10X,'(c) Copyright Microsoft Corp 1985')
  43.   26  FORMAT(10X,'    Microsoft FORTRAN-77 V3.30',//)
  44.       WRITE(*,20)
  45.       WRITE(*,22)
  46.       WRITE(*,24)
  47.       WRITE(*,26)
  48. C
  49. C
  50.       OPEN(9,FILE='CONFIG.PC3',FORM='FORMATTED',ACCESS='SEQUENTIAL',
  51.      +       STATUS='OLD',IOSTAT=IERR)
  52. C
  53. C
  54.   30  FORMAT(5X,'*** PROBLEM MISSING "config.pc3" CANNOT CONTINUE')
  55.   35  FORMAT(5X,'    PLEASE EXECUTE "install3" TO CONTINUE')
  56.   40  FORMAT(5X,'    SESSION ABORTED',//)
  57.       IF (IERR .GT. 0) THEN
  58.          WRITE(*,30)
  59.          WRITE(*,35)
  60.          WRITE(*,40)
  61.          STOP 99
  62.       ENDIF
  63. C
  64.   70  FORMAT(A1,72A1)
  65.   71  FORMAT(1X,A1,72A1)
  66.   72  FORMAT(I1,72A1)
  67.   73  FORMAT(1X,I1,72A1)
  68.       READ(9,72) ISEC, TEMP
  69.       WRITE(*,73) ISEC, TEMP
  70. C
  71. C
  72.       READ(9,70) IKEY, TEMP
  73.       WRITE(*,71) IKEY, TEMP
  74. C
  75. C
  76.       READ(9,70) ITRANS, TEMP
  77.       WRITE(*,71) ITRANS, TEMP
  78. C
  79. C
  80.       READ(9,80) ILOW, TEMP
  81.   80  FORMAT(I3,72A1)
  82.   81  FORMAT(1X,I3,72A1)
  83.       WRITE(*,81) ILOW, TEMP
  84. C
  85. C
  86.       READ(9,80) IHIGH, TEMP
  87.       WRITE(*,81) IHIGH, TEMP
  88. C
  89. C
  90.       READ(9,70) IHDR, TEMP
  91.       WRITE(*,71) IHDR, TEMP
  92. C
  93. C
  94.       READ(9,70) IHASH, TEMP
  95.       WRITE(*,71) IHASH, TEMP
  96. C
  97. C
  98.       READ(9,80) IFREQ, TEMP
  99.       WRITE(*,81) IFREQ, TEMP
  100. C
  101. C
  102.       READ(9,70) IINP, TEMP
  103.       WRITE(*,71) IINP, TEMP
  104. C
  105. C
  106.       READ(9,70) IOUT, TEMP
  107.       WRITE(*,71) IOUT, TEMP
  108. C
  109. C
  110.       CLOSE(9)
  111. C
  112.       RANGE = (IHIGH - ILOW) + 1
  113.       RANGE2 = 2 * RANGE
  114.       WRITE(*,6)
  115.       PAUSE
  116.       WRITE(*,6)
  117. C
  118. C
  119. C
  120.   401 FORMAT(1X,'Enter KEYS (a minimum of 4) one per line')
  121.   402 FORMAT(1X,'---------> to TERMINATE enter a ZERO (0)')
  122.   455 FORMAT(I10)
  123.   460 FORMAT(1X,'AT LEAST 4 KEYS MUST BE ENTERED; ADD MORE')
  124.   500 FORMAT(1X,'Enter Key FILE Name below ---',/)
  125.   571 FORMAT(1X,'123456789A')
  126.   572 FORMAT(1X,'+........+')
  127. C
  128.       IF (IKEY .EQ. 'N') THEN
  129.          NKEYS = 1
  130.          WRITE(*,401)
  131.          WRITE(*,402)
  132.          WRITE(*,571)
  133.          WRITE(*,572)
  134.   450    READ(*,455,END=451) KEYS(NKEYS)
  135.          IF (KEYS(NKEYS) .GT. 0) THEN
  136.             NKEYS = NKEYS + 1
  137.             GOTO 450
  138.          ENDIF
  139.   451    NKEYS = NKEYS - 1
  140.          IF (NKEYS .LT. 4) THEN
  141.             WRITE(*,460)
  142.             GO TO 450
  143.          ENDIF
  144.       ELSE
  145.          NKEYS = 1
  146.          WRITE(*,500)
  147.          OPEN(3,FILE='  ',FORM='FORMATTED',ACCESS='SEQUENTIAL',
  148.      +       STATUS='OLD',IOSTAT=IERR)
  149.   501    READ(3,455,END=600) KEYS(NKEYS)
  150.          NKEYS = NKEYS + 1
  151.          GO TO 501
  152.   600    NKEYS = NKEYS - 1
  153.          CLOSE(3)
  154.       ENDIF
  155.       WRITE(*,606) NKEYS
  156.   606 FORMAT(1X,/,1X,'KEYS FOUND=',I4)
  157. C
  158. C
  159. C
  160.       IF (IHASH .EQ. 'Y') THEN
  161.          HASHER = 0
  162.          DO 404 J=1,NKEYS
  163.             HASHER = MOD((HASHER + KEYS(J)),997)
  164.   404    CONTINUE
  165.       ENDIF
  166. C
  167. C
  168. C
  169.       WRITE(*,5)
  170.   707 WRITE(*,100)
  171.   100 FORMAT(1X,'Encode or Decode ("E" or "D") a file:')
  172.   110 FORMAT(A1)
  173.       READ(*,110) ICODE
  174.       IF (ICODE .EQ. 'e') ICODE = 'E'
  175.       IF (ICODE .EQ. 'd') ICODE = 'D'
  176.       IF ((ICODE .NE. 'E') .AND. (ICODE .NE. 'D')) GOTO 707
  177.       WRITE(*,6)
  178. C
  179. C
  180.       IF (ICODE .EQ. 'E') THEN
  181.          WRITE(*,120)
  182.          OPEN(5,FILE='  ',FORM='FORMATTED',ACCESS='SEQUENTIAL',
  183.      +       STATUS='OLD',IOSTAT=IERR)
  184.          WRITE(*,5)
  185.          WRITE(*,130)
  186.          OPEN(6,FILE='  ',FORM='FORMATTED',ACCESS='SEQUENTIAL',
  187.      +       STATUS='NEW',IOSTAT=IERR)
  188.       ELSE
  189.          WRITE(*,5)
  190.          WRITE(*,140)
  191.          OPEN(5,FILE='  ',FORM='FORMATTED',ACCESS='SEQUENTIAL',
  192.      +       STATUS='OLD',IOSTAT=IERR)
  193.          WRITE(*,5)
  194.          WRITE(*,150)
  195.          OPEN(6,FILE='  ',FORM='FORMATTED',ACCESS='SEQUENTIAL',
  196.      +       STATUS='NEW',IOSTAT=IERR)
  197.       ENDIF
  198. C
  199. C
  200.   120 FORMAT(1X,'Enter the INPUT File to be ENCODED -----',/,1X)
  201.   130 FORMAT(1X,'Enter the OUTPUT file for the CODE -----',/,1X)
  202.   140 FORMAT(1X,'Enter the INPUT File to be DECODED -----',/,1X)
  203.   150 FORMAT(1X,'Enter the OUTPUT file for plain TEXT ---',/,1X)
  204.   407 FORMAT(1X,'$PC-CODE3 V6.2 APR-86;  HASHED=',I3,'  $END HEADER')
  205.   408 FORMAT(1X,A21,10X,I3,13X)
  206.   409 FORMAT(1X,//,5X,'FATAL ERROR: KEY does not match coded file')
  207.   410 FORMAT(1X,//,5X,'FATAL ERROR: cannot decode,not of Pc-Code3')
  208.   411 FORMAT(5X,'----- This file never encoded by Pc-Code3')
  209.   412 FORMAT(5X,'Correct VERSION should be: ',A21)
  210.   413 FORMAT(5X,'Incorrect file VERSION is: ',A21)
  211.   414 FORMAT(5X,'Correct Hash count should be: ',I3)
  212.   415 FORMAT(5X,'Incorrect File Hash count is: ',I3)
  213. C
  214. C
  215. C
  216.       IF (IHDR .EQ. 'Y') THEN
  217.          IF (ICODE .EQ. 'D') THEN
  218.              READ(5,408) VERS,JHASH
  219.          ELSE
  220.              WRITE(6,407) HASHER
  221.          ENDIF
  222.       ENDIF
  223. C
  224. C
  225. C
  226.       IF ((IHDR .EQ. 'Y') .AND. (ICODE .EQ. 'D')) THEN
  227.          IF (VERS .NE. VERSION) THEN
  228.              WRITE(*,410)
  229.              WRITE(*,411)
  230.              WRITE(*,412) VERSION
  231.              WRITE(*,413) VERS
  232.              STOP 410
  233.          ENDIF
  234.       ENDIF
  235. C
  236. C
  237.       IF ((IHASH .EQ. 'Y') .AND. (IHDR .EQ. 'Y')) THEN
  238.          IF (ICODE .EQ. 'D') THEN
  239.             IF (HASHER .NE. JHASH) THEN
  240.                WRITE(*,409)
  241.                WRITE(*,415) JHASH
  242.                WRITE(*,414) HASHER
  243.                STOP 409
  244.             ENDIF
  245.          ENDIF
  246.       ENDIF
  247. C
  248. C
  249. C <----------- LOOP HERE FOR NEW RECORD <----------
  250.   200 CONTINUE
  251. C
  252. C
  253.   209 FORMAT(1X,512A1)
  254.   210 FORMAT(I3,512A1)
  255.   919 FORMAT(512A1)
  256. C
  257. C
  258.       IF (ICODE .EQ. 'E') THEN
  259.          READ(5,919,END=800) (TEXT(M),M=1,SIZE99)
  260.          DO 205 KLEN=SIZE99,1,-1
  261.             IF (TEXT(KLEN) .NE. ' ') GOTO 211
  262.   205    CONTINUE
  263.   211    CONTINUE
  264.       ELSE
  265.          KLEN = SIZE99
  266.          READ(5,210,END=800) KLEN, (TEXT(M),M=1,KLEN)
  267.       ENDIF
  268. C
  269.       IF (IINP .EQ. 'Y') WRITE(*,209) (TEXT(M),M=1,KLEN)
  270. C
  271.       IF (KLEN .GE. 2) THEN
  272.          CALL IJGEND(KEYS,NKEYS,IFREQ,ISEC,KLEN)
  273.          IF ((ITRANS .EQ. 'Y') .AND. (ICODE .EQ. 'D'))
  274.      +       CALL IJDEAL(TEXT,KLEN)
  275.       ENDIF
  276. C
  277. C
  278.       IF (KLEN .LT. 1) GOTO 335
  279. C
  280. C
  281.       DO 333 J=1,KLEN
  282. C
  283.       IA = ICHAR( TEXT(J) )
  284.       IF ((IA .EQ. 13) .OR. (IA .EQ. 10)) GOTO 334
  285.       IF (IA .GT. IHIGH) IA = ICHAR('?')
  286.       IF (IA .LT. ILOW ) IA = ICHAR('?')
  287. C
  288.       CALL RANDJ1(KEYS,RANGE,RESULT,NKEYS,ISEC)
  289. C
  290.       IA = IA - ILOW
  291.       IR = RESULT
  292.       IF (ICODE .EQ. 'D') IR = -1 * IR
  293.       IA = RANGE2 + IA + IR
  294. C
  295.       TEXT(J) = CHAR( MOD(IA,RANGE) + ILOW )
  296. C
  297.   333 CONTINUE
  298.   334 CONTINUE
  299. C
  300. C
  301.       IF (KLEN .GE. 2) THEN
  302.          IF ((ITRANS .EQ. 'Y') .AND. (ICODE .EQ. 'E') )
  303.      +       CALL IJDEAL(TEXT,KLEN)
  304.       ENDIF
  305. C
  306. C
  307.   335 CONTINUE
  308. C
  309. C
  310.       IF (IOUT .EQ. 'Y') WRITE(*,209) (TEXT(M),M=1,KLEN)
  311. C
  312.       IF (ICODE .EQ. 'D') THEN
  313.           WRITE(6,919) (TEXT(M),M=1,KLEN)
  314.       ELSE
  315.           WRITE(6,210) KLEN, (TEXT(M),M=1,KLEN)
  316.       ENDIF
  317. C
  318. C
  319.       IF ((IOUT .EQ. 'Y') .AND. (IINP .EQ. 'Y')) WRITE(*,5)
  320. C
  321.       GO TO 200
  322. C
  323. C
  324. C
  325.   800 CONTINUE
  326.   900 FORMAT(2X,/,5X,'*** End of Program PC-CODE3 ***',/)
  327.       WRITE(*,900)
  328.       DO 903 J=1,NKEYS
  329.   903 KEYS(J) = 0
  330.       CLOSE(6)
  331.       CLOSE(5)
  332.       STOP
  333.       END
  334. $NODEBUG
  335. $STRICT
  336. $NOFLOATCALLS
  337. $PAGE
  338.        SUBROUTINE RANDJ1(SEEDS,RANGE,RESULT,NSIZE,ISEC)
  339. C
  340. C      * * * * * * * * * * * * * * * * * * * * * * *
  341. C      *                                           *
  342. C      *         P E R M U T T A T I O N           *
  343. C      *                                           *
  344. C      *         MICROSOFT FORTRAN-77 V3.30        *
  345. C      *                                           *
  346. C      * * * * * * * * * * * * * * * * * * * * * * *
  347. C
  348.        INTEGER*4  SEEDS(*)
  349.        INTEGER*4  JSAVE
  350.        INTEGER*2  RANGE,RESULT,NSIZE
  351.        INTEGER*2  JTEMP,JSIZE,ISEC
  352. C
  353. C
  354.        JSIZE = NSIZE - 1
  355. C
  356.        IF (JSIZE .LE. 1) THEN
  357.           WRITE (*,*) '* RANDJ1 ERROR INPUT NSIZE LT 3'
  358.           GOTO 999
  359.        ENDIF
  360. C
  361.        JSAVE = SEEDS(1)
  362.        CALL RANDJ3(JSAVE,JSIZE,JTEMP)
  363.        SEEDS(1) = JSAVE
  364. C
  365.        JTEMP = JTEMP + 1
  366.        JSAVE = SEEDS(JTEMP)
  367. C
  368.        IF (JSAVE .EQ. 0) THEN
  369.           WRITE(*,*) '* RANDJ1 ZERO SEED SELECTED /SYSTEM ERROR/'
  370.           WRITE(*,*) '*        JTEMP=', JTEMP, '  JSIZE=', NSIZE
  371.        ENDIF
  372. C
  373.        IF (ISEC .GT. 3) ISEC = MOD(ISEC,3) + 1
  374. C
  375.        GOTO (100,200,300), ISEC
  376. C
  377.   100  CALL RANDJ3(JSAVE,RANGE,RESULT)
  378.        GOTO 900
  379.   200  CALL RANDJ2(JSAVE,RANGE,RESULT)
  380.        GO TO 900
  381.   300  CALL RANDJ4(JSAVE,RANGE,RESULT)
  382.        GO TO 900
  383. C
  384. C
  385.   900  SEEDS(JTEMP) = JSAVE
  386. C
  387.   999  RETURN
  388.        END
  389. $NODEBUG
  390. $STRICT
  391. $NOFLOATCALLS
  392. $PAGE
  393.        SUBROUTINE RANDJ2(SEED,RANGE,RESULT)
  394. C
  395. C      * * * * * * * * * * * * * * * * * * * * * * *
  396. C      *                                           *
  397. C      *   LOW SECURITY RANDOM NUMBERS / EFFICENT  *
  398. C      *                                           *
  399. C      *   MICROSOFT FORTRAN-77  V3.30             *
  400. C      *                                           *
  401. C      * * * * * * * * * * * * * * * * * * * * * * *
  402. C
  403.        INTEGER*4  SEED,MX,MX2,A,B,C,CSAVE
  404.        INTEGER*4  SEED2
  405.        INTEGER*2  RANGE,RESULT
  406.        INTEGER*2  SEEDR(2)
  407. C
  408.        EQUIVALENCE  (SEED2,SEEDR(1))
  409. C
  410.        DATA  MX/032767/, MX2/032768/
  411. C
  412. C
  413. C
  414.        SEED2 = SEED
  415.        A = SEEDR(1)
  416.        B = SEEDR(2)
  417. C
  418.        IF (A) 10,20,30
  419.   10   A = IABS(A) + 1
  420.        GOTO 30
  421.   20   A = 1
  422.        WRITE (*,*) 'RANDJ2 INPUT SEED(a) OF ZERO; Reset OK'
  423.   30   CONTINUE
  424. C
  425.        IF (B) 40,50,60
  426.   40   B = IABS(B) + 1
  427.        GOTO 30
  428.   50   B = 1
  429.        WRITE (*,*) 'RANDJ2 INPUT SEED(b) OF ZERO; Reset OK'
  430.   60   CONTINUE
  431. C
  432.        A = 2 * A
  433.        B = 2 * B
  434. C
  435.        IF (A .GT. MX) A = A - MX
  436.        IF (B .GT. MX) B = B - MX
  437. C
  438.        C = A + B
  439.        CSAVE = C
  440.        IF (C .GT. MX2) C = C - MX2
  441.        C = 2 * C
  442. C
  443.        IF (C .GT. MX) C = C - MX
  444. C
  445.        A = B
  446.        B = C
  447.        SEEDR(1) = A
  448.        SEEDR(2) = B
  449.        SEED = SEED2
  450.        RESULT = MOD(CSAVE,RANGE) + 1
  451. C
  452.        RETURN
  453.        END
  454. $NODEBUG
  455. $STRICT
  456. $NOFLOATCALLS
  457. $PAGE
  458.        SUBROUTINE RANDJ3(SEED,RANGE,RESULT)
  459. C
  460. C      * * * * * * * * * * * * * * * * * * * * * * *
  461. C      *                                           *
  462. C      *  HIGH SECURITY RANDOM NUMBERS / SLOW      *
  463. C      *                                           *
  464. C      *  MICROSOFT FORTRAN-77  V3.30              *
  465. C      *                                           *
  466. C      * * * * * * * * * * * * * * * * * * * * * * *
  467. C
  468.        INTEGER*4  SEED
  469.        INTEGER*2  RANGE,RESULT
  470.        REAL*8     SEED2,ZMOD,ZMULT
  471. C
  472. C
  473.        DATA  ZMOD/2147483647.00D0/, ZMULT/16807.000D0/
  474. C
  475. C
  476. C
  477.        SEED2 = SEED
  478. C
  479.        IF (SEED .LT. 1) THEN
  480.           WRITE(*,*) '* RANDJ3 SEED VALUE OF ZERO; Reset OK'
  481.           SEED2 = 10019567.0000D0
  482.        ENDIF
  483. C
  484. C
  485.        SEED2 = SEED2 * ZMULT
  486.        SEED2 = DMOD(SEED2,ZMOD)
  487. C
  488.        RESULT = (SEED2 / ZMOD) * DFLOAT(RANGE)
  489.        RESULT = RESULT + 1
  490.        SEED = SEED2
  491. C
  492.        RETURN
  493.        END
  494. $PAGE
  495.        DOUBLE PRECISION FUNCTION DFLOAT(D)
  496.        INTEGER*2  D
  497.        DFLOAT = D
  498.        RETURN
  499.        END
  500. $NODEBUG
  501. $STRICT
  502. $NOFLOATCALLS
  503. $PAGE
  504.        SUBROUTINE RANDJ4(SEED,RANGE,RESULT)
  505. C
  506. C      * * * * * * * * * * * * * * * * * * * * * * *
  507. C      *                                           *
  508. C      *   LOW SECURITY RANDOM NUMBERS / EFFICENT  *
  509. C      *                                           *
  510. C      *   MICROSOFT FORTRAN-77  V3.30             *
  511. C      *                                           *
  512. C      * * * * * * * * * * * * * * * * * * * * * * *
  513. C
  514.        INTEGER*4  SEED,A,B,C,ASAVE,BSAVE
  515.        INTEGER*4  SEED2
  516.        INTEGER*2  RANGE,RESULT
  517.        INTEGER*2  SEEDR(2)
  518. C
  519.        EQUIVALENCE  (SEED2,SEEDR(1))
  520. C
  521. C
  522. C
  523.        SEED2 = SEED
  524.        A = SEEDR(1)
  525.        B = SEEDR(2)
  526. C
  527. C
  528.        IF (A) 10,20,30
  529.   10   A = IABS(A)
  530.        GOTO 30
  531.   20   A = 18127
  532.        WRITE (*,*) 'RANDJ4 INPUT SEED(a) OF ZERO; Reset OK'
  533.   30   CONTINUE
  534. C
  535.        IF (B) 40,50,60
  536.   40   B = IABS(B)
  537.        GOTO 30
  538.   50   B = 16651
  539.        WRITE (*,*) 'RANDJ2 INPUT SEED(b) OF ZERO; Reset OK'
  540.   60   CONTINUE
  541. C
  542.        A = A * 182
  543.        ASAVE = A
  544.        A = MOD(A,32749)
  545. C
  546.        B = B * 180
  547.        BSAVE = B
  548.        B = MOD(B,32717)
  549. C
  550.        SEEDR(1) = A
  551.        SEEDR(2) = B
  552.        SEED = SEED2
  553. C
  554.        C = ASAVE + BSAVE
  555.        RESULT = MOD(C,RANGE) + 1
  556. C
  557.        RETURN
  558.        END
  559. $NODEBUG
  560. $STRICT
  561. $NOFLOATCALLS
  562. $PAGE
  563.        SUBROUTINE IJDEAL(TEXT,LEN)
  564. C
  565. C      * * * * * * * * * * * * * * * * * * * * * * *
  566. C      *                                           *
  567. C      *   TRANSPOSE INPUT/OUTPUT TEXT             *
  568. C      *                                           *
  569. C      *   MICROSOFT FORTRAN-77  V3.30             *
  570. C      *                                           *
  571. C      * * * * * * * * * * * * * * * * * * * * * * *
  572. C
  573.        INTEGER*2   LEN,LEN2
  574.        INTEGER*2   J,K,M,ISEC,IDEAL
  575.        CHARACTER*1 TEXT(*),CHSAVE
  576.        COMMON /IJRAN/ IDEAL(512)
  577. C
  578. C
  579.        LEN2 = LEN / 2
  580. C
  581. C
  582.        DO 400 K=1,LEN2
  583.           J = IDEAL(K)
  584.           M = IDEAL(K+LEN2)
  585.           CHSAVE = TEXT(M)
  586.           TEXT(M) = TEXT(J)
  587.           TEXT(J) = CHSAVE
  588.   400  CONTINUE
  589. C
  590. C
  591. C
  592.        RETURN
  593.        END
  594. $NODEBUG
  595. $STRICT
  596. $NOFLOATCALLS
  597. $PAGE
  598.        SUBROUTINE IJGEND(KEYS,NKEYS,IFREQ,ISEC,LEN)
  599. C
  600. C      * * * * * * * * * * * * * * * * * * * * * * *
  601. C      *                                           *
  602. C      *   DEAL PERMUATION FOR TRANSPOSITION       *
  603. C      *                                           *
  604. C      *   MICROSOFT FORTRAN-77  V3.30             *
  605. C      *                                           *
  606. C      * * * * * * * * * * * * * * * * * * * * * * *
  607. C
  608.        INTEGER*4   KEYS(*)
  609.        INTEGER*2   NKEYS,LEN,IFREQ,DEAL
  610.        INTEGER*2   ICOUNT,LAST,J,K,M
  611.        INTEGER*2   RANGE,RESULT,ISEC
  612.        COMMON /IJRAN/ DEAL(512)
  613.        DATA ICOUNT / 9999 /, LAST / 9999 /
  614. C
  615. C
  616.        IF (ICOUNT .EQ. 9999) THEN
  617.           ICOUNT = -1
  618.           LAST = LEN
  619.           DO 100 J=1,512
  620.              DEAL(J) = J
  621.   100     CONTINUE
  622.        ENDIF
  623. C
  624. C
  625.        IF (LAST .NE. LEN) THEN
  626.           ICOUNT = -1
  627.           LAST = LEN
  628.           DO 200 J=1,LEN
  629.              DEAL(J) = J
  630.   200     CONTINUE
  631.        ENDIF
  632. C
  633. C
  634.        ICOUNT = ICOUNT + 1
  635. C
  636. C
  637.        RANGE = LEN
  638. C
  639. C
  640.        IF ( MOD(ICOUNT,IFREQ) .EQ. 0) THEN
  641.           DO 300 K=1,LEN
  642.              CALL RANDJ1(KEYS,RANGE,RESULT,NKEYS,ISEC)
  643.              M  = DEAL(RESULT)
  644.              DEAL(RESULT) = DEAL(K)
  645.              DEAL(K) = M
  646.   300     CONTINUE
  647.        ENDIF
  648. C
  649. C
  650. C
  651.        RETURN
  652.        END
  653.