c***********************************************************************
c                TEST SUITE FOR VECTORIZING COMPILERS                  *
c                        (File 1 of 2)                                 *
c                                                                      *
c  Version:   2.0                                                      *
c  Date:      3/14/88                                                  *
c  Authors:   Original loops from a variety of                         *
c             sources. Collection and synthesis by                     *
c                                                                      *
c             David Callahan  -  Tera Computer                         *
c             Jack Dongarra   -  University of Tennessee               *
c             David Levine    -  Argonne National Laboratory           *
c***********************************************************************
c  Version:   3.0                                                      *
c  Date:      1/4/91                                                   *
c  Authors:   David Levine    -  Executable version                    *
c***********************************************************************
c                         ---DESCRIPTION---                            *
c                                                                      *
c  This test consists of a variety of  loops that represent different  *
c  constructs  intended   to  test  the   analysis  capabilities of a  *
c  vectorizing  compiler.  Each loop is  executed with vector lengths  *
c  of 10, 100, and 1000.   Also included  are several simple  control  *
c  loops  intended  to  provide  a  baseline  measure  for  comparing  *
c  compiler performance on the more complicated loops.                 *
c                                                                      *
c  The  output from a  run  of the test  consists of seven columns of  *
c  data:                                                               *
c     Loop:        The name of the loop.                               *
c     VL:          The vector length the loop was run at.              *
c     Seconds:     The time in seconds to run the loop.                *
c     Checksum:    The checksum calculated when running the test.      *
c     PreComputed: The precomputed checksum (64-bit IEEE arithmetic).  *
c     Residual:    A measure of the accuracy of the calculated         *
c                  checksum versus the precomputed checksum.           *
c     No.:         The number of the loop in the test suite.           *
c                                                                      *
c  The  residual  calculation  is  intended  as  a  check  that   the  *
c  computation  was  done  correctly  and  that 64-bit arithmetic was  *
c  used.   Small   residuals    from    non-IEEE    arithmetic    and  *
c  nonassociativity  of   some calculations  are   acceptable.  Large  *
c  residuals  from   incorrect  computations or  the  use   of 32-bit  *
c  arithmetic are not acceptable.                                      *
c                                                                      *
c  The test  output  itself  does not report   any  results;  it just  *
c  contains data.  Absolute  measures  such as Mflops and  total time  *
c  used  are  not   appropriate    metrics  for  this  test.   Proper  *
c  interpretation of the results involves correlating the output from  *
c  scalar and vector runs  and the  loops which  have been vectorized  *
c  with the speedup achieved at different vector lengths.              *
c                                                                      *
c  These loops  are intended only  as  a partial test of the analysis  *
c  capabilities of a vectorizing compiler (and, by necessity,  a test  *
c  of the speed and  features  of the underlying   vector  hardware).  *
c  These loops  are  by no means  a  complete  test  of a vectorizing  *
c  compiler and should not be interpreted as such.                     *
c                                                                      *
c***********************************************************************
c                           ---DIRECTIONS---                           *
c                                                                      *
c  To  run this  test,  you will  need  to  supply  a  function named  *
c  second() that returns user CPU time.                                *
c                                                                      *
c  This test is distributed as two separate files, one containing the  *
c  driver  and  one containing the loops.   These  two files MUST  be  *
c  compiled separately.                                                *
c                                                                      *
c  Results must  be supplied from  both scalar and vector  runs using  *
c  the following rules for compilation:                                *
c                                                                      *
c     Compilation   of the  driver  file must  not  use any  compiler  *
c     optimizations (e.g., vectorization, function  inlining,  global  *
c     optimizations,...).   This   file   also must  not  be analyzed  *
c     interprocedurally to  gather information useful  in  optimizing  *
c     the test loops.                                                  *
c                                                                      *
c     The file containing the  loops must be compiled twice--once for  *
c     a scalar run and once for a vector run.                          *
c                                                                      *
c        For the scalar  run, global (scalar) optimizations should be  *
c        used.                                                         *
c                                                                      *
c        For  the  vector run,  in  addition   to  the  same   global  *
c        optimizations specified  in the scalar   run,  vectorization  *
c        and--if available--automatic  call generation to   optimized  *
c        library  routines,  function inlining,  and  interprocedural  *
c        analysis should be  used.  Note again that function inlining  *
c        and interprocedural  analysis  must  not be  used to  gather  *
c        information  about any of the  program  units  in the driver  *
c        program.                                                      *
c                                                                      *
c     No changes  may  be made  to   the   source code.   No compiler  *
c     directives may be used, nor may  a file  be split into separate  *
c     program units.  (The exception is  filling  in  the information  *
c     requested in subroutine "info" as described below.)              *
c                                                                      *
c     All files must be compiled to use 64-bit arithmetic.             *
c                                                                      *
c     The  outer  timing  loop  is  included  only   to increase  the  *
c     granularity of the calculation.  It should not be vectorizable.  *
c     If it is found to be so, please notify the authors.              *
c                                                                      *
c  All runs  must be  made  on a standalone  system  to minimize  any  *
c  external effects.                                                   *
c                                                                      *
c  On virtual memory computers,  runs should be  made with a physical  *
c  memory and working-set  size  large enough  that  any  performance  *
c  degradation from page  faults is negligible.   Also,  the  timings  *
c  should be repeatable  and you  must  ensure  that timing anomalies  *
c  resulting from paging effects are not present.                      *
c                                                                      *
c  You should edit subroutine "info"   (the  last subroutine  in  the  *
c  driver program) with  information specific to your  runs, so  that  *
c  the test output will be annotated automatically.                    *
c                                                                      *
c  Please return the following three files in an electronic format:    *
c                                                                      *
c  1. Test output from a scalar run.                                   *
c  2. Test output from a vector run.                                   *
c  3. Compiler output listing (source echo, diagnostics, and messages) *
c     showing which loops have been vectorized.                        *
c                                                                      *
c  The preferred media  for receipt, in order  of preference, are (1)  *
c  electronic mail, (2) 9-track  magnetic or  cartridge tape in  Unix  *
c  tar  format, (3) 5" IBM PC/DOS  floppy   diskette, or  (4) 9-track  *
c  magnetic  tape in  ascii  format,   80 characters per card,  fixed  *
c  records, 40 records per block, 1600bpi.  Please return to           *
c                                                                      *
c  David Levine       		                                       *
c  Mathematics and Computer Science Division                           *
c  Argonne National Laboratory                                         *
c  Argonne, Illinois 60439                                             *
c  levine@mcs.anl.gov                                                  *
c***********************************************************************
      use iso_c_binding
      integer ld, nloops
      parameter (ld=2000,nloops=135)
      real*8 dtime, ctime, c471s, s1, s2, array
      integer ip(ld),indx(ld),n1,n3,n,i,ntimes
      common /cdata/ array(ld*ld)
      real*8 a(ld),b(ld),c(ld),d(ld),e(ld),aa(ld,ld),bb(ld,ld),cc(ld,ld)
      save a,b,c,d,e,aa,bb,cc

      call title
      n      = 100
      ntimes = 10000
      call set(dtime,ctime,c471s,ip,indx,n1,n3,s1,s2,
     +           n,a,b,c,d,e,aa,bb,cc)

      do 1000 i = 1,3
 
      call s114 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s125 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s126 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s141 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s176 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s231 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s232 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s233 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s234 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s235 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s257 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s2102(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s3110(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)

      n      = min(n*10,2000)
      ntimes = max(ntimes/10,n)

1000  continue

      call info(ctime,dtime,c471s)

      stop
      end

      block data
c
c --  initialize precomputed checksums and array of names
c --  resary contains checksums for vectors of length 10,100, and 1000
c --  snames contains the 5 character string names of the loops
c --  time gets set in subroutine check with execution times
c --  ans  gets set in subroutine check with calculated checksums
c --  nit, number of iterations of inner loop, is not currently used
c
      integer i,nloops,ld,j,nvl
      parameter(ld=2000,nloops=135,nvl=3)
      integer nit(nloops,nvl)
      real*8   time(nloops,nvl),ans(nloops,nvl),resary(nloops,nvl)
      character*5 snames(nloops)
      common /acom/time,ans,resary
      common /bcom/nit
      common /ccom/snames
c
c --  precomputed checksums 
c
      data ( (resary(i,j), j=1,nvl),i=1,10 ) /
     &     10.36590277778d0,    100.40628318341d0,   1000.41073401638d0,
     &     22.56870905770d0,    258.31101250085d0,   2636.44909582101d0,
     &     10.54976773117d0,    100.63498390018d0,   1000.64393456668d0,
     &    7272.5116474479d0,    353.12363498321d0,   3628.96362496028d0,
     &      9.12372283291d0,     99.01324486818d0,    999.00149833537d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &     10.92428292812d0,    100.99325548216d0,   1000.99949866671d0,
     &    122.58323255228d0,  13099.31638829156d0,1321154.90032936420d0,
     &     12.82896825397d0,    105.17737751764d0,   1007.48447086055d0,
     & 154986.77311666883d0,  16449.83900184871d0,   2643.93456668156d0/

      data ( (resary(i,j), j=1,nvl),i=11,20 ) /
     &     12.92722222222d0,    103.25026546724d0,   1003.28587213103d0,
     &      6.46361111111d0,     51.62513273362d0,    501.64293606551d0,
     &8000000.00000000000d0,  20000.00000000000d0,2000000.00000000000d0,
     &4015201.30521080922d0,  10460.02285184050d0,1006907.25586229020d0,
     &     12.92722222222d0,    103.25026546724d0,   1003.28587213103d0,
     &     25.00000000000d0,    250.00000000000d0,   2500.00000000000d0,
     &     12.82896825397d0,    105.17737751764d0,   1007.48447086055d0,
     &    100.96448412698d0,  10002.09368875882d0,1000003.24273543020d0,
     &4003282.33444999065d0,  25994.59964010348d0,1001638.09303032420d0,
     &     12.82896825397d0,    105.17737751764d0,   1007.48447086055d0/

      data ( (resary(i,j), j=1,nvl),i=21,30 ) /
     & 119763.19856741340d0,  12120.07400659667d0,   2202.05640365934d0,
     &     21.88004550894d0,    202.03631475108d0,   2002.05416908073d0,
     &     12.82896825397d0,    105.17737751764d0,   1007.48447086055d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     &     11.46361111111d0,    101.62513273362d0,   1001.64293606552d0,
     &     11.46361111111d0,    101.62513273362d0,   1001.64293606551d0,
     &     12.82896825397d0,    105.17737751764d0,   1007.48447086055d0,
     &   2024.99373155108d0,   1756.26368022382d0,   1023.06352283494d0,
     &     15.97371236458d0,    191.54999869568d0,   1986.96285998095d0/

      data ( (resary(i,j), j=1,nvl),i=31,40 ) /
     &  90012.92896823291d0,  10005.18737751802d0,   2006.48547086055d0,
     & 466901.67065395752d0, 611283.72814145486d0,1145729.92128578290d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &7287223.94954790249d0,  18093.17030591522d0,1821145.31605738050d0,
     &4000000.00000000000d0,  10000.00000000000d0,1000000.00000000000d0,
     &43081386.9907936508d0,  63220.03164047703d0,9733449.02625389960d0,
     &7287223.94954790249d0,  18093.17030591522d0,1821145.31605738050d0,
     &9452789.73843175732d0, 554106.50684144662d0,2362767.41506457240d0,
     &     20.00000000000d0,    200.00000000000d0,   2000.00000000000d0,
     &    135.00014500000d0,  14850.01494999997d0,1498501.49950003670d0/

      data ( (resary(i,j), j=1,nvl),i=41,50 ) /
     & 703168.96900448343d0,  74452.86201741260d0,   9467.85242521049d0,
     &     21.89999209985d0,    201.98990200994d0,   2001.99800200180d0,
     &     14.18157204583d0,    104.35229070571d0,   1004.37019236674d0,
     &     19.00000000000d0,    199.00000000000d0,   1999.00000000000d0,
     & 985374.71938453394d0, 999940.55331344355d0,1001996.24603636260d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &      9.99000000000d0,     99.90000000000d0,    999.00000000002d0,
     &    210.00000000000d0,  20100.00000000000d0,2001000.00000000000d0,
     &8002000.00000000000d0,  20100.00000000000d0,2001000.00000000000d0,
     &      8.25300047928d0,     12.77876983660d0,     17.37505452842d0/

      data ( (resary(i,j), j=1,nvl),i=51,60 ) /
     & 208965.09600098155d0,  22800.31298759832d0,   3289.51206792981d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 309973.54623333761d0,  32899.67800369742d0,   5287.86913336312d0,
     &     31.30754181311d0,    301.05213316999d0,   3001.00748921734d0,
     &1154998.32288425600d0,1016551.47398574440d0,1003645.57850125060d0,
     &    100.00000000041d0,  10000.00000048991d0,1000000.00050001150d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &     24.47873598513d0,    206.82236141782d0,   2009.12940542723d0,
     &     25.77728228143d0,    208.47634861140d0,   2010.81938737257d0/

      data ( (resary(i,j), j=1,nvl),i=61,70 ) /
     &     33.09953546233d0,    303.26996780037d0,   3003.28786913336d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     &  54986.77311666882d0,   6449.83900184871d0,   1643.93456668156d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &      9.99000000000d0,     99.90000000000d0,    999.00000000002d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     & 155076.77311666880d0,  26349.83900184871d0,1001643.93456668160d0,
     &   2000.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &      3.00000000000d0,      3.00000000000d0,      3.00000000000d0/

      data ( (resary(i,j), j=1,nvl),i=71,80 ) /
     &      2.92896825397d0,      5.18737751764d0,      7.48547086055d0,
     &      1.00001000004d0,      1.00010000495d0,      1.00100049967d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &      1.00000000000d0,      1.00000000000d0,      1.00000000000d0,
     &      2.00000000000d0,      2.00000000000d0,      2.00000000000d0,
     &      0.10000000000d0,      0.01000000000d0,      0.00100000000d0,
     &      0.99990000450d0,      0.99900049484d0,      0.99004978425d0,
     &     12.00000000000d0,    102.00000000000d0,   1002.00000000000d0,
     &     11.71587301587d0,     20.74951007056d0,     29.94188344220d0,
     &   4002.00000000000d0,    202.00000000000d0,   2002.00000000000d0/

      data ( (resary(i,j), j=1,nvl),i=81,90 ) /
     &      2.92896825397d0,      5.18737751764d0,      7.48547086055d0,
     &     15.66824452003d0,    161.58098030122d0,   1639.73696495437d0,
     &      2.00000000000d0,      2.00000000000d0,      2.00000000000d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &     35.92413942429d0,    439.14900170395d0,   4551.72818698408d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &     12.00000000000d0,    102.00000000000d0,   1002.00000000000d0,
     &      2.92896825397d0,      5.18737751764d0,      7.48547086055d0,
     &      2.92896825397d0,      5.18737751764d0,      7.48547086055d0/

      data ( (resary(i,j), j=1,nvl),i=91,100 ) /
     &     29.28968253968d0,    518.73775176393d0,   7485.47086054862d0,
     &5000010.00000000000d0,5000100.00000000000d0,5001000.00000000000d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &5000010.00000000000d0,5000100.00000000000d0,5001000.00000000000d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 153996.32288440072d0,  16548.47398574890d0,   3643.57750124824d0,
     &    228.31891298186d0,  19130.64580944312d0,1836116.25777848130d0,
     & 153984.77311666956d0,  16446.83900184871d0,   2641.93356668156d0,
     &     12.82896825397d0,    105.17737751764d0,   1007.48447086055d0/

      data ( (resary(i,j), j=1,nvl),i=101,110 ) /
     &      6.69827003023d0,     52.29313637543d0,    502.87104683277d0,
     &     10.53976773117d0,    100.64083339222d0,   1000.68224820984d0,
     &     10.53976773117d0,    103.25165081509d0,   1026.25239026486d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     &     12.00663579797d0,    104.22170317263d0,   1006.51531302881d0,
     &     10.00005500000d0,    100.00505000000d0,   1000.50050000000d0/

      data ( (resary(i,j), j=1,nvl),i=111,120 ) /
     &      5.85793650794d0,     10.37475503528d0,     14.97094172110d0,
     &     24.64930319350d0,    204.90495170055d0,   2004.93180370004d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     &     11.54976773117d0,    101.63498390018d0,   1001.64393456668d0,
     & 292906.82539681665d0,  51973.77517639728d0,   8485.47086055035d0,
     &     11.54976773117d0,    101.63498390018d0,   1001.64393456668d0,
     &     10.64027777778d0,    100.10352524037d0,   1000.01496357775d0,
     &      0.94448853616d0,      1.02889405454d0,      1.03784373764d0,
     &      0.65398478836d0,      0.74716878794d0,      0.75617087823d0/

      data ( (resary(i,j), j=1,nvl),i=121,130 ) /
     &     10.24053571429d0,    100.41622200819d0,   1000.43417317164d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     & 154976.77311666883d0,  16349.83900184871d0,   1643.93456668156d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0,
     & 154986.77311666880d0,  16449.83900184871d0,   2643.93456668156d0/

      data ( (resary(i,j), j=1,nvl),i=131,nloops ) /
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &     10.00000000000d0,    100.00000000000d0,   1000.00000000000d0,
     &      2.92896825397d0,      5.18737751764d0,      7.48547086055d0,
     &      1.54976773117d0,      1.63498390018d0,      1.64393456668d0,
     &    180.04429557950d0,    180.04429557960d0,    180.04429557960d0/
c
c --  subroutine name used in function nindex
c
      data ( snames(i),i=1,nloops) /
     &'s111 ','s112 ','s113 ','s114 ','s115 ','s116 ','s118 ','s119 ',
     &'s121 ','s122 ','s123 ','s124 ','s125 ','s126 ','s127 ','s128 ',
     &'s131 ','s132 ','s141 ','s151 ','s152 ','s161 ','s162 ','s171 ',
     &'s172 ','s173 ','s174 ','s175 ','s176 ','s211 ','s212 ','s221 ',
     &'s222 ','s231 ','s232 ','s233 ','s234 ','s235 ','s241 ','s242 ',
     &'s243 ','s244 ','s251 ','s252 ','s253 ','s254 ','s255 ','s256 ',
     &'s257 ','s258 ','s261 ','s271 ','s272 ','s273 ','s274 ','s275 ',
     &'s276 ','s277 ','s278 ','s279 ','s2710','s2711','s2712','s281 ',
     &'s291 ','s292 ','s293 ','s2101','s2102','s2111','s311 ','s312 ',
     &'s313 ','s314 ','s315 ','s316 ','s317 ','s318 ','s319 ','s3110',
     &'s3111','s3112','s3113','s321 ','s322 ','s323 ','s331 ','s332 ',
     &'s341 ','s342 ','s343 ','s351 ','s352 ','s353 ','s411 ','s412 ',
     &'s413 ','s414 ','s415 ','s421 ','s422 ','s423 ','s424 ','s431 ',
     &'s432 ','s441 ','s442 ','s443 ','s451 ','s452 ','s453 ','s471 ',
     &'s481 ','s482 ','s491 ','s4112','s4113','s4114','s4115','s4116',
     &'s4117','s4121','va   ','vag  ','vas  ','vif  ','vpv  ','vtv  ',
     &'vpvtv','vpvts','vpvpv','vtvtv','vsumr','vdotr','vbor '/

      end


      subroutine set(dtime,ctime,c471s,ip,indx,n1,n3,s1,s2,
     +               n,a,b,c,d,e,aa,bb,cc)
c
c --  initialize miscellaneous data
c
      integer ld
      parameter(ld=2000)
      integer ip(ld),indx(ld),n1,n3,k,n,i
      real*8 dtime, ctime, c471s, s1, s2, tdummy, tcall, t471s
      real*8 a(ld),b(ld),c(ld),d(ld),e(ld),aa(ld,ld),bb(ld,ld),cc(ld,ld)

      dtime     = tdummy(ld,n,a,b,c,d,e,aa,bb,cc)
      ctime     = tcall()
      c471s     = t471s()

      k = 0
      do 5 i = 1,ld,5
         ip(i)   = (i+4)
         ip(i+1) = (i+2)
         ip(i+2) = (i)  
         ip(i+3) = (i+3)
         ip(i+4) = (i+1)
         k = k + 1
5     continue
      do 6 i = 1,ld
         indx(i) = mod(i,4) + 1
6     continue
      n1   = 1
      n3   = 1
      s1   = 1.0
      s2   = 2.0

      return
      end


      subroutine title
      write(*,40)
 40   format(/,' Loop    VL     Seconds',
     +'     Checksum      PreComputed  Residual(1.e-10)   No.')

      return
      end

      subroutine set1d(n,array,value,stride)
c
c  -- initialize one-dimensional arrays
c
      integer i, n, stride, frac, frac2
      real*8 array(n), value
      parameter(frac=-1,frac2=-2)
      if ( stride .eq. frac ) then
!$omp parallel do if(n>129) default(none) shared(array,n)
!dir$ unroll(0)
         do 10 i=1,n
            array(i) = 1.0/dble(i)
10       continue
      elseif ( stride .eq. frac2 ) then
!$omp parallel do if(n>129) default(none) shared(array,n)
!dir$ unroll(0)
         do 15 i=1,n
            array(i) = 1.0/dble(i*i)
15       continue
      else
!$omp parallel do if(n>129) default(none) shared(array,n,stride,value)
         do 20 i=1,n,stride
            array(i) = value
20       continue
      endif
      return
      end

      subroutine set2d(n,array,value,stride)
c
c  -- initialize two-dimensional arrays
c
      integer i, j, n, stride, frac, frac2, ld
      parameter(frac=-1, frac2=-2, ld=2000)
      real*8 array(ld,n),value
      if ( stride .eq. frac ) then
!$omp parallel do if(n>129) default(none) shared(array,n)
         do 10 j=1,n
!dir$ unroll(0)
            do 20 i=1,n
               array(i,j) = 1.0/dble(i)
20          continue
10       continue
      elseif ( stride .eq. frac2 ) then
!$omp parallel do if(n>129) default(none) shared(array,n)
         do 30 j=1,n
!dir$ unroll(0)
            do 40 i=1,n
               array(i,j) = 1.0/dble(i*i)
40          continue
30       continue
      else
!$omp parallel do if(n>129) default(none) shared(array,n,stride,value)
         do 50 j=1,n,stride
!dir$ unroll(0)
            do 60 i=1,n
               array(i,j) = value
60          continue
50       continue
      endif
      return
      end

      subroutine check (chksum,totit,n,t2,name)
c
c --  called by each loop to record and report results
c --  chksum is the computed checksum
c --  totit is the number of times the loop was executed
c --  n  is the length of the loop
c --  t2 is the time to execute loop 'name'
c
      integer nloops, nvl, i, j, totit, n, nindex
      real*8 epslon, chksum, t2, rnorm
      parameter (nloops=135,nvl=3,epslon=1.e-10)
      character*5 name
      external nindex
      integer nit (nloops,nvl)
      real*8    time(nloops,nvl),ans(nloops,nvl),resary(nloops,nvl)
      common /acom/time,ans,resary
      common /bcom/nit
c
c -- get row index based on vector length
c
      if     ( n > 1000) then
         j = 1
      elseif ( n .eq. 100 ) then
         j = 2
      elseif ( n .eq. 1000) then
         j = 3
      else
         print*,'ERROR COMPUTING COLUMN INDEX IN SUB. CHECK, n= ',n
      endif
c
c --  column index is the kernel number from function nindex
c
      i = nindex(name)

      ans (i,j)  = chksum
      nit (i,j)  = totit
      time(i,j)  = t2

      rnorm = sqrt((resary(i,j)-chksum)*(resary(i,j)-chksum))/chksum
      if ( ( rnorm .gt. epslon) .or. ( rnorm .lt. -epslon) ) then
        write(*,98)name,n,t2,chksum,resary(i,j),rnorm,i
      else
        write(*,99)name,n,t2,chksum,resary(i,j),i
      endif

98    format(a6,i5,1x,f12.6,1x,1pe19.9,1x,1pe13.4,1pe13.4,9x,i3)
99    format(a6,i5,1x,f12.6,1x,1pe13.4,1x,1pe13.4,22x,i3)

      return
      end


      real*8 function cs1d(n,a)
c
c --  calculate one-dimensional checksum
c
      integer i,n
      real*8 a(n)
      real*8 sum
      sum = 0.0
!$omp parallel do reduction(+: sum) if(n>1129)
      do 10 i = 1,n
         sum = sum + a(i)
10    continue
      cs1d = sum
      return
      end

      real*8 function cs2d(n,aa)
c
c --  calculate two-dimensional checksum
c
      integer i,j,n,ld
      parameter(ld=2000)
      real*8 aa(ld,n)
      real*8 sum
      sum = 0.0
!$omp parallel do reduction(+: sum) if(n>129)
      do 10 j = 1,n
         do 20 i = 1,n
            sum = sum + aa(i,j)
20       continue
10    continue
      cs2d = sum
      return
      end

      real*8 function tcall()
c
c --  time the overhead of a call to function second()
c
      integer i, ncalls
      real*8 t1,t2,s
      parameter(ncalls = 100000)

      call forttime(t1)
      do 1 i = 1,ncalls
         call forttime(s)
  1   continue
      call forttime(t2)
      tcall = (t2-t1)/ncalls
      return
      end

      real*8 function t471s()
c
c --  time the overhead of a call to subroutine s471s
c
      integer ncalls, i
      real*8 t1,t2
      parameter(ncalls = 100000)
      call forttime(t1)
      do 1 i = 1,ncalls
         call s471s
  1   continue
      call forttime(t2)
      t471s = (t2-t1)/ncalls
      return
      end

      real*8 function tdummy(ld,n,a,b,c,d,e,aa,bb,cc)
c
c --  time the overhead of a call to subroutine dummy
c
      integer ld, n, i, ncalls
      real*8 a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n)
      real*8 t1,t2
      parameter(ncalls = 100000)
      call forttime(t1)
      do 1 i = 1,ncalls
         call dummy(ld,n,a,b,c,d,e,aa,bb,cc,1d0)
  1   continue
      call forttime(t2)
      tdummy = (t2-t1)/ncalls
      return
      end

      subroutine dummy(ld,n,a,b,c,d,e,aa,bb,cc,s)
c
c --  called in each loop to make all computations appear required
c
      integer ld, n
      real*8 a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n)
      real*8 s
      return
      end

      subroutine s471s
c
c --  dummy subroutine call made in s471
c
      return
      end


      integer function nindex(name)
c
c --  returns the (integer) loop index given the (character) name
c
      integer i, nloops
      parameter(nloops=135)
      character*5 name
      character*5 snames(nloops)
      common /ccom/snames

      do 10 i=1,nloops
        if ( name .eq. snames(i) ) then
           nindex = i
           return
        endif
10    continue
      print*,'ERROR COMPUTING ROW INDEX IN FUNCTION NINDEX()'
      nindex = -1
      return
      end

      subroutine init(ld,n,a,b,c,d,e,aa,bb,cc,name)
      real*8 zero, small, half, one, two, any, array
      parameter(any=0.0,zero=0.0,half=.5,one=1.,two=2.,small=.000001d0)
      integer unit, frac, frac2, ld, n
      parameter(unit=1, frac=-1, frac2=-2)
      real*8 a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n)
      common /cdata/ array(2000*2000)
      character*5 name

      if ( name .eq. 's114 ' ) then
         call set2d(n,aa, any,frac)
         call set2d(n,bb, any,frac2)
      elseif ( name .eq. 's125 ' ) then
         call set1d(n*n,array,zero,unit)
         call set2d(n,aa, one,unit)
         call set2d(n,bb,half,unit)
         call set2d(n,cc, two,unit)
      elseif ( name .eq. 's126 ' ) then
         call set2d(n,  bb, one,unit)
         call set1d(n*n,array,any,frac)
         call set2d(n,  cc, any,frac)
      elseif ( name .eq. 's141 ' ) then
         call set1d(n*n,array, one,unit)
         call set2d(n,bb, any,frac2)
      elseif ( name .eq. 's176 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's231 ' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb, any,frac2)
      elseif ( name .eq. 's232 ' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb,zero,unit)
      elseif ( name .eq. 's233 ' ) then
         call set2d(n,aa, any,frac)
         call set2d(n,bb, any,frac)
         call set2d(n,cc, any,frac)
      elseif ( name .eq. 's234 ' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb, any,frac)
         call set2d(n,cc, any,frac)
      elseif ( name .eq. 's235 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         call set2d(n,aa, one,unit)
         call set2d(n,bb, any, frac2)
      elseif ( name .eq. 's257 ' ) then
         call set1d(n, a, one,unit)
         call set2d(n,aa, two,unit)
         call set2d(n,bb, one,unit)
      elseif ( name .eq. 's2102' ) then
         call set2d(n,aa,zero,unit)
      elseif ( name .eq. 's3110' ) then
         call set2d(n,aa, any,frac)
         aa(n,n) = two
      else
        print*,'COULDN''T FIND ',name,' TO INITIALIZE'
      endif

      return
      end


      subroutine info(ctime,dtime,c471s)
#ifdef _OPENMP
      USE omp_lib
#endif
#ifdef __INTEL_COMPILER
      USE IFPORT, ONLY: system
#endif
      real*8 ctime, dtime, c471s
c
c --  Please fill in the information below as best you can.  Additional
c --  information you feel useful may be entered in the comments section.
c --  Thanks to the SLALOM benchmark for the idea for this subroutine.
c
      character(80) txtline
      character*72 who(7), run(3), cmpter(16), coment(6)
      data who   /
     &' Run by:                  Tim Prince',
     &' Address:                           ',
     &' Address:                   ',
     &' Address:                 ',
     &' Phone:                   (513)330-5589',
     &' FAX:                     ',
     &' Electronic mail:         tprince@computer.org'/    
      data run    /
     &' Scalar/Vector run:       Vector',
     &' Timer:                   system_clock',
     &' Standalone:              Yes'/
      data cmpter /
     &' Computer:                Fast_Computer 1',
#ifdef __INTEL_COMPILER
     &' Compiler/version:        INTEL',
#elif defined __GNUC__
     &' Compiler/version:        GNU',
#else
     &' Compiler/version:        unspecified ',
#endif
     &' Compiler options:        -O3 -assume protect_parens',
     &' Availability date:       Now',
     &' OS/version:              Un*x, 1.0',
     &' Cache size:              none',
     &' Main memory size:        16GB',
#ifdef __MIC__
     &' No. vec. registers:      32',
     &' Vec. register length:    8',
#elif defined __AVX__
     &' No. vec. registers:      16',
     &' Vec. register length:    4',
#else
     &' No. vec. registers:      16',
     &' Vec. register length:    2',
#endif
     &' No. functional units:    2 fused multiply add',
     &' Chaining supported:      yes',
     &' Overlapping supported:   pipelined add and multiply units',
     &' Memory paths:            1 load/store',
     &' Memory path width        (L1 cache) 2 words per clock',
     &' Clock speed:             4ns.',
     &' OpenMP num threads:'/
c
c -- Enter any comments you think may be important.
c -- Feel free to increase the number of comment lines 
c
      data coment /
     &' Comments:',
     &' Comments:',
     &' Comments:',
     &' Comments:',
     &' Comments:',
     &' Comments:'/

      open(11,file='/proc/cpuinfo',action='READ',form='formatted',
     &access='stream',iostat=ios)
      if(ios==0)then
	  read(11,'(a)',iostat=ios)txtline
	  do while(ios == 0 .and. index(txtline,'model name') == 0)
	      read(11,'(a)',iostat=ios)txtline
	  enddo
	  cmpter(1)(27:72) = txtline(14:50)
	  close(11)
      open(11,file='/proc/cpuinfo',action='READ',form='formatted',
     &access='stream',iostat=ios)
	  do while(ios == 0 .and. index(txtline,'cpu MHz') == 0)
	      read(11,'(a)',iostat=ios)txtline
	  enddo
	  cmpter(15)(27:72) = txtline(12:41)
	  do while(ios == 0 .and. index(txtline,'cache size') == 0)
	      read(11,'(a)',iostat=ios)txtline
	  enddo
	  close(11)
	  cmpter(6)(27:72) = txtline(14:20)
      else
	write(*,*)'Failed to open /proc/cpuinfo'
      endif
#ifdef _OPENMP
!$omp parallel
!$omp single
	nt=omp_get_num_threads()
      write(cmpter(16)(27:72),'(i0)'),nt
!$omp end single
!$omp end parallel
#endif
#ifdef __INTEL_COMPILER
      junk=system("uname -ps > uname.txt")
#else
      call execute_command_line("uname -ps > uname.txt")
#endif
      open(11,file='uname.txt',action='READ')
      read(11,'(a)',iostat=ios)txtline
      close(11)
      cmpter(5)(27:72) = txtline(1:20)

      write (*, *) ' '
      write (*, '(a72)') who
      write (*, '(a72)') run
      write (*, '(a72)') cmpter
      write (*, 99) 'Cost of timing call:', ctime
      write (*, 99) 'Cost of dummy  call:', dtime
      write (*, 99) 'Cost of c471s  call:', c471s
      write (*, '(a72)') coment
99    format(1x,a,5x,f13.10)
      return
      end


