home *** CD-ROM | disk | FTP | other *** search
/ Microsoft Programmer's Library 1.3 / Microsoft_Programmers_Library.7z / MPL / fortran / frtsam.txt < prev   
Encoding:
Text File  |  2013-11-08  |  79.7 KB  |  2,562 lines
  1.  \SAMPCODE
  2.  \SAMPCODE\FORTRAN
  3.  \SAMPCODE\FORTRAN\DEMO.FOR
  4.  
  5.  C     Bubble Sort Demonstration Program
  6.  C     Microsoft FORTRAN77
  7.  C     4 October 1982
  8.  C
  9.  C     The main routine reads from the terminal an array
  10.  C     of ten real numbers in F8.0 format and calls the
  11.  C     subroutine BUBBLE to sort them.
  12.  C
  13.        REAL R(10)
  14.        INTEGER I
  15.        WRITE (*,001)
  16.    001 FORMAT(1X,'Bubble Sort Demonstration Program.')
  17.    100 DO 103 I=1,10
  18.        WRITE (*,101) I
  19.    101 FORMAT(1X,'Please input real number no. ',I2)
  20.        READ (*,102) R(I)
  21.    102 FORMAT(F8.0)
  22.    103 CONTINUE
  23.        CALL BUBBLE(R,10)
  24.        WRITE (*,002)
  25.    002 FORMAT(/1X,'The sorted ordering from lowest to highest is:')
  26.        WRITE (*,003) (R(I),I = 1,10)
  27.    003 FORMAT(2(1x,5F13.3/))
  28.        STOP
  29.        END
  30.  C
  31.  C     Subroutine    BUBBLE   performs   a   bubble   sort   on   a
  32.  C     one-dimensional real array of arbitrary  length.   It  sorts
  33.  C     the array in ascending order.
  34.        SUBROUTINE BUBBLE(X,J)
  35.        INTEGER J,A1,A2
  36.        REAL X(J),TEMP
  37.    100 IF (J .LE. 1) GOTO 101
  38.    200 DO 201 A1 = 1,J-1
  39.    300 DO 301 A2 = A1 + 1,J
  40.    400 IF (X(A1) .LE. X(A2)) GOTO 401
  41.        TEMP = X(A1)
  42.        X(A1) = X(A2)
  43.        X(A2) = TEMP
  44.    401 CONTINUE
  45.    301 CONTINUE
  46.    201 CONTINUE
  47.    101 CONTINUE
  48.        RETURN
  49.        END
  50.  
  51.  
  52.  \SAMPCODE\FORTRAN\DEMORAN.FOR
  53.  
  54.          PROGRAM DEMORAN
  55.  c
  56.  c  This program demonstrates a uniform pseudo-random number
  57.  c  generator.
  58.  c
  59.  c  Portions of this program are based on ideas presented in the
  60.  c  the book "Numerical Recipes - The Art of Scientific Computing"
  61.  c  by William H. Press, Brian P. Flannery, Saul A. Teukolsky, and
  62.  c  William T. Vetterling, Cambridge University Press 1986
  63.  c
  64.  c  If 1000 numbers and 10 bins are requested, each bin should
  65.  c  (ideally) be filled with 100 numbers. The percentage error
  66.  c  is printed for each bin.
  67.  c
  68.  c  The following routines are provided:
  69.  c
  70.  c  REAL FUNCTION RAND ()
  71.  c    returns a real number in the range 0. to 1.0
  72.  c
  73.  c  INTEGER FUNCTION RANDLIM (ILO,IHI)
  74.  c    returns a random integer in the range ILO to IHI
  75.  c
  76.  c  REAL FUNCTION SRAND (SEED)
  77.  c    initializes either generator (seed = 0. to 259199.)
  78.  c
  79.  c  SUBROUTINE SECOND (TX)
  80.  c    returns the number of seconds and hundreths of seconds elapsed
  81.  c    since midnight
  82.  c
  83.  c
  84.  c  NOTE -- Both generators should produce identical results
  85.  c
  86.          INTEGER BINS(0:999), RANDLIM
  87.          ERR(I) = (I-FLOAT(NREP/NBINS))/(NREP/NBINS)*100.
  88.          WRITE (*,*) 'You will be asked to provide the following:'
  89.          WRITE (*,*) 'how many random numbers to generate'
  90.          WRITE (*,*) 'how many bins to use (1-1000)'
  91.          WRITE (*,*) 'which generator to use (1 or 2)'
  92.          WRITE (*,*)
  93.  10      CONTINUE
  94.          WRITE (*,*) 'Input three numbers separated by blanks or commas'
  95.          WRITE (*,*) 'or CTRL-Z to end'
  96.          READ (*,*,END=999) NREP,NBINS,IGEN
  97.          SEED = SRAND(1.0)
  98.          CALL SECOND (T1)
  99.          DO 100 I=1,NREP
  100.            IF (IGEN .EQ. 1) THEN
  101.              IX = RANDLIM(0,NBINS-1)
  102.            ELSE
  103.              IX = NBINS*RAND()
  104.            ENDIF
  105.            BINS(IX) = BINS(IX)+1
  106.  100     CONTINUE
  107.          CALL SECOND (T2)
  108.          WRITE (*,*) 'Time elapsed=',t2-t1
  109.          WRITE (*,*) 'Numbers generated per second=',nrep/(t2-t1)
  110.          WRITE (*,*)
  111.          WRITE (*,*) 'Bin    Count  % Error'
  112.          WRITE (*,*) '----  ------- -------'
  113.          DO 200 I=0,NBINS-1
  114.            WRITE (*,'(1x,i4,i9,f7.1,''%'')') i+1,bins(i),err(bins(i))
  115.            BINS(I) = 0
  116.  200     CONTINUE
  117.          GO TO 10
  118.  999     CONTINUE
  119.          END
  120.          FUNCTION RANDOM ()
  121.  c
  122.  c  If called, RANDOM just returns 0.0
  123.  c
  124.          INTEGER RANDLIM
  125.          PARAMETER (IA=7141, IC=54773, IM=259200)
  126.          RANDOM = 0.0
  127.          RETURN
  128.  c
  129.  c  REAL FUNCTION SRAND (SEED)
  130.  c    initializes either generator (seed = 0. to 259199.)
  131.  c
  132.          ENTRY SRAND (X)
  133.          SRAND = X
  134.          SEED = X
  135.          RETURN
  136.  c
  137.  c  INTEGER FUNCTION RANDLIM (ILO,IHI)
  138.  c    returns a random integer in the range ILO to IHI
  139.  c
  140.          ENTRY RANDLIM (ILO,IHI)
  141.          SEED = MOD (INT(SEED)*IA+IC,IM)
  142.          RANDLIM = ILO+(IHI-ILO+1)*SEED/IM
  143.          RETURN
  144.  c
  145.  c  REAL FUNCTION RAND ()
  146.  c    returns a real number in the range 0. to 1.0
  147.  c
  148.          ENTRY RAND ()
  149.          SEED = MOD (INT(SEED)*IA+IC,IM)
  150.          RAND = SEED/IM
  151.          END
  152.          SUBROUTINE SECOND (TX)
  153.  c
  154.  c  SUBROUTINE SECOND (TX)
  155.  c    returns the number of seconds and hundredths of seconds elapsed
  156.  c    since midnight
  157.  c
  158.          INTEGER*2 IH,IM,IS,IHU
  159.          CALL GETTIM (IH,IM,IS,IHU)
  160.          TX = IH*3600.+IM*60+IS+IHU/100.
  161.          END
  162.  
  163.  \SAMPCODE\FORTRAN\DWHET.FOR
  164.  
  165.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  166.  C
  167.  C       "WHETSTONE INSTRUCTIONS PER SECONDS" MEASURE OF FORTRAN
  168.  C       AND CPU PERFORMANCE.
  169.  C
  170.  C         References on Whetstones:    Computer Journal Feb 76
  171.  C                                      pg 43-49 vol 19 no 1.
  172.  C                                      Curnow and Wichman.
  173.  C
  174.  C                                      and Timing Studies using a
  175.  C                                      synthetic Whetstone Benchmark
  176.  C                                      S. Harbaugh & J. Forakris
  177.  C
  178.  C         References on FORTRAN Benchmarks:
  179.  C
  180.  C                                   -  Computer Languages, Jan 1986
  181.  C                                   -  EDN, Oct 3, 1985, Array Processors
  182.  C                                           for PCs
  183.  C                                   -  Byte, Feb 1984.
  184.  C
  185.  C       03/03/87
  186.  C          Seeing that Microsoft distributed this without
  187.  C          shipping the commented version, the timing loop
  188.  C          was reworked to eliminate all do loops and to put
  189.  C          in code to print the variation in the measurment to
  190.  C          make it more cook-book.  The 3 loop method described
  191.  C          below was eliminated because it caused confusion.
  192.  C          The printout was grouped and placed at the end of the test
  193.  C          so that the outputs could be checked.
  194.  C          although it is ugly code, it checks with the Ada version
  195.  C          and original article.
  196.  C          Because the Whetstones are printed as a reciprical,
  197.  C          you can not average Whetstones to reduce time errors,
  198.  C          you must run it multiple times and accumulate time.
  199.  C          (AKT)
  200.  C
  201.  C
  202.  C       01/01/87
  203.  C          fixed second subroutine to return seconds, not centi
  204.  C          seconds and used double precision variables. (AKT)
  205.  C
  206.  C       12/15/86
  207.  C          Modified by Microsoft, removed reading in loop
  208.  C          option, added timer routine, removed meta-commands
  209.  C          on large model.  Changed default looping from 100 to 10.
  210.  C
  211.  C       9/24/84
  212.  C
  213.  C          ADDED CODE TO THESE SO THAT IT HAS VARIABLE LOOPING
  214.  C
  215.  C          from DEC but DONE BY OUTSIDE CONTRACTOR, OLD STYLE CODING
  216.  C          not representative of DEC coding
  217.  C
  218.  C          A. TETEWSKY, c/o
  219.  C          555 TECH SQ MS 92
  220.  C          CAMBRIDGE MASS 02139           617/258-1287
  221.  C
  222.  C          benchmarking notes:   1)    insure that timer has
  223.  C                                      sufficient resolution and
  224.  C                                      uses elapsed CPU time
  225.  C
  226.  C                                2)    to be useful for mainframe
  227.  C                                      comparisons, measure
  228.  C                                      INTEGER*4 time and large
  229.  C                                      memory model or quote
  230.  C                                      both large and small model
  231.  C                                      times.  It may be necessary
  232.  C                                      to make the arrays in this
  233.  C                                      program large enough to span
  234.  C                                      a 64K byte boundary because
  235.  C                                      many micro compilers will
  236.  C                                      generate small model code
  237.  C                                      for small arrays even with
  238.  C                                      large models.
  239.  C
  240.  C                                 3)   Make sure that it loops
  241.  C                                      long enough to gain
  242.  C                                      stability, i.e. third-second
  243.  C                                      loop = first loop time.
  244.  C
  245.  C         research notes,
  246.  C         structure and definition:
  247.  C         I received this code as a black box and based on some
  248.  C         study, discovered the following background.
  249.  C
  250.  C            n1-n10 are loop counters for 10 tests, and tests
  251.  C            n1,n5, and n10 are skipped.
  252.  C            computed goto's are used to skip over tests that
  253.  C            are not wanted.
  254.  C
  255.  C
  256.  C            n1-n10 scale with I.   When I is set to 10,
  257.  C            kilo whets per second = 1000/ (time for doing n1-n10),
  258.  C            the definition found in the literature.
  259.  C
  260.  C            If I were 100, the scale factor would be 10,000.
  261.  C            which explains the 10,000 discovered in this code because
  262.  C            it was shipped with IMUCH wired to 100.
  263.  C
  264.  C            the original DEC version uses a do-loop,
  265.  C                  imuch=100
  266.  C                  do 200 loop=1,3
  267.  C                       i = loop*imuch
  268.  C                       n1-n10 scales by I
  269.  C                       ... whetstones here ...
  270.  C              200 continue
  271.  C
  272.  C            and it took me a while to figure out why it worked.
  273.  C
  274.  C            This code loops three times
  275.  C                 TIMES(1) is time for 1*I  whets
  276.  C                 TIMES(2) is time for 2*I
  277.  C                 TIMES(3) is time for 3*I
  278.  C            and TIMES(3)-TIMES(2) =  time for 1*I.
  279.  C            As long as TIMES(3)-TIMES(2) =  TIMES(1) to
  280.  C            4 digits, then the cycle counter is sufficiently
  281.  C            large enough for a given clock resolution.
  282.  C
  283.  C            By scaling whets * (IMUCH/10), you can alter IMUCH.
  284.  C            The default definition is IMUCH = 10, hence the factor
  285.  C            is unity.  IMUCH should be a factor of 10.
  286.  C
  287.  C
  288.  C            Problems I have found:
  289.  C            -  the SECONDS function is a single precision number
  290.  C               and as CPUs get faster, you need to loop longer
  291.  C               so that significant digits are not dropped.
  292.  C
  293.  C
  294.  C       WHETS.FOR       09/27/77     TDR
  295.  C       ...WHICH IS AN IMPROVED VERSION OF:
  296.  C       WHET2A.FTN      01/22/75     RBG
  297.  C
  298.          DOUBLE PRECISION X1,X2,X3,X4,X,Y,Z,T,T1,T2,E1
  299.          INTEGER   J,K,L,I, N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,ISAVE
  300.          COMMON    T,T1,T2,E1(4),J,K,L
  301.  C
  302.  C
  303.          REAL*8         BEGTIM, ENDTIM, DIFTIM
  304.          REAL*8         DT,  WHETS, WS, ERR, WERR, PERR
  305.          INTEGER*4      IO1, IO1L, KREP, MKREP
  306.  C
  307.          REAL*4         SECNDS
  308.          EXTERNAL       SECNDS
  309.  
  310.  C
  311.  C****************************************************************
  312.  C
  313.  C
  314.          MKREP  =    2
  315.          KREP   =    0
  316.          WRITE(*,*) ' Suggest inner > 10, outer > 1 '
  317.          WRITE(*,*) ' ENTER the number of inner/outer loops  '
  318.          READ(*,*)  I  ,IO1
  319.   7020   CONTINUE
  320.          WRITE(*,*) ' Starting ',IO1,' loops, inner loop = ',I
  321.  C       ***** BEGININNING OF TIMED INTERVAL *****
  322.          IO1L   = 0
  323.          BEGTIM = DBLE(SECNDS(0.0E+00) )
  324.   7010   CONTINUE
  325.  C
  326.  C       ... the Whetstone code here ...
  327.          ISAVE=I
  328.          T=0.499975D00
  329.          T1=0.50025D00
  330.          T2=2.0D00
  331.          N1=0
  332.          N2=12*I
  333.          N3=14*I
  334.          N4=345*I
  335.          N5=0
  336.          N6=210*I
  337.          N7=32*I
  338.          N8=899*I
  339.          N9=616*I
  340.          N10=0
  341.          N11=93*I
  342.          N12=0
  343.          X1=1.0D0
  344.          X2=-1.0D0
  345.          X3=-1.0D0
  346.          X4=-1.0D0
  347.          IF(N1)19,19,11
  348.   11     DO 18 I=1,N1,1
  349.          X1=(X1+X2+X3-X4)*T
  350.          X2=(X1+X2-X3+X4)*T
  351.          X4=(-X1+X2+X3+X4)*T
  352.          X3=(X1-X2+X3+X4)*T
  353.   18     CONTINUE
  354.   19     CONTINUE
  355.          E1(1)=1.0D0
  356.          E1(2)=-1.0D0
  357.          E1(3)=-1.0D0
  358.          E1(4)=-1.0D0
  359.          IF(N2)29,29,21
  360.   21     DO 28 I=1,N2,1
  361.          E1(1)=(E1(1)+E1(2)+E1(3)-E1(4))*T
  362.          E1(2)=(E1(1)+E1(2)-E1(3)+E1(4))*T
  363.          E1(3)=(E1(1)-E1(2)+E1(3)+E1(4))*T
  364.          E1(4)=(-E1(1)+E1(2)+E1(3)+E1(4))*T
  365.   28     CONTINUE
  366.   29     CONTINUE
  367.          IF(N3)39,39,31
  368.   31     DO 38 I=1,N3,1
  369.   38     CALL PA(E1)
  370.   39     CONTINUE
  371.          J=1
  372.          IF(N4)49,49,41
  373.   41     DO 48 I=1,N4,1
  374.          IF(J-1)43,42,43
  375.   42     J=2
  376.          GOTO44
  377.   43     J=3
  378.   44     IF(J-2)46,46,45
  379.   45     J=0
  380.          GOTO47
  381.   46     J=1
  382.   47     IF(J-1)411,412,412
  383.   411    J=1
  384.          GOTO48
  385.   412    J=0
  386.   48     CONTINUE
  387.   49     CONTINUE
  388.          J=1
  389.          K=2
  390.          L=3
  391.          IF(N6)69,69,61
  392.   61     DO 68 I=1,N6,1
  393.          J=J*(K-J)*(L-K)
  394.          K=L*K-(L-J)*K
  395.          L=(L-K)*(K+J)
  396.          E1(L-1)=J+K+L
  397.          E1(K-1)=J*K*L
  398.   68     CONTINUE
  399.   69     CONTINUE
  400.          X=0.5D0
  401.          Y=0.5D0
  402.          IF(N7)79,79,71
  403.   71     DO 78 I=1,N7,1
  404.          X=T*DATAN(T2*DSIN(X)*DCOS(X)/(DCOS(X+Y)+DCOS(X-Y)-1.0D0))
  405.          Y=T*DATAN(T2*DSIN(Y)*DCOS(Y)/(DCOS(X+Y)+DCOS(X-Y)-1.0D0))
  406.   78     CONTINUE
  407.   79     CONTINUE
  408.          X=1.0D0
  409.          Y=1.0D0
  410.          Z=1.0D0
  411.          IF(N8)89,89,81
  412.   81     DO 88 I=1,N8,1
  413.   88     CALL P3(X,Y,Z)
  414.   89     CONTINUE
  415.          J=1
  416.          K=2
  417.          L=3
  418.          E1(1)=1.0D0
  419.          E1(2)=2.0D0
  420.          E1(3)=3.0D0
  421.          IF(N9)99,99,91
  422.   91     DO 98 I=1,N9,1
  423.   98     CALL P0
  424.   99     CONTINUE
  425.          J=2
  426.          K=3
  427.          IF(N10)109,109,101
  428.   101    DO 108 I=1,N10,1
  429.          J=J+K
  430.          K=J+K
  431.          J=J-K
  432.          K=K-J-J
  433.   108    CONTINUE
  434.   109    CONTINUE
  435.          X=0.75D0
  436.          IF(N11)119,119,111
  437.   111    DO 118 I=1,N11,1
  438.   118    X=DSQRT(DEXP(DLOG(X)/T1))
  439.   119    CONTINUE
  440.          I = ISAVE
  441.  C       ... the whetstone ends here
  442.  C
  443.  C         ... loop counter instead of do loop ...
  444.            IO1L = IO1L + 1
  445.            IF( IO1L .LT. IO1) GOTO 7010
  446.  C       ******* END of TIME INTERVALED ***********
  447.  C
  448.          ENDTIM = DBLE(SECNDS(0.0E+00))
  449.          DIFTIM = ENDTIM - BEGTIM
  450.  C       whets  = 1000/(TIME FOR 10 inner ITERATIONS OF PROGRAM LOOP)
  451.  C       or 100 for every 1 inner count
  452.          WHETS = (100.0D+00* DBLE( FLOAT(IO1*I  ))/DIFTIM)
  453.          WRITE(*,*) ' START TIME = ',BEGTIM
  454.          WRITE(*,*) ' END   TIME = ',ENDTIM
  455.          WRITE(*,*) ' DIF   TIME = ',DIFTIM
  456.  C
  457.          WRITE (*,201) WHETS
  458.    201   FORMAT(' SPEED IS: ',1PE10.3,' THOUSAND WHETSTONE',
  459.       2     ' DOUBLE PRECISION INSTRUCTIONS PER SECOND')
  460.          CALL POUT(N1,N1,N1,X1,X2,X3,X4)
  461.          CALL POUT(N2,N3,N2,E1(1),E1(2),E1(3),E1(4))
  462.          CALL POUT(N3,N2,N2,E1(1),E1(2),E1(3),E1(4))
  463.          CALL POUT(N4,J,J,X1,X2,X3,X4)
  464.          CALL POUT(N6,J,K,E1(1),E1(2),E1(3),E1(4))
  465.          CALL POUT(N7,J,K,X,X,Y,Y)
  466.          CALL POUT(N8,J,K,X,Y,Z,Z)
  467.          CALL POUT(N9,J,K,E1(1),E1(2),E1(3),E1(4))
  468.          CALL POUT(N10,J,K,X1,X2,X3,X4)
  469.          CALL POUT(N11,J,K,X,X,X,X)
  470.  C
  471.  C       ... repeat but double (MULTIPLY UP) inner count ...
  472.          KREP = KREP + 1
  473.          IF( KREP .LT. MKREP) THEN
  474.              DT     = DIFTIM
  475.              WT     = WHETS
  476.              I=I*MKREP
  477.              GOTO 7020
  478.          ENDIF
  479.  C
  480.  C       ... compute sensitivity
  481.  C
  482.          ERR =  DIFTIM - (DT*DBLE(FLOAT(MKREP)))
  483.          WERR=  WT-WHETS
  484.          PERR=  WERR*100.0D+00/WHETS
  485.          WRITE(*,*) ' Time ERR = ',ERR, ' seconds '
  486.          WRITE(*,*) ' Whet ERR = ',WERR,' kwhets/sec '
  487.          WRITE(*,*) ' %    ERR = ',PERR,' % whet error '
  488.          IF( DIFTIM .LT. 10.0D+00) THEN
  489.           WRITE(*,*)
  490.       1   ' TIME is less than 10 seconds, suggest larger inner loop '
  491.          ENDIF
  492.  C
  493.          STOP
  494.          END
  495.          SUBROUTINE PA(E)
  496.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  497.          DOUBLE PRECISION T,T1,T2,E
  498.          COMMON T,T1,T2
  499.          DIMENSION E(4)
  500.          J=0
  501.   1      E(1)=(E(1)+E(2)+E(3)-E(4))*T
  502.          E(2)=(E(1)+E(2)-E(3)+E(4))*T
  503.          E(3)=(E(1)-E(2)+E(3)+E(4))*T
  504.          E(4)=(-E(1)+E(2)+E(3)+E(4))/T2
  505.          J=J+1
  506.          IF(J-6)1,2,2
  507.   2      CONTINUE
  508.          RETURN
  509.          END
  510.          SUBROUTINE P0
  511.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  512.          DOUBLE PRECISION T,T1,T2,E1
  513.          COMMON T,T1,T2,E1(4),J,K,L
  514.          E1(J)=E1(K)
  515.          E1(K)=E1(L)
  516.          E1(L)=E1(J)
  517.          RETURN
  518.          END
  519.          SUBROUTINE P3(X,Y,Z)
  520.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  521.          DOUBLE PRECISION T,T1,T2,X1,Y1,X,Y,Z
  522.          COMMON T,T1,T2
  523.          X1=X
  524.          Y1=Y
  525.          X1=T*(X1+Y1)
  526.          Y1=T*(X1+Y1)
  527.          Z=(X1+Y1)/T2
  528.          RETURN
  529.          END
  530.          SUBROUTINE POUT(N,J,K,X1,X2,X3,X4)
  531.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  532.  C
  533.  C
  534.          DOUBLE PRECISION X1,X2,X3,X4
  535.          WRITE(*,1)N,J,K,X1,X2,X3,X4
  536.   1      FORMAT('  ',3(I7,1X),4(1PD12.4,1X))
  537.          RETURN
  538.          END
  539.  
  540.  \SAMPCODE\FORTRAN\GRAPH.FOR
  541.  
  542.          INTERFACE TO INTEGER[C] FUNCTION getmod[C]
  543.          END
  544.  C
  545.  C
  546.          INTERFACE TO SUBROUTINE init[C](num)
  547.          INTEGER[C] num
  548.          END
  549.  C
  550.  C
  551.          INTERFACE TO SUBROUTINE setbck[C](num)
  552.          INTEGER[C] num
  553.          END
  554.  C
  555.  C
  556.          INTERFACE TO SUBROUTINE palett[C](num)
  557.          INTEGER[C] num
  558.          END
  559.  C
  560.  C
  561.          INTERFACE TO SUBROUTINE circle[C](x, y, rad, col)
  562.          INTEGER[C] x, y, rad, col
  563.          END
  564.  C
  565.  C
  566.  C       Change "back" between 1 and 15 and "pal" between 0 and 1 to
  567.  C       get different results.
  568.  C
  569.          PROGRAM graph
  570.          INTEGER[C] back/0/,pal/1/, imode, mode/4/, getmod
  571.          INTEGER xmax/320/, ymax/200/, radmax/18/, xcenter/160/
  572.          INTEGER y, xoff, radius, color, bumps/2/
  573.          INTEGER xoffs(4)/0, 46, 92, 140/
  574.          REAL pi
  575.          PARAMETER (pi = 3.141569265)
  576.          imode = getmod()
  577.          CALL init(mode)
  578.          CALL setbck(back)
  579.          CALL palett(pal)
  580.          DO 30 i = 1, 3
  581.                  DO 20 y = 1, ymax
  582.                          r      = (REAL(y)/ymax)*pi*bumps
  583.                          x      = SIN(r)
  584.                          radius = radmax * ABS(x)
  585.                          DO 10 j = 1, 4
  586.                                          xoff  = xoffs(j) * x
  587.                                          color = MOD(j+i-1, 3)+1
  588.                                          CALL mirror(xcenter, xoff, y, radius,
  589.  10                      CONTINUE
  590.  20              CONTINUE
  591.  30      CONTINUE
  592.          DO 40 j = 1,300000
  593.                  CALL timer
  594.  40      CONTINUE
  595.          CALL init(imode)
  596.          END
  597.  C
  598.  C
  599.          SUBROUTINE mirror(xcenter, xoff, y, radius, color)
  600.          IMPLICIT INTEGER (a-z)
  601.          CALL circle(xcenter+xoff, y, radius, color)
  602.          CALL circle(xcenter-xoff, y, radius, color)
  603.          END
  604.  C
  605.  C
  606.          SUBROUTINE timer
  607.          END
  608.  
  609.  \SAMPCODE\FORTRAN\SECNDS.FOR
  610.  
  611.  C
  612.  C     INTERFACE ROUTINE FROM DEC TO PC FOR GETTING TIME
  613.  C
  614.        FUNCTION SECNDS(X)
  615.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  616.  C
  617.  C     RETURN CURRENT TIME - MIDNIGHT - X
  618.  C
  619.  C
  620.        REAL*4    SECNDS, X
  621.  C
  622.  C
  623.        INTEGER*2 IHOUR, IMINUT, ISECON, IHUND
  624.        REAL*4    RHOUR, RMINUT, RSECON, RHUND
  625.        REAL*4    X1
  626.  C
  627.        CALL GETTIM(IHOUR, IMINUT, ISECON, IHUND)
  628.        RHOUR     =  FLOAT( IHOUR )
  629.        RMINUT    =  FLOAT( IMINUT)
  630.        RSECON    =  FLOAT( ISECON)
  631.        RHUND     =  FLOAT( IHUND )
  632.        X1        =  RHOUR*3600.0 + RMINUT*60.0 + RSECON +
  633.       &             RHUND/100.0
  634.        SECNDS    =  X1 - X
  635.  C
  636.        RETURN
  637.        END
  638.  \SAMPCODE\FORTRAN\SIEVE.FOR
  639.  
  640.          subroutine second (t1)
  641.  c
  642.  c  MS version of SECOND (timing routine)
  643.  c
  644.          integer*2 ih,im,is,ihu
  645.          integer*4 t1
  646.          call gettim (ih,im,is,ihu)
  647.          t1 = (ih*3600+im*60+is)*100+ihu
  648.          end
  649.  *     prime number sieve program (integer*4 version)
  650.  
  651.        integer*4   i, niter, count, prime
  652.          integer*4 t1,t2
  653.  c     integer   t1 (4), t2 (4)
  654.  
  655.  c     write  (*, '  ('' no. iterations: '' )   ')
  656.  c     read   (*, *) niter
  657.        niter = 10
  658.  
  659.  c     call time (t1)
  660.        call second (t1)
  661.        do 30 i = 1, niter
  662.           call sieve (count, prime)
  663.  30       continue
  664.  
  665.  c     call etime (t2, t1, niter)
  666.        call second (t2)
  667.        write  (*, 40) count, prime
  668.  40    format ('0 done', I6, ' primes, largest is ', I6)
  669.        write (*,*) 'Elapsed=',t2-t1,' sieve4 '
  670.        write (*,*) 'Average per iteration=',+(t2-t1)/niter
  671.        end
  672.  
  673.        subroutine sieve (count, largest)
  674.        integer*4         count, largest
  675.  
  676.        integer*4     size
  677.        parameter   (size = 8191)
  678.  
  679.        integer*4   i, prime, k
  680.        logical     flags (size)
  681.  
  682.        count = 0
  683.        do 10 i = 1, size
  684.           flags (i) = .true.
  685.  10       continue
  686.  
  687.        do 30 i = 1, size
  688.           if (flags (i)) then
  689.              prime = i + i + 1
  690.              do 20 k = i + prime, size, prime
  691.                 flags (k) = .false.
  692.  20             continue
  693.              count = count + 1
  694.              end if
  695.  30       continue
  696.        largest = prime
  697.        return
  698.        end
  699.  
  700.  \SAMPCODE\FORTRAN\STATS.FOR
  701.  
  702.  C**********************************************************************
  703.  C
  704.  C  STATS.FOR
  705.  C
  706.  C        Calculates simple statistics (minimum, maximum, mean, median,
  707.  C        variance, and standard deviation) of up to 50 values.
  708.  C
  709.  C        Reads one value at a time from unit 5.  Echoes values and
  710.  C        writes results to unit 6.
  711.  C
  712.  C        All calculations are done in single precision.
  713.  C
  714.  C
  715.  C***********************************************************************
  716.  
  717.  
  718.  
  719.        DIMENSION DAT(50)
  720.        OPEN(5,FILE=' ')
  721.  
  722.        N=0
  723.        DO 10 I=1,50
  724.        READ(5,99999,END=20) DAT(I)
  725.        N=I
  726.   10   CONTINUE
  727.  
  728.  C Too many values.  Write error message and die.
  729.  
  730.        WRITE(6,99998) N
  731.        STOP
  732.  
  733.  C Test to see if there's more than one value.  We don't want to divide
  734.  C by zero.
  735.  
  736.  20    IF(N.LE.1) THEN
  737.  
  738.  C Too few values. Print message and die.
  739.  
  740.           WRITE(6,99997)
  741.  
  742.        ELSE
  743.  
  744.  C Echo input values to output.
  745.  
  746.           WRITE(6,99996)
  747.           WRITE(6,99995) (DAT(I),I=1,N)
  748.  
  749.  C Calculate mean, standard deviation, and median.
  750.  
  751.           CALL MEAN (DAT,N,DMEAN)
  752.           CALL STDEV (DAT,N,DMEAN,DSTDEV,DSTVAR)
  753.           CALL MEDIAN (DAT,N,DMEDN,DMIN,DMAX)
  754.  
  755.           WRITE(6,99994) N,DMEAN,DMIN,DMAX,DMEDN,DSTVAR,DSTDEV
  756.  
  757.        ENDIF
  758.  
  759.        STOP
  760.  
  761.  99999 FORMAT(E14.6)
  762.  99998 FORMAT('0 ********STAT: TOO MANY VALUES-- ',I5)
  763.  99997 FORMAT('0 ********STAT: TOO FEW VALUES (1 OR LESS) ')
  764.  99996 FORMAT(//,10X,
  765.       +' ******************SAMPLE DATA VALUES*****************'//)
  766.  99995 FORMAT(5(1X,1PE14.6))
  767.  99994 FORMAT(///,10X,
  768.       +' ******************SAMPLE STATISTICS******************',//,
  769.       +15X,'          Sample size = ',I5,/,
  770.       +15X,'          Mean        = ',1PE14.6,/,
  771.       +15X,'          Minimum     = ',E14.6,/,
  772.       +15X,'          Maximum     = ',E14.6,/
  773.       +15X,'          Median      = ',E14.6,/
  774.       +15X,'          Variance    = ',E14.6,/
  775.       +15X,'          St deviation= ',E14.6////)
  776.  
  777.        END
  778.  
  779.  C Calculate the mean (XMEAN) of the N values in array X.
  780.  
  781.        SUBROUTINE  MEAN (X,N,XMEAN)
  782.        DIMENSION X(N)
  783.  
  784.        SUM=0.0
  785.        DO 10 I=1,N
  786.           SUM=SUM+X(I)
  787.     10 CONTINUE
  788.  
  789.        XMEAN=SUM/FLOAT(N)
  790.  
  791.        RETURN
  792.        END
  793.  
  794.  C Calculate the standard deviation (XSTDEV) and variance (XVAR)
  795.  C of the N values in X using the mean (XMEAN).
  796.  C This divides by zero when N = 1.
  797.  
  798.        SUBROUTINE STDEV (X,N,XMEAN,XSTDEV,XVAR)
  799.        DIMENSION X(N)
  800.  
  801.        SUMSQ=0.0
  802.        DO 10 I=1,N
  803.           XDIFF=X(I)-XMEAN
  804.           SUMSQ=SUMSQ+XDIFF*XDIFF
  805.     10 CONTINUE
  806.  
  807.        XVAR=SUMSQ/FLOAT(N-1)
  808.        XSTDEV=SQRT(XVAR)
  809.  
  810.        RETURN
  811.        END
  812.  
  813.  
  814.  C Calculate the median (XMEDN), minimum (XMIN), and maximum (XMAX) of
  815.  C the N values in X.
  816.  C MEDIAN sorts the array and then calculates the median value.
  817.  
  818.        SUBROUTINE MEDIAN (X,N,XMEDN,XMIN,XMAX)
  819.        DIMENSION X(N)
  820.  
  821.        CALL SORT (X,N)
  822.  
  823.        IF(MOD(N,2).EQ.0) THEN
  824.           K=N/2
  825.           XMEDN=(X(K)+X(K+1))/2.0
  826.        ELSE
  827.           K=(N+1)/2
  828.           XMEDN=X(K)
  829.        ENDIF
  830.  
  831.        XMIN=X(1)
  832.        XMAX=X(N)
  833.  
  834.        END
  835.  
  836.  C Sort the N values in array X.  SORT uses a bubble sort
  837.  C that quits when no values were exchanged on the last pass.
  838.  C Each pass goes from the first element to where the last
  839.  C exchange occurred on the previous pass.
  840.  
  841.        SUBROUTINE SORT (X,N)
  842.        DIMENSION X(N)
  843.  
  844.        IBND=N
  845.    20  IXCH=0
  846.  
  847.        DO 100 J=1,IBND-1
  848.             IF(X(J).GT.X(J+1))THEN
  849.                TEMP=X(J)
  850.                X(J)=X(J+1)
  851.                X(J+1)=TEMP
  852.                IXCH=J
  853.             ENDIF
  854.   100  CONTINUE
  855.  
  856.        IF (IXCH.EQ.0) RETURN
  857.        IBND=IXCH
  858.        GO TO 20
  859.  
  860.        END
  861.  
  862.  
  863.  \SAMPCODE\FORTRAN\SWHET.FOR
  864.  
  865.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  866.  C
  867.  C       "WHETSTONE INSTRUCTIONS PER SECONDS" MEASURE OF FORTRAN
  868.  C       AND CPU PERFORMANCE.
  869.  C
  870.  C         References on Whetstones:    Computer Journal Feb 76
  871.  C                                      pg 43-49 vol 19 no 1.
  872.  C                                      Curnow and Wichman.
  873.  C
  874.  C                                      and Timing Studies using a
  875.  C                                      synthetic Whetstone Benchmark
  876.  C                                      S. Harbaugh & J. Forakris
  877.  C
  878.  C         References on FORTRAN Benchmarks:
  879.  C
  880.  C                                   -  Computer Languages, Jan 1986
  881.  C                                   -  EDN, Oct 3, 1985, Array Processors
  882.  C                                           for PCs
  883.  C                                   -  Byte, Feb 1984.
  884.  C
  885.  C       03/03/87
  886.  C          Seeing that Microsoft distributed this without
  887.  C          shipping the commented version, the timing loop
  888.  C          was reworked to eliminate all do loops and to put
  889.  C          in code to print the variation in the measurment to
  890.  C          make it more cook-book.  The 3 loop method described
  891.  C          below was eliminated because it caused confusion.
  892.  C          The printout was grouped and placed at the end of the test
  893.  C          so that the outputs could be checked.
  894.  C          although it is ugly code, it checks with the Ada version
  895.  C          and original article.
  896.  C          Because the Whetstones are printed as a reciprical,
  897.  C          you can not average Whetstones to reduce time errors,
  898.  C          you must run it multiple times and accumulate time.
  899.  C          (AKT)
  900.  C
  901.  C
  902.  C       01/01/87
  903.  C          fixed second subroutine to return seconds, not centi
  904.  C          seconds and used double precision variables. (AKT)
  905.  C
  906.  C       12/15/86
  907.  C          Modified by Microsoft, removed reading in loop
  908.  C          option, added timer routine, removed meta-commands
  909.  C          on large model.  Changed default looping from 100 to 10.
  910.  C
  911.  C       9/24/84
  912.  C
  913.  C          ADDED CODE TO THESE SO THAT IT HAS VARIABLE LOOPING
  914.  C
  915.  C          from DEC but DONE BY OUTSIDE CONTRACTOR, OLD STYLE CODING
  916.  C          not representative of DEC coding
  917.  C
  918.  C          A. TETEWSKY, c/o
  919.  C          555 TECH SQ MS 92
  920.  C          CAMBRIDGE MASS 02139           617/258-1287
  921.  C
  922.  C          benchmarking notes:   1)    insure that timer has
  923.  C                                      sufficient resolution and
  924.  C                                      uses elapsed CPU time
  925.  C
  926.  C                                2)    to be useful for mainframe
  927.  C                                      comparisons, measure
  928.  C                                      INTEGER*4 time and large
  929.  C                                      memory model or quote
  930.  C                                      both large and small model
  931.  C                                      times.  It may be necessary
  932.  C                                      to make the arrays in this
  933.  C                                      program large enough to span
  934.  C                                      a 64K byte boundary because
  935.  C                                      many micro compilers will
  936.  C                                      generate small model code
  937.  C                                      for small arrays even with
  938.  C                                      large models.
  939.  C
  940.  C                                 3)   Make sure that it loops
  941.  C                                      long enough to gain
  942.  C                                      stability, i.e. third-second
  943.  C                                      loop = first loop time.
  944.  C
  945.  C         research notes,
  946.  C         structure and definition:
  947.  C         I received this code as a black box and based on some
  948.  C         study, discovered the following background.
  949.  C
  950.  C            n1-n10 are loop counters for 10 tests, and tests
  951.  C            n1,n5, and n10 are skipped.
  952.  C            computed goto's are used to skip over tests that
  953.  C            are not wanted.
  954.  C
  955.  C
  956.  C            n1-n10 scale with I.   When I is set to 10,
  957.  C            kilo whets per second = 1000/ (time for doing n1-n10),
  958.  C            the definition found in the literature.
  959.  C
  960.  C            If I were 100, the scale factor would be 10,000.
  961.  C            which explains the 10,000 discovered in this code because
  962.  C            it was shipped with IMUCH wired to 100.
  963.  C
  964.  C            the original DEC version uses a do-loop,
  965.  C                  imuch=100
  966.  C                  do 200 loop=1,3
  967.  C                       i = loop*imuch
  968.  C                       n1-n10 scales by I
  969.  C                       ... whetstones here ...
  970.  C              200 continue
  971.  C
  972.  C            and it took me a while to figure out why it worked.
  973.  C
  974.  C            This code loops three times
  975.  C                 TIMES(1) is time for 1*I  whets
  976.  C                 TIMES(2) is time for 2*I
  977.  C                 TIMES(3) is time for 3*I
  978.  C            and TIMES(3)-TIMES(2) =  time for 1*I.
  979.  C            As long as TIMES(3)-TIMES(2) =  TIMES(1) to
  980.  C            4 digits, then the cycle counter is sufficiently
  981.  C            large enough for a given clock resolution.
  982.  C
  983.  C            By scaling whets * (IMUCH/10), you can alter IMUCH.
  984.  C            The default definition is IMUCH = 10, hence the factor
  985.  C            is unity.  IMUCH should be a factor of 10.
  986.  C
  987.  C
  988.  C            Problems I have found:
  989.  C            -  the SECONDS function is a single precision number
  990.  C               and as CPUs get faster, you need to loop longer
  991.  C               so that significant digits are not dropped.
  992.  C
  993.  C
  994.  C       WHETS.FOR       09/27/77     TDR
  995.  C       ...WHICH IS AN IMPROVED VERSION OF:
  996.  C       WHET2A.FTN      01/22/75     RBG
  997.  C
  998.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  999.          REAL      X1,X2,X3,X4,X,Y,Z,T,T1,T2,E1
  1000.          INTEGER   J,K,L,I, N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,ISAVE
  1001.          COMMON    T,T1,T2,E1(4),J,K,L
  1002.  C
  1003.  C
  1004.          REAL*8         BEGTIM, ENDTIM, DIFTIM
  1005.          REAL*8         DT,  WHETS, WS, ERR, WERR, PERR
  1006.          INTEGER*4      IO1, IO1L, KREP, MKREP
  1007.  C
  1008.          REAL*4         SECNDS
  1009.          EXTERNAL       SECNDS
  1010.  C
  1011.  C****************************************************************
  1012.  C
  1013.  C
  1014.          MKREP  =    2
  1015.          KREP   =    0
  1016.          WRITE(*,*) ' Suggest inner > 10, outer > 1 '
  1017.          WRITE(*,*) ' ENTER the number of inner/outer loops  '
  1018.          READ(*,*)  I  ,IO1
  1019.   7020   CONTINUE
  1020.          WRITE(*,*) ' Starting ',IO1,' loops, inner loop = ',I
  1021.  C       ***** BEGININNING OF TIMED INTERVAL *****
  1022.          IO1L   = 0
  1023.          BEGTIM = DBLE(SECNDS(0.0E+00) )
  1024.   7010   CONTINUE
  1025.  C
  1026.  C       ... the Whetstone code here ...
  1027.  C
  1028.          T=0.499975E00
  1029.          T1=0.50025E00
  1030.          T2=2.0E00
  1031.  C
  1032.          ISAVE=I
  1033.          N1=0
  1034.          N2=12*I
  1035.          N3=14*I
  1036.          N4=345*I
  1037.          N5=0
  1038.          N6=210*I
  1039.          N7=32*I
  1040.          N8=899*I
  1041.          N9=616*I
  1042.          N10=0
  1043.          N11=93*I
  1044.          N12=0
  1045.          X1=1.0E0
  1046.          X2=-1.0E0
  1047.          X3=-1.0E0
  1048.          X4=-1.0E0
  1049.          IF(N1)19,19,11
  1050.   11     DO 18 I=1,N1,1
  1051.          X1=(X1+X2+X3-X4)*T
  1052.          X2=(X1+X2-X3+X4)*T
  1053.          X4=(-X1+X2+X3+X4)*T
  1054.          X3=(X1-X2+X3+X4)*T
  1055.   18     CONTINUE
  1056.   19     CONTINUE
  1057.          E1(1)=1.0E0
  1058.          E1(2)=-1.0E0
  1059.          E1(3)=-1.0E0
  1060.          E1(4)=-1.0E0
  1061.          IF(N2)29,29,21
  1062.   21     DO 28 I=1,N2,1
  1063.          E1(1)=(E1(1)+E1(2)+E1(3)-E1(4))*T
  1064.          E1(2)=(E1(1)+E1(2)-E1(3)+E1(4))*T
  1065.          E1(3)=(E1(1)-E1(2)+E1(3)+E1(4))*T
  1066.          E1(4)=(-E1(1)+E1(2)+E1(3)+E1(4))*T
  1067.   28     CONTINUE
  1068.   29     CONTINUE
  1069.          IF(N3)39,39,31
  1070.   31     DO 38 I=1,N3,1
  1071.   38     CALL PA(E1)
  1072.   39     CONTINUE
  1073.          J=1
  1074.          IF(N4)49,49,41
  1075.   41     DO 48 I=1,N4,1
  1076.          IF(J-1)43,42,43
  1077.   42     J=2
  1078.          GOTO44
  1079.   43     J=3
  1080.   44     IF(J-2)46,46,45
  1081.   45     J=0
  1082.          GOTO47
  1083.   46     J=1
  1084.   47     IF(J-1)411,412,412
  1085.   411    J=1
  1086.          GOTO48
  1087.   412    J=0
  1088.   48     CONTINUE
  1089.   49     CONTINUE
  1090.          J=1
  1091.          K=2
  1092.          L=3
  1093.          IF(N6)69,69,61
  1094.   61     DO 68 I=1,N6,1
  1095.          J=J*(K-J)*(L-K)
  1096.          K=L*K-(L-J)*K
  1097.          L=(L-K)*(K+J)
  1098.          E1(L-1)=J+K+L
  1099.          E1(K-1)=J*K*L
  1100.   68     CONTINUE
  1101.   69     CONTINUE
  1102.          X=0.5E0
  1103.          Y=0.5E0
  1104.          IF(N7)79,79,71
  1105.   71     DO 78 I=1,N7,1
  1106.          X=T*ATAN(T2*SIN(X)*COS(X)/(COS(X+Y)+COS(X-Y)-1.0E0))
  1107.          Y=T*ATAN(T2*SIN(Y)*COS(Y)/(COS(X+Y)+COS(X-Y)-1.0E0))
  1108.   78     CONTINUE
  1109.   79     CONTINUE
  1110.          X=1.0E0
  1111.          Y=1.0E0
  1112.          Z=1.0E0
  1113.          IF(N8)89,89,81
  1114.   81     DO 88 I=1,N8,1
  1115.   88     CALL P3(X,Y,Z)
  1116.   89     CONTINUE
  1117.          J=1
  1118.          K=2
  1119.          L=3
  1120.          E1(1)=1.0E0
  1121.          E1(2)=2.0E0
  1122.          E1(3)=3.0E0
  1123.          IF(N9)99,99,91
  1124.   91     DO 98 I=1,N9,1
  1125.   98     CALL P0
  1126.   99     CONTINUE
  1127.          J=2
  1128.          K=3
  1129.          IF(N10)109,109,101
  1130.   101    DO 108 I=1,N10,1
  1131.          J=J+K
  1132.          K=J+K
  1133.          J=J-K
  1134.          K=K-J-J
  1135.   108    CONTINUE
  1136.   109    CONTINUE
  1137.          X=0.75E0
  1138.          IF(N11)119,119,111
  1139.   111    DO 118 I=1,N11,1
  1140.   118    X=SQRT(EXP(ALOG(X)/T1))
  1141.   119    CONTINUE
  1142.          I = ISAVE
  1143.  C
  1144.  C       ... the whetstone ends here
  1145.  C
  1146.  C         ... loop counter instead of do loop ...
  1147.            IO1L = IO1L + 1
  1148.            IF( IO1L .LT. IO1) GOTO 7010
  1149.  C       ******* END of TIME INTERVALED ***********
  1150.  C
  1151.          ENDTIM = DBLE(SECNDS(0.0E+00))
  1152.          DIFTIM = ENDTIM - BEGTIM
  1153.  C       whets  = 1000/(TIME FOR 10 inner ITERATIONS OF PROGRAM LOOP)
  1154.  C       or 100 for every 1 inner count
  1155.          WHETS = (100.0D+00* DBLE( FLOAT(IO1*I  ))/DIFTIM)
  1156.          WRITE(*,*) ' START TIME = ',BEGTIM
  1157.          WRITE(*,*) ' END   TIME = ',ENDTIM
  1158.          WRITE(*,*) ' DIF   TIME = ',DIFTIM
  1159.  C
  1160.          WRITE (*,201) WHETS
  1161.    201   FORMAT(' SPEED IS: ',1PE10.3,' THOUSAND WHETSTONE',
  1162.       2     ' SINGLE PRECISION INSTRUCTIONS PER SECOND')
  1163.          CALL POUT(N1,N1,N1,X1,X2,X3,X4)
  1164.          CALL POUT(N2,N3,N2,E1(1),E1(2),E1(3),E1(4))
  1165.          CALL POUT(N3,N2,N2,E1(1),E1(2),E1(3),E1(4))
  1166.          CALL POUT(N4,J,J,X1,X2,X3,X4)
  1167.          CALL POUT(N6,J,K,E1(1),E1(2),E1(3),E1(4))
  1168.          CALL POUT(N7,J,K,X,X,Y,Y)
  1169.          CALL POUT(N8,J,K,X,Y,Z,Z)
  1170.          CALL POUT(N9,J,K,E1(1),E1(2),E1(3),E1(4))
  1171.          CALL POUT(N10,J,K,X1,X2,X3,X4)
  1172.          CALL POUT(N11,J,K,X,X,X,X)
  1173.  C
  1174.  C
  1175.  C       ... repeat but double (MULTIPLY UP) inner count ...
  1176.          KREP = KREP + 1
  1177.          IF( KREP .LT. MKREP) THEN
  1178.              DT     = DIFTIM
  1179.              WT     = WHETS
  1180.              I=I*MKREP
  1181.              GOTO 7020
  1182.          ENDIF
  1183.  C
  1184.  C       ... compute sensitivity
  1185.  C
  1186.          ERR =  DIFTIM - (DT*DBLE(FLOAT(MKREP)))
  1187.          WERR=  WT-WHETS
  1188.          PERR=  WERR*100.0D+00/WHETS
  1189.          WRITE(*,*) ' Time ERR = ',ERR, ' seconds '
  1190.          WRITE(*,*) ' Whet ERR = ',WERR,' kwhets/sec '
  1191.          WRITE(*,*) ' %    ERR = ',PERR,' % whet error '
  1192.          IF( DIFTIM .LT. 10.0D+00) THEN
  1193.           WRITE(*,*)
  1194.       1   ' TIME is less than 10 seconds, suggest larger inner loop '
  1195.          ENDIF
  1196.  C
  1197.          STOP
  1198.          END
  1199.  C
  1200.          SUBROUTINE PA(E)
  1201.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1202.  C
  1203.          COMMON T,T1,T2
  1204.          DIMENSION E(4)
  1205.          J=0
  1206.   1      E(1)=(E(1)+E(2)+E(3)-E(4))*T
  1207.          E(2)=(E(1)+E(2)-E(3)+E(4))*T
  1208.          E(3)=(E(1)-E(2)+E(3)+E(4))*T
  1209.          E(4)=(-E(1)+E(2)+E(3)+E(4))/T2
  1210.          J=J+1
  1211.          IF(J-6)1,2,2
  1212.   2      CONTINUE
  1213.          RETURN
  1214.          END
  1215.          SUBROUTINE P0
  1216.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1217.  C
  1218.          COMMON T,T1,T2,E1(4),J,K,L
  1219.          E1(J)=E1(K)
  1220.          E1(K)=E1(L)
  1221.          E1(L)=E1(J)
  1222.          RETURN
  1223.          END
  1224.          SUBROUTINE P3(X,Y,Z)
  1225.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1226.  C
  1227.          COMMON T,T1,T2
  1228.          X1=X
  1229.          Y1=Y
  1230.          X1=T*(X1+Y1)
  1231.          Y1=T*(X1+Y1)
  1232.          Z=(X1+Y1)/T2
  1233.          RETURN
  1234.          END
  1235.          SUBROUTINE POUT(N,J,K,X1,X2,X3,X4)
  1236.  CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1237.  C
  1238.          WRITE(*,1)N,J,K,X1,X2,X3,X4
  1239.   1      FORMAT(1H,3(I7,1X),4(1PE12.4,1X))
  1240.          RETURN
  1241.          END
  1242.  
  1243.  \SAMPCODE\FORTRAN\WHETSTON.FOR
  1244.  
  1245.  
  1246.          SUBROUTINE second (t1)
  1247.  C
  1248.  C  MS version of SECOND (timing routine)
  1249.  C
  1250.          INTEGER*2 ih,im,is,ihu
  1251.          INTEGER*4 t1
  1252.          CALL gettim(ih,im,is,ihu)
  1253.          t1 = (ih*3600+im*60+is)*100+ihu
  1254.          END
  1255.  C       WHETS.FOR       09/27/77     TDR
  1256.  C       ...WHICH IS AN IMPROVED VERSION OF:
  1257.  C       WHET2A.FTN      01/22/75     RBG
  1258.  C       DOUBLE-PRECISION VARIANT OF PROGRAM
  1259.  C
  1260.  C       "WHETSTONE INSTRUCTIONS PER SECONDS" MEASURE OF FORTRAN
  1261.  C       AND CPU PERFORMANCE.
  1262.  C
  1263.  C       9/24/84
  1264.  C
  1265.  C          ADDED CODE TO THESE SO THAT IT HAS VARIABLE LOOPING
  1266.  C
  1267.  C          from DEC but DONE BY OUTSIDE CONTRACTOR, OLD STYLE CODING
  1268.  C          not representative of DEC THIS PROGRAM IS THE
  1269.  C
  1270.  C          A. TETEWSKY, 555 TECH SQ MS 92
  1271.  C          CAMBRIDGE MASS 02139           617/258-1487
  1272.  C
  1273.  C        ========= MICROSOFT OPT CODES ===========
  1274.  C
  1275.  C        COMPILE          LINK             COMMENT
  1276.  C
  1277.  C        FLOAT            MATH             GOOD FOR ON THE FLY
  1278.  C                         8087             ONLY WITH 8087
  1279.  C                         ALTLIB           BEST W/O 8087
  1280.  C                                          IF NO 8087, FLOAT FASTER
  1281.  C                                             THEN NOFLOAT
  1282.  C
  1283.  C        NOFLOAT          MATH             BEST ON THE FLY 8087
  1284.  C                         8087             ONLY WITH 8087
  1285.  C                         ALTLIB           CAN'T DO
  1286.  C
  1287.  C                                          IF 8087, NOFLOAT
  1288.  C                                             IS BEST
  1289.  C
  1290.  C
  1291.          DOUBLE PRECISION X1,X2,X3,X4,X,Y,Z,T,T1,T2,E1
  1292.  C
  1293.          DIMENSION TIMES(3)
  1294.  C
  1295.  C       ...       END = SECNDS(X) YIELDS TIME IN SECONDS
  1296.  C                 END = TIME - MIDNITE - X
  1297.  C                 INTERFRACE YOUR ROUTINE TO SECNDS
  1298.  C
  1299.  C
  1300.  C
  1301.  C
  1302.  C       COMMON WHICH REFERENCES LOGICAL UNIT ASSIGNMENTS
  1303.  C
  1304.          INTEGER  IMUCH
  1305.          INTEGER*4 temp
  1306.  C
  1307.          COMMON T,T1,T2,E1(4),J,K,L
  1308.          COMMON /LUNS/ ICRD,ILPT,IKBD,ITTY
  1309.  C
  1310.          ITTY   =    0
  1311.          IKBD   =    0
  1312.          T      =    0.499975D00
  1313.          T1     =    0.50025D00
  1314.          T2     =    2.0D00
  1315.  
  1316.  C
  1317.          IMUCH = 10
  1318.  C
  1319.  C       ***** BEGININNING OF TIMED INTERVAL *****
  1320.          DO 200 ILOOP = 1,3
  1321.            I = ILOOP * IMUCH
  1322.  C         times(ILOOP) = SECNDS(0.)
  1323.            CALL second(temp)
  1324.            times(iloop) = temp/100.
  1325.  C       *******************************************
  1326.  C
  1327.  C       *****                               *****
  1328.  C
  1329.          ISAVE=I
  1330.          N1=0
  1331.          N2=12*I
  1332.          N3=14*I
  1333.          N4=345*I
  1334.          N5=0
  1335.          N6=210*I
  1336.          N7=32*I
  1337.          N8=899*I
  1338.          N9=616*I
  1339.          N10=0
  1340.          N11=93*I
  1341.          N12=0
  1342.          X1=1.0D0
  1343.          X2=-1.0D0
  1344.          X3=-1.0D0
  1345.          X4=-1.0D0
  1346.          IF (N1) 19,19,11
  1347.   11     DO 18 I=1,N1,1
  1348.            X1=(X1+X2+X3-X4)*T
  1349.            X2=(X1+X2-X3+X4)*T
  1350.            X4=(-X1+X2+X3+X4)*T
  1351.            X3=(X1-X2+X3+X4)*T
  1352.   18     CONTINUE
  1353.   19     CONTINUE
  1354.          CALL POUT(N1,N1,N1,X1,X2,X3,X4)
  1355.          E1(1)=1.0D0
  1356.          E1(2)=-1.0D0
  1357.          E1(3)=-1.0D0
  1358.          E1(4)=-1.0D0
  1359.          IF (N2) 29,29,21
  1360.   21     DO 28 I=1,N2,1
  1361.            E1(1)=(E1(1)+E1(2)+E1(3)-E1(4))*T
  1362.            E1(2)=(E1(1)+E1(2)-E1(3)+E1(4))*T
  1363.            E1(3)=(E1(1)-E1(2)+E1(3)+E1(4))*T
  1364.            E1(4)=(-E1(1)+E1(2)+E1(3)+E1(4))*T
  1365.   28     CONTINUE
  1366.   29     CONTINUE
  1367.          CALL POUT(N2,N3,N2,E1(1),E1(2),E1(3),E1(4))
  1368.          IF (N3) 39,39,31
  1369.   31     DO 39 I=1,N3,1
  1370.   38       CALL PA(E1)
  1371.   39     CONTINUE
  1372.          CALL POUT(N3,N2,N2,E1(1),E1(2),E1(3),E1(4))
  1373.          J=1
  1374.          IF (N4) 49,49,41
  1375.   41     DO 48 I=1,N4,1
  1376.            IF (J-1) 43,42,43
  1377.   42       J=2
  1378.            GOTO 44
  1379.   43       J=3
  1380.   44       IF (J-2) 46,46,45
  1381.   45       J=0
  1382.            GOTO 47
  1383.   46       J=1
  1384.   47       IF (J-1) 411,412,412
  1385.   411      J=1
  1386.            GOTO 48
  1387.   412      J=0
  1388.   48     CONTINUE
  1389.   49     CONTINUE
  1390.          CALL POUT(N4,J,J,X1,X2,X3,X4)
  1391.          J=1
  1392.          K=2
  1393.          L=3
  1394.          IF (N6) 69,69,61
  1395.   61     DO 68 I=1,N6,1
  1396.            J=J*(K-J)*(L-K)
  1397.            K=L*K-(L-J)*K
  1398.            L=(L-K)*(K+J)
  1399.            E1(L-1)=J+K+L
  1400.            E1(K-1)=J*K*L
  1401.   68     CONTINUE
  1402.   69     CONTINUE
  1403.          CALL POUT(N6,J,K,E1(1),E1(2),E1(3),E1(4))
  1404.          X=0.5D0
  1405.          Y=0.5D0
  1406.          IF (N7) 79,79,71
  1407.   71     DO 78 I=1,N7,1
  1408.            X=T*DATAN(T2*DSIN(X)*DCOS(X)/(DCOS(X+Y)+DCOS(X-Y)-1.0D0))
  1409.            Y=T*DATAN(T2*DSIN(Y)*DCOS(Y)/(DCOS(X+Y)+DCOS(X-Y)-1.0D0))
  1410.   78     CONTINUE
  1411.   79     CONTINUE
  1412.          CALL POUT(N7,J,K,X,X,Y,Y)
  1413.          X=1.0D0
  1414.          Y=1.0D0
  1415.          Z=1.0D0
  1416.          IF (N8) 89,89,81
  1417.   81     DO 89 I=1,N8,1
  1418.   88       CALL P3(X,Y,Z)
  1419.   89     CONTINUE
  1420.          CALL POUT(N8,J,K,X,Y,Z,Z)
  1421.          J=1
  1422.          K=2
  1423.          L=3
  1424.          E1(1)=1.0D0
  1425.          E1(2)=2.0D0
  1426.          E1(3)=3.0D0
  1427.          IF (N9) 99,99,91
  1428.   91     DO 99 I=1,N9,1
  1429.   98       CALL P0
  1430.   99     CONTINUE
  1431.          CALL POUT(N9,J,K,E1(1),E1(2),E1(3),E1(4))
  1432.          J=2
  1433.          K=3
  1434.          IF (N10) 109,109,101
  1435.   101    DO 108 I=1,N10,1
  1436.            J=J+K
  1437.            K=J+K
  1438.            J=J-K
  1439.            K=K-J-J
  1440.   108    CONTINUE
  1441.   109    CONTINUE
  1442.          CALL POUT(N10,J,K,X1,X2,X3,X4)
  1443.          X=0.75D0
  1444.          IF (N11) 119,119,111
  1445.   111    DO 119 I=1,N11,1
  1446.   118      X=DSQRT(DEXP(DLOG(X)/T1))
  1447.   119    CONTINUE
  1448.          CALL POUT(N11,J,K,X,X,X,X)
  1449.  C
  1450.  C       ***** END OF TIMED INTERVAL         *****
  1451.          CALL SECOND(TEMP)
  1452.  200     TIMES(ILOOP)=TEMP/100.-TIMES(ILOOP)
  1453.  C
  1454.  C       WHET. IPS = 1000/(TIME FOR 10 ITERATIONS OF PROGRAM LOOP)
  1455.          WHETS = (10000.0 * FLOAT(IMUCH)/100.0)/(TIMES(3)-TIMES(2))
  1456.          WRITE (*,201) WHETS
  1457.  201     FORMAT(' SPEED IS: ',1PE10.3,' THOUSAND WHETSTONE',
  1458.       2     ' DOUBLE PRECISION INSTRUCTIONS PER SECOND')
  1459.          WRITE (*,*) 'Elapsed=',INT((TIMES(3)-TIMES(1))*100),' whetd3h '
  1460.  C
  1461.  C
  1462.          STOP
  1463.          END
  1464.          SUBROUTINE PA(E)
  1465.          DOUBLE PRECISION T,T1,T2,E
  1466.          COMMON T,T1,T2
  1467.          DIMENSION E(4)
  1468.          J=0
  1469.   1      E(1)=(E(1)+E(2)+E(3)-E(4))*T
  1470.          E(2)=(E(1)+E(2)-E(3)+E(4))*T
  1471.          E(3)=(E(1)-E(2)+E(3)+E(4))*T
  1472.          E(4)=(-E(1)+E(2)+E(3)+E(4))/T2
  1473.          J=J+1
  1474.          IF (J-6) 1,2,2
  1475.   2      CONTINUE
  1476.          RETURN
  1477.          END
  1478.  
  1479.  
  1480.          SUBROUTINE P0
  1481.          DOUBLE PRECISION T,T1,T2,E1
  1482.          COMMON T,T1,T2,E1(4),J,K,L
  1483.          E1(J)=E1(K)
  1484.          E1(K)=E1(L)
  1485.          E1(L)=E1(J)
  1486.          RETURN
  1487.          END
  1488.  
  1489.  
  1490.          SUBROUTINE P3(X,Y,Z)
  1491.          DOUBLE PRECISION T,T1,T2,X1,Y1,X,Y,Z
  1492.          COMMON T,T1,T2
  1493.          X1=X
  1494.          Y1=Y
  1495.          X1=T*(X1+Y1)
  1496.          Y1=T*(X1+Y1)
  1497.          Z=(X1+Y1)/T2
  1498.          RETURN
  1499.          END
  1500.  
  1501.  
  1502.          SUBROUTINE POUT(N,J,K,X1,X2,X3,X4)
  1503.  C
  1504.  C       WRITE STATEMENT COMMENTED OUT TO IMPROVE REPEATABILITY OF TIMINGS
  1505.  C
  1506.          DOUBLE PRECISION X1,X2,X3,X4
  1507.   1      FORMAT('  ',3I7,4E12.4)
  1508.          RETURN
  1509.          END
  1510.  
  1511.  \SAMPCODE\FORTRAN\SORTDEMO.FOR
  1512.  
  1513.  $NOTRUNCATE
  1514.  $STORAGE:2
  1515.          INTERFACE TO INTEGER*2 FUNCTION KbdCharIn
  1516.       +  [ALIAS: 'KBDCHARIN']
  1517.       +  (CHARDATA,
  1518.       +   IoWait [VALUE],
  1519.       +   KbdHandle [VALUE])
  1520.  
  1521.          INTEGER*2 CHARDATA(10)*1, IoWait, KbdHandle
  1522.  
  1523.          END
  1524.  
  1525.          INTERFACE TO INTEGER*2 FUNCTION DosBeep
  1526.       +  [ALIAS: 'DOSBEEP']
  1527.       +  (Frequency [VALUE],
  1528.       +   Duration [VALUE])
  1529.  
  1530.          INTEGER*2 Frequency, Duration
  1531.  
  1532.          END
  1533.  
  1534.          INTERFACE TO INTEGER*2 FUNCTION DosGetDateTime
  1535.       +  [ALIAS: 'DOSGETDATETIME']
  1536.       +  (DateTime)
  1537.  
  1538.          INTEGER*1 DateTime(11)
  1539.  
  1540.          END
  1541.          INTERFACE TO INTEGER*2 FUNCTION DosSleep
  1542.       +  [ALIAS: 'DOSSLEEP']
  1543.       +  (TimeInterval [VALUE])
  1544.  
  1545.          INTEGER*4 TimeInterval
  1546.  
  1547.          END
  1548.  
  1549.          INTERFACE TO INTEGER*2 FUNCTION VioScrollDn
  1550.       +  [ALIAS: 'VIOSCROLLDN']
  1551.       +  (TopRow [VALUE],
  1552.       +   LeftCol [VALUE],
  1553.       +   BotRow [VALUE],
  1554.       +   RightCol [VALUE],
  1555.       +   Lines [VALUE],
  1556.       +   Cell,
  1557.       +   VioHandle [VALUE])
  1558.  
  1559.          INTEGER*2 TopRow, LeftCol, BotRow, RightCol
  1560.          INTEGER*2 Lines, Cell, VioHandle
  1561.  
  1562.          END
  1563.  
  1564.          INTERFACE TO INTEGER*2 FUNCTION VioWrtCharStrAtt
  1565.       +  [ALIAS: 'VIOWRTCHARSTRATT']
  1566.       +  (CharString,
  1567.       +   Length [VALUE],
  1568.       +   Row [VALUE],
  1569.       +   Column [VALUE],
  1570.       +   Attr,
  1571.       +   VioHandle [VALUE])
  1572.  
  1573.          CHARACTER*80 CharString
  1574.          INTEGER*2 Length, Row, Column, Attr*1, VioHandle
  1575.  
  1576.          END
  1577.  
  1578.          INTERFACE TO INTEGER*2 FUNCTION VioReadCellStr
  1579.       +  [ALIAS: 'VIOREADCELLSTR']
  1580.       +  (CellStr,
  1581.       +   Length,
  1582.       +   Row [VALUE],
  1583.       +   Column [VALUE],
  1584.       +   VioHandle [VALUE])
  1585.  
  1586.          CHARACTER*8000 CellStr
  1587.          INTEGER*2 Length, Row, Column, VioHandle
  1588.  
  1589.          END
  1590.  
  1591.          INTERFACE TO INTEGER*2 FUNCTION VioWrtCellStr
  1592.       +  [ALIAS: 'VIOWRTCELLSTR']
  1593.       +  (CellStr,
  1594.       +   Length [VALUE],
  1595.       +   Row [VALUE],
  1596.       +   Column [VALUE],
  1597.       +   VioHandle [VALUE])
  1598.  
  1599.          CHARACTER*8000 CellStr
  1600.          INTEGER*2 Length, Row, Column, VioHandle
  1601.  
  1602.          END
  1603.  
  1604.          INTERFACE TO INTEGER*2 FUNCTION VioWrtNCell
  1605.       +  [ALIAS: 'VIOWRTNCELL']
  1606.       +  (Cell,
  1607.       +   Times [VALUE],
  1608.       +   Row [VALUE],
  1609.       +   Column [VALUE],
  1610.       +   VioHandle [VALUE])
  1611.  
  1612.          INTEGER*2 Cell, Times, Row, Column, VioHandle
  1613.  
  1614.          END
  1615.  
  1616.          INTERFACE TO INTEGER*2 FUNCTION VioGetCurPos
  1617.       +  [ALIAS: 'VIOGETCURPOS']
  1618.       +  (Row,
  1619.       +   Column,
  1620.       +   VioHandle [VALUE])
  1621.  
  1622.          INTEGER*2 Row, Column, VioHandle
  1623.  
  1624.          END
  1625.  
  1626.          INTERFACE TO INTEGER*2 FUNCTION VioSetCurPos
  1627.       +  [ALIAS: 'VIOSETCURPOS']
  1628.       +  (Row [VALUE],
  1629.       +   Column [VALUE],
  1630.       +   VioHandle [VALUE])
  1631.  
  1632.          INTEGER*2 Row, Column, VioHandle
  1633.  
  1634.          END
  1635.  
  1636.          INTERFACE TO INTEGER*2 FUNCTION VioGetMode
  1637.       +  [ALIAS: 'VIOGETMODE']
  1638.       +  (MODE,
  1639.       +   VioHandle [VALUE])
  1640.  
  1641.          INTEGER*2 MODE(6), VioHandle
  1642.  
  1643.          END
  1644.  
  1645.          INTERFACE TO INTEGER*2 FUNCTION VioSetMode
  1646.       +  [ALIAS: 'VIOSETMODE']
  1647.       +  (MODE,
  1648.       +   VioHandle [VALUE])
  1649.  
  1650.          INTEGER*2 MODE(6), VioHandle
  1651.  
  1652.          END
  1653.  
  1654.        PROGRAM SortDemo
  1655.  C                                 SORTDEMO
  1656.  C This program graphically demonstrates six common sorting algorithms.  It
  1657.  C prints 25 or 43 horizontal bars, all of different lengths and all in random
  1658.  C order, then sorts the bars from smallest to longest.
  1659.  C
  1660.  C The program also uses SOUND statements to generate different pitches,
  1661.  C depending on the location of the bar being printed. Note that the SOUND
  1662.  C statements delay the speed of each sorting algorithm so you can follow
  1663.  C the progress of the sort. Therefore, the times shown are for comparison
  1664.  C only. They are not an accurate measure of sort speed.
  1665.  C
  1666.  C If you use these sorting routines in your own programs, you may notice
  1667.  C a difference in their relative speeds (for example, the exchange
  1668.  C sort may be faster than the shell sort) depending on the number of
  1669.  C elements to be sorted and how "scrambled" they are to begin with.
  1670.  C
  1671.        IMPLICIT INTEGER*2(a-z)
  1672.        CHARACTER cellstr*8000
  1673.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1674.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1675.        DIMENSION mode(6),wmode(6)
  1676.        DATA length,mode(1)/8000,12/
  1677.        gbg = VioGetCurPos(crow,ccol,0)
  1678.        gbg = VioReadCellStr(cellstr,length,0,0,0)
  1679.        gbg = VioGetMode(mode,0)
  1680.        DO 100 i=1,6
  1681.            mode(i)= mode(i)
  1682.  100   CONTINUE
  1683.  C
  1684.  C If monochrome or color burst disabled, use one color
  1685.  C
  1686.        IF((.not. btest(mode(2),0)).OR.(btest(mode(2),2))) MaxColors=1
  1687.  C
  1688.  C First try 43 lines on VGA, then EGA. If neither, use 25 lines.
  1689.  C
  1690.        IF(wmode(4).NE.43) THEN
  1691.          wmode(4)=43
  1692.          wmode(5)=640
  1693.          wmode(6)=350
  1694.          IF(VioSetMode(wmode,0).NE.0) THEN
  1695.            wmode(5)=720
  1696.            wmode(6)=400
  1697.            IF(VioSetMode(wmode,0).NE.0) THEN
  1698.              gbg=VioGetMode(wmode,0)
  1699.              MaxBars=25
  1700.              wmode(4)=25
  1701.              gbg=VioSetMode(wmode,0)
  1702.            ENDIF
  1703.          ENDIF
  1704.        ENDIF
  1705.        CALL Initialize
  1706.        CALL SortMenu
  1707.        IF(mode(4).NE.MaxBars) gbg = VioSetMode(mode,0)
  1708.        gbg = VioWrtCellStr(cellstr,length,0,0,0)
  1709.        gbg = VioSetCurPos(crow,ccol,0)
  1710.        END
  1711.  
  1712.        BLOCK DATA
  1713.        IMPLICIT INTEGER*2(a-z)
  1714.        LOGICAL Sound
  1715.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1716.        DATA MaxBars/43/,MaxColors/15/,Sound/.TRUE./,Pause/30/
  1717.        END
  1718.  
  1719.        SUBROUTINE BoxInit
  1720.  C
  1721.  C =============================== BoxInit ===================================
  1722.  C    Calls the DrawFrame procedure to draw the frame around the sort menu,
  1723.  C    then prints the different options stored in the OptionTitle array.
  1724.  C ===========================================================================
  1725.  C
  1726.        IMPLICIT INTEGER*2(a-z)
  1727.        INTEGER*1 COLOR
  1728.        PARAMETER (COLOR=15,FIRSTMENU=1,LEFT=48,LINELENGTH=30,NLINES=18,
  1729.       +           WIDTH=80-LEFT)
  1730.        CHARACTER Factor*4,menu(NLINES)*30
  1731.        LOGICAL Sound
  1732.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1733.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1734.        DATA menu/
  1735.       +      '     FORTRAN Sorting Demo',
  1736.       +      ' ',
  1737.       +      'Insertion',
  1738.       +      'Bubble',
  1739.       +      'Heap',
  1740.       +      'Exchange',
  1741.       +      'Shell',
  1742.       +      'Quick',
  1743.       +      ' ',
  1744.       +      'Toggle Sound: ',
  1745.       +      ' ',
  1746.       +      'Pause Factor: ',
  1747.       +      '<   (Slower)',
  1748.       +      '>   (Faster)',
  1749.       +      ' ',
  1750.       +      'Type first character of',
  1751.       +      'choice ( I B H E S Q T < > )',
  1752.       +      'or ESC key to end program: '/
  1753.  C
  1754.        CALL DrawFrame (1,LEFT-3,WIDTH+3,22)
  1755.  C
  1756.        DO 100 i=1,NLINES
  1757.          gbg = VioWrtCharStrAtt(menu(i),LINELENGTH,FIRSTMENU + i,
  1758.       +                         LEFT,COLOR,0)
  1759.  100   CONTINUE
  1760.        WRITE(Factor,'(I2.2)')Pause/30
  1761.        gbg = VioWrtCharStrAtt(Factor,len(Factor),13,LEFT+14,COLOR,0)
  1762.  C
  1763.  C Erase the speed option if the length of the Pause is at a limit
  1764.  C
  1765.        IF(Pause.EQ.900) THEN
  1766.          gbg = VioWrtCharStrAtt('            ',12,14,LEFT,COLOR,0)
  1767.        ELSEIF(Pause.EQ.0) THEN
  1768.          gbg = VioWrtCharStrAtt('            ',12,15,LEFT,COLOR,0)
  1769.        ENDIF
  1770.  C
  1771.  C Print the current value for Sound:
  1772.  C
  1773.        IF(Sound) THEN
  1774.          gbg = VioWrtCharStrAtt('ON ',3,11,LEFT+14,COLOR,0)
  1775.        ELSE
  1776.          gbg = VioWrtCharStrAtt('OFF',3,11,LEFT+14,COLOR,0)
  1777.        ENDIF
  1778.  C
  1779.        RETURN
  1780.        END
  1781.  
  1782.        SUBROUTINE BubbleSort
  1783.  C
  1784.  C ============================== BubbleSort =================================
  1785.  C    The BubbleSort algorithm cycles through SortArray, comparing adjacent
  1786.  C    elements and swapping pairs that are out of order.  It continues to
  1787.  C    do this until no pairs are swapped.
  1788.  C ===========================================================================
  1789.  C
  1790.        IMPLICIT INTEGER*2(a-z)
  1791.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1792.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1793.  C
  1794.        limit = MaxBars
  1795.  1     CONTINUE
  1796.        switch = 0
  1797.        DO 100 row=1,limit-1
  1798.  C
  1799.  C Two adjacent elements are out of order, so swap their values
  1800.  C and redraw those two bars:
  1801.  C
  1802.          IF(SortArray(BARLENGTH,row).GT.SortArray(BARLENGTH,row+1)) THEN
  1803.            CALL SwapSortArray(row,row+1)
  1804.            CALL SwapBars(row,row+1)
  1805.            switch = row
  1806.          ENDIF
  1807.  100   CONTINUE
  1808.  C
  1809.  C Sort on next pass only to where the last switch was made:
  1810.  C
  1811.        limit = switch
  1812.        IF(switch.NE.0) GO TO 1
  1813.        RETURN
  1814.        END
  1815.  
  1816.        SUBROUTINE DrawFrame(Top,Left,Width,Height)
  1817.  C
  1818.  C ============================== DrawFrame ==================================
  1819.  C   Draws a rectangular frame using the high-order ASCII characters ╔ (201) ,
  1820.  C   ╗ (187) , ╚ (200) , ╝ (188) , ║ (186) , and ═ (205).
  1821.  C ===========================================================================
  1822.  C
  1823.        IMPLICIT INTEGER*2(a-z)
  1824.  C
  1825.        CHARACTER tempstr*80
  1826.        INTEGER*1 Attr,COLOR
  1827.        PARAMETER (ULEFT=201,URIGHT=187,LLEFT=200,LRIGHT=188,
  1828.       +           VERTICAL=186,HORIZONTAL=205,SPACE=32,COLOR=15)
  1829.  C
  1830.        Attr=COLOR
  1831.        CellAttr=ishl(COLOR,8)
  1832.        bottom=Top+Height-1
  1833.        right=Left+Width-1
  1834.        gbg = VioWrtNCell(ior(CellAttr,ULEFT),1,Top,Left,0)
  1835.        gbg = VioWrtNCell(ior(CellAttr,HORIZONTAL),
  1836.       +                  Width-2,Top,Left+1,0)
  1837.        gbg = VioWrtNCell(ior(CellAttr,URIGHT),1,Top,right,0)
  1838.        tempstr(1:1)=char(VERTICAL)
  1839.        DO 100 i=2,Width-1
  1840.          tempstr(i:i)=char(SPACE)
  1841.  100   CONTINUE
  1842.        tempstr(Width:Width)=char(VERTICAL)
  1843.        DO 200 i=1,Height-2
  1844.          gbg = VioWrtCharStrAtt(tempstr,Width,i+Top,Left,COLOR,0)
  1845.  200   CONTINUE
  1846.        gbg = VioWrtNCell(ior(CellAttr,LLEFT),1,bottom,Left,0)
  1847.        gbg = VioWrtNCell(ior(CellAttr,HORIZONTAL),
  1848.       +                  Width-2,bottom,Left+1,0)
  1849.        gbg = VioWrtNCell(ior(CellAttr,LRIGHT),1,bottom,right,0)
  1850.        RETURN
  1851.        END
  1852.  
  1853.        SUBROUTINE ElapsedTime(CurrentRow)
  1854.  C
  1855.  C ============================= ElapsedTime =================================
  1856.  C    Prints seconds elapsed since the given sorting routine started.
  1857.  C    Note that this time includes both the time it takes to redraw the
  1858.  C    bars plus the pause while the SOUND statement plays a note, and
  1859.  C    thus is not an accurate indication of sorting speed.
  1860.  C ===========================================================================
  1861.  C
  1862.        IMPLICIT INTEGER*2(a-z)
  1863.        CHARACTER Timing*7
  1864.        INTEGER*1 DateTime(12),COLOR
  1865.        INTEGER*4 time0,time1
  1866.        LOGICAL Sound
  1867.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1868.        COMMON /time/time0
  1869.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1870.        PARAMETER (COLOR=15,FIRSTMENU=1,LEFT=48)
  1871.        gbg = DosGetDateTime(DateTime)
  1872.        time1=DateTime(1)*360000+
  1873.       +      DateTime(2)*6000+
  1874.       +      DateTime(3)*100+
  1875.       +      DateTime(4)
  1876.        WRITE(Timing,'(F7.2)')float(time1-time0)/100.
  1877.  C
  1878.  C Print the number of seconds elapsed
  1879.  C
  1880.        gbg = VioWrtCharStrAtt(Timing,len(Timing),Select+FIRSTMENU+3,
  1881.       +                       LEFT+15,COLOR,0)
  1882.  C
  1883.        IF(Sound) gbg = DosBeep(60*CurrentRow,32)
  1884.        gbg = DosSleep(int4(Pause))
  1885.        RETURN
  1886.        END
  1887.  
  1888.        SUBROUTINE ExchangeSort
  1889.  C
  1890.  C ============================= ExchangeSort ================================
  1891.  C   The ExchangeSort compares each element in SortArray - starting with
  1892.  C   the first element - with every following element.  If any of the
  1893.  C   following elements is smaller than the current element, it is exchanged
  1894.  C   with the current element and the process is repeated for the next
  1895.  C   element in SortArray.
  1896.  C ===========================================================================
  1897.  C
  1898.        IMPLICIT INTEGER*2(a-z)
  1899.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1900.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1901.  C
  1902.        DO 100 Row=1,MaxBars-1
  1903.          SmallestRow = Row
  1904.          DO 200 j=Row+1,MaxBars
  1905.            IF(SortArray(BARLENGTH,j) .LT.
  1906.       +       SortArray(BARLENGTH,SmallestRow)) THEN
  1907.              SmallestRow = j
  1908.              CALL ElapsedTime(j)
  1909.            ENDIF
  1910.  200     CONTINUE
  1911.          IF(SmallestRow.GT.Row) THEN
  1912.  C
  1913.  C       Found a row shorter than the current row, so swap those
  1914.  C       two array elements:
  1915.  C
  1916.            CALL SwapSortArray(Row,SmallestRow)
  1917.            CALL SwapBars(Row,SmallestRow)
  1918.          ENDIF
  1919.  100   CONTINUE
  1920.        RETURN
  1921.        END
  1922.  
  1923.        SUBROUTINE HeapSort
  1924.  C
  1925.  C =============================== HeapSort ==================================
  1926.  C  The HeapSort procedure works by calling two other procedures - PercolateUp
  1927.  C  and PercolateDown.  PercolateUp turns SortArray into a "heap," which has
  1928.  C  the properties outlined in the diagram below:
  1929.  C
  1930.  C                               SortArray(1)
  1931.  C                               /          \
  1932.  C                    SortArray(2)           SortArray(3)
  1933.  C                   /          \            /          \
  1934.  C         SortArray(4)   SortArray(5)   SortArray(6)  SortArray(7)
  1935.  C          /      \       /       \       /      \      /      \
  1936.  C        ...      ...   ...       ...   ...      ...  ...      ...
  1937.  C
  1938.  C
  1939.  C  where each "parent node" is greater than each of its "child nodes"; for
  1940.  C  example, SortArray(1) is greater than SortArray(2) or SortArray(3),
  1941.  C  SortArray(3) is greater than SortArray(6) or SortArray(7), and so forth.
  1942.  C
  1943.  C  Therefore, once the first FOR...NEXT loop in HeapSort is finished, the
  1944.  C  largest element is in SortArray(1).
  1945.  C
  1946.  C  The second FOR...NEXT loop in HeapSort swaps the element in SortArray(1)
  1947.  C  with the element in MaxRow, rebuilds the heap (with PercolateDown) for
  1948.  C  MaxRow - 1, then swaps the element in SortArray(1) with the element in
  1949.  C  MaxRow - 1, rebuilds the heap for MaxRow - 2, and continues in this way
  1950.  C  until the array is sorted.
  1951.  C ===========================================================================
  1952.  C
  1953.        IMPLICIT INTEGER*2(a-z)
  1954.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1955.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1956.  C
  1957.        DO 100 i=2,MaxBars
  1958.          CALL PercolateUp(i)
  1959.  100   CONTINUE
  1960.  C
  1961.        DO 200 i=MaxBars,2,-1
  1962.          CALL SwapSortArray(1,i)
  1963.          CALL SwapBars(1,i)
  1964.          CALL PercolateDown(i-1)
  1965.  200   CONTINUE
  1966.        RETURN
  1967.        END
  1968.  
  1969.        SUBROUTINE Initialize
  1970.  C
  1971.  C ============================== Initialize =================================
  1972.  C    Initializes the SortBackup and OptionTitle arrays.  It also calls the
  1973.  C    BoxInit procedure.
  1974.  C ===========================================================================
  1975.  C
  1976.        IMPLICIT INTEGER*2(a-z)
  1977.        INTEGER*1 DateTime(11)
  1978.        LOGICAL Sound
  1979.        REAL Seed,SRand
  1980.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  1981.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  1982.  C
  1983.        DIMENSION temparray(43)
  1984.        BARLENGTH = 1
  1985.        BARCOLOR = 2
  1986.        DO 100 i=1,MaxBars
  1987.          temparray(i) = i
  1988.  100   CONTINUE
  1989.  C
  1990.  C Seed the random-number generator.
  1991.  C
  1992.        gbg = DosGetDateTime(DateTime)
  1993.        Seed = DateTime(1)*3600+DateTime(2)*60+DateTime(3)
  1994.        Seed = SRand(Seed/86400.*259199.)
  1995.  C
  1996.        MaxIndex = MaxBars
  1997.        DO 200 i=1,MaxBars
  1998.  C
  1999.  C Find a random element in TempArray between 1 and MaxIndex,
  2000.  C then assign the value in that element to LengthBar
  2001.  C
  2002.          index = RANDLIM(1,MaxIndex)
  2003.          lengthbar = temparray(index)
  2004.  C
  2005.  C Overwrite the value in TempArray(Index) with the value in
  2006.  C TempArray(MaxIndex) so the value in TempArray(Index) is
  2007.  C chosen only once:
  2008.  C
  2009.          temparray(index) = temparray(MaxIndex)
  2010.  C
  2011.  C Decrease the value of MaxIndex so that TempArray(MaxIndex) can't
  2012.  C be chosen on the next pass through the loop:
  2013.  C
  2014.          MaxIndex = MaxIndex - 1
  2015.  C
  2016.          SortBackup(BARLENGTH,i) = LengthBar
  2017.          IF(MaxColors.EQ.1) THEN
  2018.            SortBackup(BARCOLOR,i) = 7
  2019.          ELSE
  2020.            SortBackup(BARCOLOR,i) = mod(LengthBar,MaxColors) + 1
  2021.          ENDIF
  2022.  200   CONTINUE
  2023.        CALL cls
  2024.  C Assign values in SortBackup to SortArray and draw unsorted bars on the scre
  2025.        CALL Reinitialize
  2026.  C Draw frame for the sort menu and print options.
  2027.        CALL BoxInit
  2028.        RETURN
  2029.        END
  2030.  
  2031.        SUBROUTINE InsertionSort
  2032.  C
  2033.  C ============================= InsertionSort ===============================
  2034.  C   The InsertionSort procedure compares the length of each successive
  2035.  C   element in SortArray with the lengths of all the preceding elements.
  2036.  C   When the procedure finds the appropriate place for the new element, it
  2037.  C   inserts the element in its new place, and moves all the other elements
  2038.  C   down one place.
  2039.  C ===========================================================================
  2040.  C
  2041.        IMPLICIT INTEGER*2(a-z)
  2042.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  2043.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2044.        DIMENSION TempArray(2)
  2045.        DO 100 Row=2,MaxBars
  2046.          TempArray(BARLENGTH) = SortArray(BARLENGTH,Row)
  2047.          TempArray(BARCOLOR) = SortArray(BARCOLOR,Row)
  2048.          DO 200 j=Row,2,-1
  2049.  C
  2050.  C As long as the length of the j-1st element is greater than the
  2051.  C length of the original element in SortArray(Row), keep shifting
  2052.  C the array elements down:
  2053.  C
  2054.            IF(SortArray(BARLENGTH,j - 1).GT.TempArray(BARLENGTH)) THEN
  2055.              SortArray(BARLENGTH,j) = SortArray(BARLENGTH,j - 1)
  2056.              SortArray(BARCOLOR,j) = SortArray(BARCOLOR,j - 1)
  2057.              CALL PrintOneBar(j)
  2058.              CALL ElapsedTime(j)
  2059.            ELSE
  2060.              GO TO 201
  2061.            ENDIF
  2062.  200     CONTINUE
  2063.  201   CONTINUE
  2064.  C
  2065.  C Insert the original value of SortArray(Row) in SortArray(j):
  2066.  C
  2067.        SortArray(BARLENGTH,j) = TempArray(BARLENGTH)
  2068.        SortArray(BARCOLOR,j) = TempArray(BARCOLOR)
  2069.        CALL PrintOneBar(j)
  2070.        CALL ElapsedTime(j)
  2071.  100   CONTINUE
  2072.        RETURN
  2073.        END
  2074.  
  2075.  C
  2076.  C ============================ PercolateDown ================================
  2077.  C   The PercolateDown procedure restores the elements of SortArray from 1 to
  2078.  C   MaxLevel to a "heap" (see the diagram with the HeapSort procedure).
  2079.  C ===========================================================================
  2080.  C
  2081.        SUBROUTINE PercolateDown(MaxLevel)
  2082.        IMPLICIT INTEGER*2(a-z)
  2083.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2084.  C
  2085.        i = 1
  2086.  C
  2087.  C Move the value in SortArray(1) down the heap until it has reached
  2088.  C its proper node (that is, until it is less than its parent node
  2089.  C or until it has reached MaxLevel, the bottom of the current heap):
  2090.  C
  2091.  1     CONTINUE
  2092.  C Get the subscript for the child node.
  2093.        Child = 2 * i
  2094.  C
  2095.  C Reached the bottom of the heap, so exit this procedure:
  2096.  C
  2097.        IF(Child.GT.MaxLevel) RETURN
  2098.  C
  2099.  C If there are two child nodes, find out which one is bigger:
  2100.  C
  2101.        IF(Child+1.LE.MaxLevel) THEN
  2102.          IF(SortArray(BARLENGTH,Child+1).GT.SortArray(BARLENGTH,Child))
  2103.       +    Child=Child+1
  2104.        ENDIF
  2105.  C
  2106.  C Move the value down if it is still not bigger than either one of
  2107.  C its children:
  2108.  C
  2109.        IF(SortArray(BARLENGTH,i).LT.SortArray(BARLENGTH,Child)) THEN
  2110.          CALL SwapSortArray(i,Child)
  2111.          CALL SwapBars(i,Child)
  2112.          i = Child
  2113.        ELSE
  2114.  C
  2115.  C Otherwise, SortArray has been restored to a heap from 1 to
  2116.  C MaxLevel, so exit:
  2117.  C
  2118.          RETURN
  2119.        ENDIF
  2120.        GO TO 1
  2121.        END
  2122.  
  2123.        SUBROUTINE PercolateUp(MaxLevel)
  2124.  C
  2125.  C ============================== PercolateUp ================================
  2126.  C   The PercolateUp procedure converts the elements from 1 to MaxLevel in
  2127.  C   SortArray into a "heap" (see the diagram with the HeapSort procedure).
  2128.  C ===========================================================================
  2129.  C
  2130.        IMPLICIT INTEGER*2(a-z)
  2131.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2132.  C
  2133.        i = MaxLevel
  2134.  C
  2135.  C Move the value in SortArray(MaxLevel) up the heap until it has
  2136.  C reached its proper node (that is, until it is greater than either
  2137.  C of its child nodes, or until it has reached 1, the top of the heap):
  2138.  C
  2139.  1     CONTINUE
  2140.        IF(i.EQ.1) RETURN
  2141.  C Get the subscript for the parent node.
  2142.        Parent = i / 2
  2143.  C
  2144.  C The value at the current node is still bigger than the value at
  2145.  C its parent node, so swap these two array elements:
  2146.  C
  2147.        IF(SortArray(BARLENGTH,i).GT.SortArray(BARLENGTH,Parent)) THEN
  2148.          CALL SwapSortArray(Parent,i)
  2149.          CALL SwapBars(Parent,i)
  2150.          i = Parent
  2151.          GO TO 1
  2152.        ENDIF
  2153.  C
  2154.  C Otherwise, the element has reached its proper place in the heap,
  2155.  C so exit this procedure:
  2156.  C
  2157.        RETURN
  2158.        END
  2159.  
  2160.        SUBROUTINE PrintOneBar(Row)
  2161.  C
  2162.  C ============================== PrintOneBar ================================
  2163.  C  Prints SortArray(BARLENGTH,Row) at the row indicated by the Row
  2164.  C  parameter, using the color in SortArray(BARCOLOR,Row)
  2165.  C ===========================================================================
  2166.  C
  2167.        IMPLICIT INTEGER*2(a-z)
  2168.        PARAMETER (BLOCK=223,SPACE=16#0720)
  2169.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  2170.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2171.  C
  2172.        gbg = VioWrtNCell(ior(ishl(SortArray(BARCOLOR,ROW),8),BLOCK),
  2173.       +                  SortArray(BARLENGTH,Row),Row,1,0)
  2174.        blanks=MaxBars-SortArray(BARLENGTH,Row)
  2175.        IF(blanks.GT.0)
  2176.       +  gbg = VioWrtNCell(SPACE,blanks,Row,SortArray(BARLENGTH,Row)+1,0)
  2177.        RETURN
  2178.        END
  2179.  
  2180.        SUBROUTINE QuickSort(Low,High)
  2181.        IMPLICIT INTEGER*2(a-z)
  2182.        PARAMETER (LOG2MAXBARS=6)
  2183.        INTEGER*1 StackPtr,Upper(LOG2MAXBARS),Lower(LOG2MAXBARS)
  2184.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2185.        Lower(1)=Low
  2186.        Upper(1)=High
  2187.        StackPtr=1
  2188.  100   CONTINUE
  2189.        IF(Lower(StackPtr).GE.Upper(StackPtr)) THEN
  2190.          StackPtr = StackPtr - 1
  2191.        ELSE
  2192.          i = Lower(StackPtr)
  2193.          j = Upper(StackPtr)
  2194.          Pivot = SortArray(BARLENGTH,j)
  2195.  200     CONTINUE
  2196.  300     IF(i.LT.j.AND.SortArray(BARLENGTH,i).LE.Pivot) THEN
  2197.            i = i + 1
  2198.            GO TO 300
  2199.          ENDIF
  2200.  400     IF(j.GT.i.AND.SortArray(BARLENGTH,j).GE.Pivot) THEN
  2201.            j = j - 1
  2202.            GO TO 400
  2203.          ENDIF
  2204.          IF(i.LT.j)THEN
  2205.            CALL SwapSortArray(i,j)
  2206.            CALL SwapBars(i,j)
  2207.         ENDIF
  2208.          IF(i.LT.j) GO TO 200
  2209.          j = Upper(StackPtr)
  2210.          CALL SwapSortArray(i,j)
  2211.          CALL SwapBars(i,j)
  2212.          IF(i-Lower(StackPtr).LT.Upper(StackPtr)-i) THEN
  2213.            Lower(StackPtr+1) = Lower(StackPtr)
  2214.            Upper(StackPtr+1) = i - 1
  2215.            Lower(StackPtr) = i + 1
  2216.          ELSE
  2217.            Lower(StackPtr+1) = i + 1
  2218.            Upper(StackPtr+1) = Upper(StackPtr)
  2219.            Upper(StackPtr) = i - 1
  2220.          ENDIF
  2221.          StackPtr = StackPtr + 1
  2222.        ENDIF
  2223.        IF(StackPtr.GT.0) GO TO 100
  2224.        RETURN
  2225.        END
  2226.  
  2227.        INTEGER FUNCTION RandLim (Lo,Hi)
  2228.        IMPLICIT INTEGER*2(a-z)
  2229.        REAL Seed,SRand,X
  2230.        Seed = mod(int(Seed)*7141+54773,259200)
  2231.        RandLim = Lo+(Hi-Lo+1)*Seed/259200
  2232.        RETURN
  2233.  C
  2234.  C    REAL FUNCTION SRand (Seed)
  2235.  C    initializes either generator (Seed = 0. to 259199.)
  2236.  C
  2237.        ENTRY SRand (X)
  2238.        SRand = X
  2239.        Seed = X
  2240.        RETURN
  2241.        END
  2242.  
  2243.        SUBROUTINE Reinitialize
  2244.  C
  2245.  C ============================== Reinitialize ===============================
  2246.  C   Restores the array SortArray to its original unsorted state while
  2247.  C   displaying the unsorted color bars.
  2248.  C ===========================================================================
  2249.  C
  2250.        IMPLICIT INTEGER*2(a-z)
  2251.        INTEGER*1 DateTime(11)
  2252.        INTEGER*4 time0
  2253.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  2254.        COMMON /time/time0
  2255.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2256.  C
  2257.        DO 100 row=1,MaxBars
  2258.          SortArray(BARLENGTH,row)=SortBackup(BARLENGTH,row)
  2259.          SortArray(BARCOLOR,row)=SortBackup(BARCOLOR,row)
  2260.          CALL PrintOneBar(row)
  2261.  100   CONTINUE
  2262.        gbg = DosGetDateTime(DateTime)
  2263.        time0=DateTime(1)*360000+
  2264.       +      DateTime(2)*6000+
  2265.       +      DateTime(3)*100+
  2266.       +      DateTime(4)
  2267.        RETURN
  2268.        END
  2269.  
  2270.        SUBROUTINE ShellSort
  2271.  C
  2272.  C =============================== ShellSort =================================
  2273.  C  The ShellSort procedure is similar to the BubbleSort procedure.  However,
  2274.  C  ShellSort begins by comparing elements that are far apart (separated by
  2275.  C  the value of the Offset variable, which is initially half the distance
  2276.  C  between the first and last element), then comparing elements that are
  2277.  C  closer together (when Offset is one, the last iteration of this procedure
  2278.  C  is merely a bubble sort).
  2279.  C ===========================================================================
  2280.  C
  2281.        IMPLICIT INTEGER*2(a-z)
  2282.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  2283.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2284.  C
  2285.  C Set comparison offset to half the number of records in SortArray:
  2286.  C
  2287.        Offset = MaxBars / 2
  2288.  1     CONTINUE
  2289.        Limit = MaxBars - Offset
  2290.  2     CONTINUE
  2291.  C Assume no switches at this offset.
  2292.        Switch = 0
  2293.  C
  2294.  C Compare elements and switch ones out of order:
  2295.        DO 100 Row=1,Limit
  2296.          IF(SortArray(BARLENGTH,Row).GT.
  2297.       +     SortArray(BARLENGTH,Row+Offset)) THEN
  2298.            CALL SwapSortArray(Row,Row+Offset)
  2299.            CALL SwapBars (Row, Row + Offset)
  2300.            Switch = Row
  2301.          ENDIF
  2302.  100   CONTINUE
  2303.  C Sort on next pass only to where last switch was made:
  2304.        Limit = Switch - Offset
  2305.        IF(Switch.GT.0) GO TO 2
  2306.  C
  2307.  C No switches at last offset, try one half as big:
  2308.  C
  2309.        Offset = Offset / 2
  2310.        IF(Offset.GT.0) GO TO 1
  2311.        RETURN
  2312.        END
  2313.  
  2314.        SUBROUTINE SortMenu
  2315.  C
  2316.  C =============================== SortMenu ==================================
  2317.  C   The SortMenu procedure first calls the Reinitialize procedure to make
  2318.  C   sure the SortArray is in its unsorted form, then prompts the user to
  2319.  C   make one of the following choices:
  2320.  C
  2321.  C               * One of the sorting algorithms
  2322.  C               * Toggle sound on or off
  2323.  C               * Increase or decrease speed
  2324.  C               * End the program
  2325.  C ===========================================================================
  2326.  C
  2327.        IMPLICIT INTEGER*2(a-z)
  2328.        PARAMETER (FIRSTMENU=1,LEFT=48,NLINES=18,SPACE=32)
  2329.        CHARACTER inkey*1
  2330.        INTEGER*1 chardata(10)
  2331.        LOGICAL Sound
  2332.        COMMON /misc/MaxBars,MaxColors,Sound,Pause
  2333.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2334.  C
  2335.  C     Locate the cursor
  2336.  C
  2337.        gbg = VioSetCurPos(FIRSTMENU + NLINES, 75, 0)
  2338.  C
  2339.  1     CONTINUE
  2340.        gbg = KbdCharIn(chardata,0,0)
  2341.        inkey=char(chardata(1))
  2342.        IF(lge(inkey,'a').AND.lle(inkey,'z'))
  2343.       +  inkey=char(ichar(inkey)-SPACE)
  2344.  C
  2345.  C        /* Branch to the appropriate procedure depending on the key typed: *
  2346.  C
  2347.        IF(inkey.EQ.'I') THEN
  2348.          Select = 0
  2349.          CALL Reinitialize
  2350.          CALL InsertionSort
  2351.          CALL ElapsedTime(0)
  2352.        ELSEIF(inkey.EQ.'B') THEN
  2353.          Select = 1
  2354.          CALL Reinitialize
  2355.          CALL BubbleSort
  2356.          CALL ElapsedTime(0)
  2357.        ELSEIF(inkey.EQ.'H') THEN
  2358.          Select = 2
  2359.          CALL Reinitialize
  2360.          CALL HeapSort
  2361.          CALL ElapsedTime(0)
  2362.        ELSEIF(inkey.EQ.'E') THEN
  2363.          Select = 3
  2364.          CALL Reinitialize
  2365.          CALL ExchangeSort
  2366.          CALL ElapsedTime(0)
  2367.        ELSEIF(inkey.EQ.'S') THEN
  2368.          Select = 4
  2369.          CALL Reinitialize
  2370.          CALL ShellSort
  2371.          CALL ElapsedTime(0)
  2372.        ELSEIF(inkey.EQ.'Q') THEN
  2373.          Select = 5
  2374.          CALL Reinitialize
  2375.          CALL QuickSort (1, MaxBars)
  2376.          CALL ElapsedTime(0)
  2377.        ELSEIF(inkey.EQ.'T') THEN
  2378.  C
  2379.  C       Toggle the sound, then redraw the menu to clear any timing
  2380.  C       results (since they won't compare with future results):
  2381.  C
  2382.          Sound=.NOT.Sound
  2383.          CALL Boxinit
  2384.        ELSEIF(inkey.EQ.'<') THEN
  2385.  C
  2386.  C       Increase pause length to slow down sorting time, then redraw
  2387.  C       the menu to clear any timing results (since they won't compare
  2388.  C       with future results):
  2389.  C
  2390.          IF(Pause.NE.900) THEN
  2391.            Pause = Pause + 30
  2392.            CALL BoxInit
  2393.          ENDIF
  2394.        ELSEIF(inkey.EQ.'>') THEN
  2395.  C
  2396.  C       Decrease pause length to speed up sorting time, then redraw
  2397.  C       the menu to clear any timing results (since they won't compare
  2398.  C       with future results):
  2399.  C
  2400.          IF(Pause.NE.0) THEN
  2401.            Pause = Pause - 30
  2402.            CALL BoxInit
  2403.          ENDIF
  2404.        ELSEIF(inkey.EQ.char(27)) THEN
  2405.  C
  2406.  C       User pressed ESC, so return to main:
  2407.  C
  2408.          RETURN
  2409.        ENDIF
  2410.        GO TO 1
  2411.        END
  2412.  
  2413.        SUBROUTINE SwapBars(Row1,Row2)
  2414.  C
  2415.  C =============================== SwapBars ==================================
  2416.  C   Calls PrintOneBar twice to switch the two bars in Row1 and Row2,
  2417.  C   then calls the ElapsedTime procedure.
  2418.  C ===========================================================================
  2419.  C
  2420.        IMPLICIT INTEGER*2(a-z)
  2421.  C
  2422.        CALL PrintOneBar(Row1)
  2423.        CALL PrintOneBar (Row2)
  2424.        CALL ElapsedTime (Row1)
  2425.  C
  2426.        RETURN
  2427.        END
  2428.  
  2429.        SUBROUTINE SwapSortArray(i,j)
  2430.        IMPLICIT INTEGER*2(a-z)
  2431.        COMMON SortArray(2,43),SortBackup(2,43),BARLENGTH,BARCOLOR,Select
  2432.        temp=SortArray(1,i)
  2433.        SortArray(1,i)=SortArray(1,j)
  2434.        SortArray(1,j)=temp
  2435.        temp=SortArray(2,i)
  2436.        SortArray(2,i)=SortArray(2,j)
  2437.        SortArray(2,j)=temp
  2438.        RETURN
  2439.        END
  2440.  
  2441.        SUBROUTINE cls
  2442.        IMPLICIT INTEGER*2(a-z)
  2443.        gbg = VioScrollDn(0, 0, -1, -1, -1, 16#720, 0)
  2444.        RETURN
  2445.        END
  2446.  
  2447.  \SAMPCODE\FORTRAN\FOREXEC.INC
  2448.  
  2449.  $LIST
  2450.  c       FOREXEC.INC - interface file for C library routines
  2451.  
  2452.  c       This file has been included
  2453.  c       with your FORTRAN 4.0 to show you how easy it is to call routines
  2454.  c       written in Microsoft C (version 3.0 or higher).
  2455.  c
  2456.  c       The Microsoft FORTRAN 4.0, and C 4.0 releases
  2457.  c       have been designed so that libraries or subprograms can be written
  2458.  c       and used in either one of these languages.
  2459.  c
  2460.  c       Try compiling and running the demonstration program DEMOEXEC.FOR
  2461.  c       to see some actual examples.
  2462.  
  2463.  c       C function
  2464.  c
  2465.  c               int system(string)
  2466.  c                       char *string;
  2467.  c
  2468.  c       The system() function passes the given C string (which ends with a
  2469.  c       CHAR(0)) to the DOS command interpreter (COMMAND.COM), which interpre
  2470.  c       and executes the string as an MS-DOS command.  This allows MS-DOS
  2471.  c       commands (i.e., DIR or DEL), batch files, and programs to be executed
  2472.  c
  2473.  c       Example usage in FORTRAN
  2474.  c
  2475.  c       integer*2 system                (the return type must be declared)
  2476.  c       ...
  2477.  c       i = system('dir *.for'c)        (notice the C literal string '...'c)
  2478.  c             OR
  2479.  c       i = system('dir *.for'//char(0))
  2480.  c
  2481.  c       The interface to system is given below.  The [c] attribute is given
  2482.  c       after the function name.  The argument string has the attribute
  2483.  c       [reference] to indicate that the argument is passed by reference.
  2484.  c       Normally, arguments are passed to C procedures by value.
  2485.  
  2486.          INTERFACE TO FUNCTION SYSTEM[C]
  2487.       +          (STRING)
  2488.          INTEGER*2 SYSTEM
  2489.          CHARACTER*1 STRING[REFERENCE]
  2490.          END
  2491.  
  2492.  
  2493.  c       C function
  2494.  c
  2495.  c       int spawnlp(mode,path,arg0,arg1,...,argn)
  2496.  c               int mode;               /* spawn mode */
  2497.  c               char *path;             /* pathname of program to execute */
  2498.  c               char *arg0;             /* should be the same as path */
  2499.  c               char *arg1,...,*argn;   /* command line arguments */
  2500.  c                                       /* argn must be NULL */
  2501.  c
  2502.  c       The spawnlp (to be referenced in FORTRAN as spawn) creates and
  2503.  c       executes a new child process.  There must be enough memory to load
  2504.  c       and execute the child process.  The mode argument determines which
  2505.  c       form of spawn is executed. When calling from FORTRAN, the mode
  2506.  c       argument must be set to zero.
  2507.  c
  2508.  c           Value       Action
  2509.  c
  2510.  c             0         Suspend parent program and execute the child program.
  2511.  c                       When the child program terminates, the parent program
  2512.  c                       resumes execution.  The return value from spawn is -1
  2513.  c                       if an error has occurred or if the child process has
  2514.  c                       run, the return value is the child process'return
  2515.  c                       code.
  2516.  c
  2517.  c       The path argument specifies the file to be executed as the child
  2518.  c       process.  The path can specify a full path name (from the root
  2519.  c       directory \), a partial path name (from the current working directory
  2520.  c       or just a file name.  If the path argument does not have a filename
  2521.  c       extension or end with a period (.), the spawn call first appends
  2522.  c       the extension ".COM" and searches for the file; if unsuccessful, the
  2523.  c       extension ".EXE" is tried.  The spawn routine will also search for
  2524.  c       the file in any of the directories specified in the PATH environment
  2525.  c       variable (using the same procedure as above).
  2526.  c
  2527.  c       Example usage in FORTRAN
  2528.  c
  2529.  c       integer*2 spawn                 (the return type must be declared)
  2530.  c       ...
  2531.  c       i = spawn(0, loc('exemod'c), loc('exemod'c),
  2532.  c    +          loc('demoexec.exe'c), int4(0))          (execute as a child)
  2533.  c
  2534.  c       The interface to _spawnlp is given below.  The [c] attribute is given
  2535.  c       after the function name.  The [varying] attribute indicates that a
  2536.  c       variable number of arguments may be given to the function.  The
  2537.  c       [alias] attribute has to be used because the C name for the function
  2538.  c       _spawnlp has 8 characters.  By default, names in FORTRAN are only
  2539.  c       significant to 6 characters, so we 'alias' the FORTRAN name spawn
  2540.  c       to the actual C name _spawnlp.
  2541.  c       When using the [alias] attribute, remember that the name is passed
  2542.  c       EXACTLY as you type it. This means that if you call a C routine using
  2543.  c       the [alias] attribute, you MUST add an underscore character before
  2544.  c       the name of the function.
  2545.  
  2546.  c       Notice in the example above that the C
  2547.  c       strings are passed differently than those in the system function.  Th
  2548.  c       is because the string arguments to spawn are undeclared in the
  2549.  c       interface below and assumed to be passed by value.  The C spawnlp
  2550.  c       function is expecting the addresses of the strings (not the actual
  2551.  c       characters), so we use the LOC() function to pass the address
  2552.  c       (remember that functions with the [c] attribute pass arguments by
  2553.  c       value).  The last parameter to the spawn routine must be a C NULL
  2554.  c       pointer which is a 32-bit integer 0, so we use the INT4(0) function
  2555.  c       to pass this number by value as the last parameter.
  2556.  
  2557.          interface to function spawn
  2558.       +          [c,varying,alias:'_spawnlp']
  2559.       +          (mode)
  2560.          integer*2 mode,spawn
  2561.          end
  2562.