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