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***********************************************************************
      integer ld, nloops
      parameter (ld=1000,nloops=135)
      real dtime, ctime, c471s, s1, s2, array
      integer ip(ld),indx(ld),n1,n3,n,i,ntimes
      common /cdata/ array(ld*ld)
      real a(ld),b(ld),c(ld),d(ld),e(ld),aa(ld,ld),bb(ld,ld),cc(ld,ld)

      call title
      n      = 10
      ntimes = 100000
      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 s111 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s112 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s113 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s114 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s115 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s116 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s118 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s119 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s121 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s122 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1,n3)
      call s123 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s124 (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 s127 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s128 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s131 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s132 (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 s151 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s152 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s161 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s162 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1)
      call s171 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1)
      call s172 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1,n3)
      call s173 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s174 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s175 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1)
      call s176 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s211 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s212 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s221 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s222 (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 s241 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s242 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,s1,s2)
      call s243 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s244 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s251 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s252 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s253 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s254 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s255 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s256 (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 s258 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s261 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s271 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s272 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,s1)
      call s273 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s274 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s275 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s276 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s277 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s278 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s279 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s2710(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,s1)
      call s2711(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s2712(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s281 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s291 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s292 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s293 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s2101(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 s2111(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s311 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s312 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s313 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s314 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s315 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s316 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s317 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s318 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1)
      call s319 (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)
      call s3111(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s3112(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s3113(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s321 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s322 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s323 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s331 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s332 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,s1)
      call s341 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s342 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s343 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s351 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s352 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s353 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip)
      call s411 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s412 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,n1)
      call s413 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s414 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s415 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s421 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s422 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s423 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s424 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s431 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s432 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s441 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s442 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,indx)
      call s443 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s451 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s452 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s453 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s471 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,c471s)
      call s481 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s482 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s491 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip)
      call s4112(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip,s1)
      call s4113(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip)
      call s4114(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip,n1)
      call s4115(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip)
      call s4116(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip,n/2,n1)
      call s4117(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call s4121(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call va   (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vag  (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip)
      call vas  (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,ip)
      call vif  (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vpv  (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vtv  (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vpvtv(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vpvts(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc,s1)
      call vpvpv(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vtvtv(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vsumr(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vdotr(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)
      call vbor (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc)

      n      = n*10
      ntimes = ntimes/10

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=1000,nloops=135,nvl=3)
      integer nit(nloops,nvl)
      real   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.36590277778,     100.40628318341,    1000.41073401638,
     &      22.56870905770,     258.31101250085,    2636.44909582101,
     &      10.54976773117,     100.63498390018,    1000.64393456668,
     &      29.63974080373,     353.12363498321,    3628.96362496028,
     &       9.12372283291,      99.01324486818,     999.00149833537,
     &      10.00000000000,     100.00000000000,    1000.00000000000,
     &      10.92428292812,     100.99325548216,    1000.99949866671,
     &     122.58323255228,   13099.31638829156, 1321154.90032936420,
     &      12.82896825397,     105.17737751764,    1007.48447086055,
     &  154986.77311666883,   16449.83900184871,    2643.93456668156/

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

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

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

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

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

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

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

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

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

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

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

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

      data ( (resary(i,j), j=1,nvl),i=131,nloops ) /
     &       1.54976773117,       1.63498390018,       1.64393456668,
     &      10.00000000000,     100.00000000000,    1000.00000000000,
     &       2.92896825397,       5.18737751764,       7.48547086055,
     &       1.54976773117,       1.63498390018,       1.64393456668,
     &     180.04429557950,     180.04429557960,     180.04429557960/
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=1000)
      integer ip(ld),indx(ld),n1,n3,k,n,i
      real dtime, ctime, c471s, s1, s2, tdummy, tcall, t471s
      real 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 array(n), value
      parameter(frac=-1,frac2=-2)
      if ( stride .eq. frac ) then
         do 10 i=1,n
            array(i) = 1.0/float(i)
10       continue
      elseif ( stride .eq. frac2 ) then
         do 15 i=1,n
            array(i) = 1.0/float(i*i)
15       continue
      else
         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=1000)
      real array(ld,n),value
      if ( stride .eq. frac ) then
         do 10 j=1,n
            do 20 i=1,n
               array(i,j) = 1.0/float(i)
20          continue
10       continue
      elseif ( stride .eq. frac2 ) then
         do 30 j=1,n
            do 40 i=1,n
               array(i,j) = 1.0/float(i*i)
40          continue
30       continue
      else
         do 50 j=1,n,stride
            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 epslon, chksum, t2, rnorm
      parameter (nloops=135,nvl=3,epslon=1.e-10)
      character*5 name
      external nindex
      integer nit (nloops,nvl)
      real    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 .eq. 10   ) 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,1pe13.4,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 function cs1d(n,a)
c
c --  calculate one-dimensional checksum
c
      integer i,n
      real a(n), sum
      sum = 0.0
      do 10 i = 1,n
         sum = sum + a(i)
10    continue
      cs1d = sum
      return
      end

      real function cs2d(n,aa)
c
c --  calculate two-dimensional checksum
c
      integer i,j,n,ld
      parameter(ld=1000)
      real aa(ld,n), sum
      sum = 0.0
      do 10 j = 1,n
         do 20 i = 1,n
            sum = sum + aa(i,j)
20       continue
10    continue
      cs2d = sum
      return
      end

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

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

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

      real 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 a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n)
      real t1, t2, second
      parameter(ncalls = 100000)
      t1 = second()
      do 1 i = 1,ncalls
         call dummy(ld,n,a,b,c,d,e,aa,bb,cc,1.)
  1   continue
      t2 = second() - t1
      tdummy = t2/float(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 a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n)
      real 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 zero, small, half, one, two, any, array
      parameter(any=0.0,zero=0.0,half=.5,one=1.,two=2.,small=.000001)
      integer unit, frac, frac2, ld, n
      parameter(unit=1, frac=-1, frac2=-2)
      real a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n)
      common /cdata/ array(1000*1000)
      character*5 name

      if     ( name .eq. 's111 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's112 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's113 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's114 ' ) then
         call set2d(n,aa, any,frac)
         call set2d(n,bb, any,frac2)
      elseif ( name .eq. 's115 ' ) then
         call set1d(n,  a, one,unit)
         call set2d(n, aa,small,unit)
      elseif ( name .eq. 's116 ' ) then
         call set1d(n,  a, one,unit)
      elseif ( name .eq. 's118 ' ) then
         call set1d(n,  a, one,unit)
         call set2d(n, bb,small,unit)
      elseif ( name .eq. 's119 ' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb, any,frac2)
      elseif ( name .eq. 's121 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's122 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's123 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's124 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      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. 's127 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's128 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, two,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, one,unit)
      elseif ( name .eq. 's131 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's132 ' ) then
         call set2d(n, aa, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's141 ' ) then
         call set1d(n*n,array, one,unit)
         call set2d(n,bb, any,frac2)
      elseif ( name .eq. 's151 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's152 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b,zero,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's161 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n/2,b(1), one,2)
         call set1d(n/2,b(2),-one,2)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's162 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's171 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's172 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's173 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's174 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's175 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, 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. 's211 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's212 ' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's221 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's222 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
      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. 's241 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, one,unit)
      elseif ( name .eq. 's242 ' ) then
         call set1d(n,  a,small,unit)
         call set1d(n,  b,small,unit)
         call set1d(n,  c,small,unit)
         call set1d(n,  d,small,unit)
      elseif ( name .eq. 's243 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's244 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c,small,unit)
         call set1d(n,  d,small,unit)
      elseif ( name .eq. 's251 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's252 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
      elseif ( name .eq. 's253 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b,small,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's254 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
      elseif ( name .eq. 's255 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
      elseif ( name .eq. 's256 ' ) then
         call set1d(n, a, one,unit)
         call set2d(n,aa, two,unit)
         call set2d(n,bb, one,unit)
      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. 's258 ' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b,zero,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e,zero,unit)
         call set2d(n, aa, any,frac)
      elseif ( name .eq. 's261 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
         call set1d(n,  c, any,frac2)
         call set1d(n,  d, one,unit)
      elseif ( name .eq. 's271 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's272 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, two,unit)
      elseif ( name .eq. 's273 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d,small,unit)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's274 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's275 ' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb,small,unit)
         call set2d(n,cc,small,unit)
      elseif ( name .eq. 's276 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's277 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n/2,b, one,unit)
         call set1d(n/2,b(n/2+1),-one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's278 ' ) then
         call set1d(n/2,a,-one,unit)
         call set1d(n/2,a(n/2+1),one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's279 ' ) then
         call set1d(n/2,a,-one,unit)
         call set1d(n/2,a(n/2+1),one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's2710' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's2711' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's2712' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's281 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
      elseif ( name .eq. 's291 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
      elseif ( name .eq. 's292 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
      elseif ( name .eq. 's293 ' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 's2101' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb, any,frac)
         call set2d(n,cc, any,frac)
      elseif ( name .eq. 's2102' ) then
         call set2d(n,aa,zero,unit)
      elseif ( name .eq. 's2111' ) then
         call set2d(n,aa,zero,unit)
      elseif ( name .eq. 's311 ' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 's312 ' ) then
         call set1d(n,a,1.000001,unit)
      elseif ( name .eq. 's313 ' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 's314 ' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 's315 ' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 's316 ' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 's317 ' ) then
         continue
      elseif ( name .eq. 's318 ' ) then
         call set1d(n,  a, any,frac)
         a(n) = -two
      elseif ( name .eq. 's319 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b,zero,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's3110' ) then
         call set2d(n,aa, any,frac)
         aa(n,n) = two
      elseif ( name .eq. 's3111' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 's3112' ) then
         call set1d(n,  a, any,frac2)
         call set1d(n,  b,zero,unit)
      elseif ( name .eq. 's3113' ) then
         call set1d(n,  a, any,frac)
         a(n) = -two
      elseif ( name .eq. 's321 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b,zero,unit)
      elseif ( name .eq. 's322 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b,zero,unit)
         call set1d(n,  c,zero,unit)
      elseif ( name .eq. 's323 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's331 ' ) then
         call set1d(n,  a, any,frac)
         a(n) = -one
      elseif ( name .eq. 's332 ' ) then
         call set1d(n,  a, any,frac2)
         a(n) = two
      elseif ( name .eq. 's341 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 's342 ' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 's343 ' ) then
         call set2d(n,aa, any,frac)
         call set2d(n,bb, one,unit)
      elseif ( name .eq. 's351 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         c(1) = 1.
      elseif ( name .eq. 's352 ' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 's353 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         c(1) = 1.
      elseif ( name .eq. 's411 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's412 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's413 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's414 ' ) then
         call set2d(n,aa, one,unit)
         call set2d(n,bb, any,frac)
         call set2d(n,cc, any,frac)
      elseif ( name .eq. 's415 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         a(n) = -one
      elseif ( name .eq. 's421 ' ) then
         call set1d(n,  a, any,frac2)
      elseif ( name .eq. 's422 ' ) then
         call set1d(n,array,one,unit)
         call set1d(n,  a, any,frac2)
      elseif ( name .eq. 's423 ' ) then
         call set1d(n,array,zero,unit)
         call set1d(n,  a, any,frac2)
      elseif ( name .eq. 's424 ' ) then
         call set1d(n,array,one,unit)
         call set1d(n,  a, any,frac2)
      elseif ( name .eq. 's431 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's432 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's441 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         call set1d(n/3,   d(1),        -one,unit)
         call set1d(n/3,   d(1+n/3),    zero,unit)
         call set1d(n/3+1, d(1+(2*n/3)), one,unit)
      elseif ( name .eq. 's442 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's443 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's451 ' ) then
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's452 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c,small,unit)
      elseif ( name .eq. 's453 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 's471 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, one,unit)
         call set1d(n,  d, any,frac)
         call set1d(n,  e, any,frac)
      elseif ( name .eq. 's481 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's482 ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 's491 ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's4112' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 's4113' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac2)
      elseif ( name .eq. 's4114' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's4115' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 's4116' ) then
         call set1d(n, a, any,frac)
         call set2d(n,aa, any,frac)
      elseif ( name .eq. 's4117' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, one,unit)
         call set1d(n,  c, any,frac)
         call set1d(n,  d, any,frac)
      elseif ( name .eq. 's4121' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 'va   ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 'vag  ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 'vas  ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 'vif  ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 'vpv  ' ) then
         call set1d(n,  a,zero,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 'vtv  ' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, one,unit)
      elseif ( name .eq. 'vpvtv' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, any,frac)
      elseif ( name .eq. 'vpvts' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, any,frac2)
      elseif ( name .eq. 'vpvpv' ) then
         call set1d(n,  a, any,frac2)
         call set1d(n,  b, one,unit)
         call set1d(n,  c,-one,unit)
      elseif ( name .eq. 'vtvtv' ) then
         call set1d(n,  a, one,unit)
         call set1d(n,  b, two,unit)
         call set1d(n,  c,half,unit)
      elseif ( name .eq. 'vsumr' ) then
         call set1d(n,  a, any,frac)
      elseif ( name .eq. 'vdotr' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, any,frac)
      elseif ( name .eq. 'vbor ' ) then
         call set1d(n,  a, any,frac)
         call set1d(n,  b, any,frac)
         call set1d(n,  c, one,frac)
         call set1d(n,  d, two,frac)
         call set1d(n,  e,half,frac)
         call set2d(n, aa, any,frac)
      else
        print*,'COULDN''T FIND ',name,' TO INITIALIZE'
      endif

      return
      end

      subroutine info(ctime,dtime,c471s)
      real 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*72 who(7), run(3), cmpter(15), coment(6)
      data who   /
     &' Run by:                  Mr./Ms. Me',
     &' Address:                 My_Company',
     &' Address:                 My_Address',
     &' Address:                 My_City, My_State, My_Zipcode',
     &' Phone:                   (123)-456-7890',
     &' FAX:                     (123)-456-7890',
     &' Electronic mail:         me@company.com'/
      data run    /
     &' Scalar/Vector run:       Scalar',
     &' Timer:                   User CPU, etime()',
     &' Standalone:              Yes'/
      data cmpter /
     &' Computer:                Fast_Computer 1',
     &' Compiler/version:        f77 3.1',
     &' Compiler options:        -O',
     &' Availability date:       Now',
     &' OS/version:              Un*x, 1.0',
     &' Cache size:              none',
     &' Main memory size:        128MB',
     &' No. vec. registers:      8',
     &' Vec. register length:    128',
     &' No. functional units:    2 add, 2 multiply',
     &' Chaining supported:      no',
     &' Overlapping supported:   independent add and mutiply units',
     &' Memory paths:            2 load, 1 store',
     &' Memory path width        4 64-bit words per clock, per pipe',
     &' Clock speed:             4ns.'/
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:'/

      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,a20,5x,f12.10)
      return
      end


      SUBROUTINE poisson_sol_E2(X,Y,Z,T)
      USE global
      REAL*8 :: X(1,NXP4), Y(1,NXP4), Z(1,NXP4)
      REAL*8 :: W(1,NXP4), T(1,NXP4), TD(1,NX),TNI, TNE, EX0
      INTEGER :: R
      EX0 = 0
      DO 44 IC=3, NXP2
         TNI = X(1,IC-1)+X(1,IC)
         TNE = Y(1,IC-1)+Y(1,IC)+ Z(1, IC-1)+ Z(1,IC)
         T(1,IC) = T(1,IC-1) + (TNI-TNE)*dx*0.5
         TD(1,IC-2) = T(1,IC)
   44 CONTINUE
      EX0 = SUM(TD)/NX
      T(1,:) = T(1,:)-EX0
      CALL boundary_condition(T(1,:))
      CALL FILTERn(T(1,:))
      END SUBROUTINE poisson_sol_E2


SUBROUTINE load_function(lf,dtim,al)
!
! This subroutine forms the increment of load at each
! calculation time step.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::lf(:,:),dtim
 REAL(iwp),INTENT(IN OUT)::al(:)
 REAL(iwp)::time,aold,anew
 INTEGER::nlfp,nincs,i,j
 nincs=SIZE(al)
 nlfp=UBOUND(lf,2)
 aold=lf(2,1)
 time=lf(1,1)
 DO i=1,nincs
   time=time+dtim
   DO j=1,nlfp
     IF(time<lf(1,j))THEN
       anew=lf(2,j-1)+                                                    &
         (time-lf(1,j-1))*(lf(2,j)-lf(2,j-1))/(lf(1,j)-lf(1,j-1))
       al(i)=anew-aold
       aold=anew
       EXIT
     END IF
   END DO
 END DO
RETURN
END SUBROUTINE load_function


      subroutine inhyco
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Read hydraulic conductivity data.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.20
!D2
!D2 Initial implementation: 09-FEB-01, Programmer: George Zyvoloski
!D2
!D2 $Log:   /pvcs.config/fehm90/src/inhyco.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:18   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:08:54   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.6 Provide Input/Output Data Files
!D3 3.0 INPUT AND OUTPUT REQUIREMENTS
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai
      use comdi
      use comdti
      use comki
      implicit none

      integer i
      real*8 conv
      real*8, allocatable ::  hycox(:)
      real*8, allocatable ::  hycoy(:)
      real*8, allocatable ::  hycoz(:)
      parameter (conv=9.89d-13/9.66d-6)
      allocate (hycox(n0))
      allocate (hycoy(n0))
      allocate (hycoz(n0))
      do i = 1,n0
         hycox(i) = pnx(i)/conv
	 hycoy(i) = pny(i)/conv
	 hycoz(i) = pnz(i)/conv
      enddo
      macro = 'hyco'
c**** read hydraulic conductivity data (in m/sec)
      narrays = 3
      itype(1) = 8
      itype(2) = 8
      itype(3) = 8
      default(1) = zero_t
      default(2) = zero_t
      default(3) = zero_t
      igroup = 1
c     convert to intrinsic perms at 20 C and 0.1 Mpa

      call initdata2 (inpt, ischk, n0, narrays, itype,
     1     default, macroread(14), macro, igroup, ireturn,
     2     r8_1=hycox(1:n0),r8_2=hycoy(1:n0),r8_3=hycoz(1:n0))

      do i=1,n0
         if(hycox(i).ge.0.0d00) then
            hycox(i) = max (zero_t, hycox(i))
         else
            hycox(i) = 1.0d00/10.0d00**(abs(hycox(i)))
         endif
         pnx(i) = conv*hycox(i)
         if(hycoy(i).ge.0.0d00) then
            hycoy(i) = max (zero_t, hycoy(i))
         else
            hycoy(i) = 1.0d00/10.0d00**(abs(hycoy(i)))
         endif
         pny(i) = conv*hycoy(i)
         if(hycoz(i).ge.0.0d00) then
            hycoz(i) = max (zero_t, hycoz(i))
         else
            hycoz(i) = 1.0d00/10.0d00**(abs(hycoz(i)))
         endif
         pnz(i) = conv*hycoz(i)
      end do

      deallocate (hycox)
      deallocate (hycoy)
      deallocate (hycoz)

      macroread(14) = .TRUE.

      end


C
C	$Id: gzw2ny.f,v 1.6 2008-07-27 00:21:04 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE GZW2NY(N,P,Q)
C
C  This subroutine takes the N points in the real array P,
C  which are assumed to be in world coordinates, and, using
C  the current normalization transformation, converts them
C  into NDC coordinates and stores them in Q.  This subroutine
C  operates on Y-coordinates.
C
      include 'gkscom.h'
C
      INTEGER N
      REAL P(N),Q(N)
      ICNT  = CNT+1
      TMP1 = NTWN(ICNT,3)
      TMP2 = NTWN(ICNT,4)
      TMP3 = NTVP(ICNT,3)
      TMP4 = NTVP(ICNT,4)
      IF ((TMP1.EQ.TMP3) .AND. (TMP2.EQ.TMP4)) THEN
        DO 210 I=1,N
          Q(I) = P(I)
  210   CONTINUE
      ELSE
        SCALE = (TMP4-TMP3)/(TMP2-TMP1)
        DO 200 I=1,N
          Q(I) = TMP3+(P(I)-TMP1)*SCALE
  200   CONTINUE
      ENDIF
C
      RETURN
      END


!! R637 allocate-coshape-spec
!    is [ lower-bound-expr : ] upper-bound-expr
!
allocate(A1[3,*])
allocate(A2[2:3,*])
allocate(A3[2,3:4,*])

end


/* Examples for testing */

 lambda f:Rec X.A->A. lambda x:A. f x;

lambda x:A. x;


program modules_15
use iso_fortran_env, only: sp=>real32, dp=>real64
use modules_15b, only: &
    f_int_float, f_int_double, &
    sub_int_float, sub_int_double, &
    f_int_float_value, f_int_double_value, &
    sub_int_float_value, sub_int_double_value, &
    f_int_intarray, f_int_floatarray, f_int_doublearray, &
    sub_int_intarray, sub_int_floatarray, sub_int_doublearray, &
    f_int_float_complex, f_int_double_complex, &
    sub_int_float_complex, sub_int_double_complex, &
    f_int_float_complex_value, f_int_double_complex_value, &
    sub_int_float_complex_value, sub_int_double_complex_value, &
    f_float_complex_value_return, f_double_complex_value_return, &
    f_int_double_value_name, &
    sub_int_double_value_name, &
    f_string
implicit none
integer :: i, a, n, I32(3)
real(sp) :: r32, X32(3)
real(dp) :: r64, X64(3)
complex(sp) :: c32
complex(dp) :: c64

a = 3
r32 = 5
i = f_int_float(a, r32)
print *, i
if (i /= 8) error stop

a = 3
r32 = 5
call sub_int_float(a, r32, i)
print *, i
if (i /= 8) error stop

a = 3
r64 = 5
i = f_int_double(a, r64)
print *, i
if (i /= 8) error stop

a = 3
r64 = 5
call sub_int_double(a, r64, i)
print *, i
if (i /= 8) error stop

a = 3
c32 = (5._sp, 7._sp)
i = f_int_float_complex(a, c32)
print *, i
if (i /= 15) error stop

a = 3
c32 = (5._sp, 7._sp)
call sub_int_float_complex(a, c32, i)
print *, i
if (i /= 15) error stop

a = 3
c32 = (5._sp, 7._sp)
i = f_int_float_complex_value(a, c32)
print *, i
if (i /= 15) error stop

c32 = (5._sp, 7._sp)
i = f_int_float_complex_value(3, c32)
print *, i
if (i /= 15) error stop

a = 3
c32 = (5._sp, 7._sp)
call sub_int_float_complex_value(a, c32, i)
print *, i
if (i /= 15) error stop

c32 = (5._sp, 7._sp)
c32 = f_float_complex_value_return(c32)
print *, c32
if (abs(real(c32,sp) - 10) > 1e-5_sp) error stop
!if (abs(aimag(c32) - 14) > 1e-5_sp) error stop

c64 = (5._dp, 7._dp)
c64 = f_double_complex_value_return(c64)
print *, c64
if (abs(real(c64,dp) - 10) > 1e-10_dp) error stop
!if (abs(aimag(c64) - 14) > 1e-10_dp) error stop

a = 3
c64 = (5._dp, 7._dp)
i = f_int_double_complex(a, c64)
print *, i
if (i /= 15) error stop

a = 3
c64 = (5._dp, 7._dp)
call sub_int_double_complex(a, c64, i)
print *, i
if (i /= 15) error stop

a = 3
c64 = (5._dp, 7._dp)
i = f_int_double_complex_value(a, c64)
print *, i
if (i /= 15) error stop

a = 3
c64 = (5._dp, 7._dp)
call sub_int_double_complex_value(a, c64, i)
print *, i
if (i /= 15) error stop

a = 3
r32 = 5
i = f_int_float_value(a, r32)
print *, i
if (i /= 8) error stop

a = 3
r32 = 5
call sub_int_float_value(a, r32, i)
print *, i
if (i /= 8) error stop

a = 3
r64 = 5
i = f_int_double_value(a, r64)
print *, i
if (i /= 8) error stop
i = f_int_double_value_name(a, r64)
print *, i
if (i /= 8) error stop

a = 3
r64 = 5
call sub_int_double_value(a, r64, i)
print *, i
if (i /= 8) error stop
call sub_int_double_value_name(a, r64, i)
print *, i
if (i /= 8) error stop

n = 3
I32(1) = 1
I32(2) = 2
I32(3) = 3
i = f_int_intarray(n, I32)
print *, i
if (i /= 6) error stop

n = 3
I32(1) = 1
I32(2) = 2
I32(3) = 3
call sub_int_intarray(n, I32, i)
print *, i
if (i /= 6) error stop

n = 3
X32(1) = 1.1_dp
X32(2) = 2.2_dp
X32(3) = 3.3_dp
r32 = f_int_floatarray(n, X32)
print *, r32
if (abs(r32 - 6.6_sp) > 1e-5_dp) error stop

n = 3
X32(1) = 1.1_dp
X32(2) = 2.2_dp
X32(3) = 3.3_dp
call sub_int_floatarray(n, X32, r32)
print *, r32
if (abs(r32 - 6.6_sp) > 1e-5_dp) error stop

n = 3
X64(1) = 1.1_dp
X64(2) = 2.2_dp
X64(3) = 3.3_dp
r64 = f_int_doublearray(n, X64)
print *, r64
if (abs(r64 - 6.6_dp) > 1e-10_dp) error stop

n = 3
X64(1) = 1.1_dp
X64(2) = 2.2_dp
X64(3) = 3.3_dp
call sub_int_doublearray(n, X64, r64)
print *, r64
if (abs(r64 - 6.6_dp) > 1e-10_dp) error stop

if (f_string("123") /= 3) error stop
if (f_string("abcde") /= 5) error stop
if (f_string(" ") /= 1) error stop
if (f_string("") /= 0) error stop

end


C ************************************************************************
C  FILE: ser_wave.f
C  DESCRIPTION:
C    Serial Concurrent Wave Equation - Fortran C rsion
C    This program implements the concurrent wave equation described
C    in Chapter 5 of Fox et al., 1988, Solving Problems on Concurrent
C    Processors, vol 1.
C  AUTHOR: unknown. Fortran version by R. Arnowitz.
C  LAST REVISED:  04/15/05 Blaise Barney
C ************************************************************************
C  Explanation of constants and variables used in common blocks and
C  include files
C    tpoints           = total points along wave
C    nsteps            = number of time steps
C    values(0:1001)   = values at time t           HARDCODED LIMIT
C    oldval(0:1001)   = values at time (t-dt)      HARDCODED LIMIT
C    newval(0:1001)   = values at time (t+dt)      HARDCODED LIMIT
C ************************************************************************

      program wave

      implicit none

      print *,'Starting serial version of wave equation...'
      call init_param
      print *,'Initializing points on the line...'
      call init_line
      print *,'Updating all points for all time steps...'
      call update
      print *,'Printing final results...'
      call printfinal
      print *,' '
      print *,'Done.'
      print *,' '
      end

C ************************************************************************
C     Obtains input values from user
C ************************************************************************
      subroutine init_param

      implicit none

C     These are hardcoded limits at the present time do NOT exceed
      integer MAXPOINTS, MAXSTEPS, MINPOINTS
      parameter (MAXPOINTS = 1000)
      parameter (MAXSTEPS = 1000)
      parameter (MINPOINTS = 20)

      integer tpoints, nsteps
      common/inputs/tpoints, nsteps

      tpoints = 0
      nsteps = 0

      do while ((tpoints .lt. MINPOINTS) .or. (tpoints .gt. MAXPOINTS))
         write (*,100) MINPOINTS, MAXPOINTS
 100  format(' Enter number of points along vibrating string [',I2,'-',
     &      I5,']:')
         read (*,*) tpoints
         if ((tpoints .lt. MINPOINTS) .or. (tpoints .gt. MAXPOINTS))
     &      print *,'Invalid. Please enter value between ',MINPOINTS,
     &              ' and ',MAXPOINTS
      end do

      do while ((nsteps .lt. 1) .or. (nsteps .gt. MAXSTEPS))
         write (*,101) MAXSTEPS
 101  format(' Enter number of time steps [1-',I4,']:')
         read (*,*) nsteps
         if ((nsteps .lt. 1) .or. (nsteps .gt. MAXSTEPS))
     &      print *,'Invalid. Please enter value between 1 and ',
     &              MAXSTEPS
      end do

      write (*,102)  tpoints, nsteps
 102  format(' Using points = ', I6, ' steps = ', I5)

      end

C ************************************************************************
C     Initialize points on line
C ************************************************************************
      subroutine init_line

      implicit none
      integer tpoints, nsteps
      common/inputs/tpoints, nsteps
      integer npoints, first
      common/decomp/npoints, first
      real*8 values(0:1001), oldval(0:1001), newval(0:1001)
      common/data/values, oldval, newval
      real*8 PI
      parameter (PI = 3.14159265)
      integer i, j
      real*8 x, fac, k, tmp

C     Calculate initial values based on sine curve
      fac = 2.0 * PI
      k = 0.0
      tmp = tpoints - 1
      do j = 1, tpoints
         x = k/tmp
         values(j) = sin (fac * x)
         k = k + 1.0
      end do

C     Initialize old values array
      do i = 1, tpoints
         oldval(i) = values(i)
      end do

      end

C ************************************************************************
C     Calculate new values using wave equation
C ************************************************************************
      subroutine do_math(i)

      implicit none
      integer tpoints, nsteps
      common/inputs/tpoints, nsteps
      real*8 values(0:1001), oldval(0:1001), newval(0:1001)
      common/data/values, oldval, newval
      integer i
      real*8 dtime, c, dx, tau, sqtau

      dtime = 0.3
      c = 1.0
      dx = 1.0
      tau = (c * dtime / dx)
      sqtau = tau * tau
      newval(i) = (2.0 * values(i)) - oldval(i)
     &     + (sqtau * (values(i-1) - (2.0 * values(i)) + values(i+1)))

      end

C ************************************************************************
C     Update all values along line a specified number of times
C ************************************************************************
      subroutine update

      implicit none
      integer tpoints, nsteps
      common/inputs/tpoints, nsteps
      real*8 values(0:1001), oldval(0:1001), newval(0:1001)
      common/data/values, oldval, newval
      integer i, j;

C     Update values for each time step
      do i = 1, nsteps
C        Update points along line for this time step
         do j = 1, tpoints
C           Global endpoints
            if ((j .eq. 1).or.(j .eq. tpoints))then
               newval(j) = 0.0
	    else
               call do_math(j)
            end if
         end do

C        Update old values with new values
         do j = 1, tpoints
            oldval(j) = values(j)
	    values(j) = newval(j)
         end do
      end do

      end

C ************************************************************************
C     Print final results
C ************************************************************************
      subroutine printfinal

      implicit none
      integer tpoints, nsteps
      common/inputs/tpoints, nsteps
      real*8 values(0:1001), oldval(0:1001), newval(0:1001)
      common/data/values, oldval, newval
      integer i, j;

      do i=1, tpoints
         write (*,200) values(i)
         j = MOD(i,10)
         if (j .eq. 0) then
            print *,' '
         endif
      enddo
 200  format(f6.3,' ',$)
      end


! { dg-do run }
! PR47285 G format outputs wrong number of characters.
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
       PROGRAM FOO
       character(len=50) :: buffer

       WRITE(buffer,"(G0.5,'<')") -10000.
       if (buffer.ne."-10000.<") call abort
       WRITE(buffer,"(G1.5E5,'<')") -10000.
       if (buffer.ne."*<") call abort
       WRITE(buffer,"(G2.5E5,'<')") -10000.
       if (buffer.ne."**<") call abort
       WRITE(buffer,"(G3.5E5,'<')") -10000.
       if (buffer.ne."***<") call abort
       WRITE(buffer,"(G4.5E5,'<')") -10000.
       if (buffer.ne."****<") call abort
       WRITE(buffer,"(G5.5E5,'<')") -10000.
       if (buffer.ne."*****<") call abort
       WRITE(buffer,"(G6.5E5,'<')") -10000.
       if (buffer.ne."******<") call abort
       WRITE(buffer,"(G7.5E5,'<')") -10000.
       if (buffer.ne."*******<") call abort
       WRITE(buffer,"(G8.5E5,'<')") -10000.
       if (buffer.ne."********<") call abort
       WRITE(buffer,"(G9.5E5,'<')") -10000.
       if (buffer.ne."*********<") call abort
       WRITE(buffer,"(G10.5E5,'<')") -10000.
       if (buffer.ne."**********<") call abort
       WRITE(buffer,"(G11.5E5,'<')") -10000.
       if (buffer.ne."***********<") call abort
       WRITE(buffer,"(G12.5E5,'<')") -10000.
       if (buffer.ne."************<") call abort
       WRITE(buffer,"(G13.5E5,'<')") -10000.
       if (buffer.ne."*************<") call abort
       WRITE(buffer,"(G14.5E5,'<')") -10000.
       if (buffer.ne."-10000.       <") call abort
       WRITE(buffer,"(G15.5E5,'<')") -10000.
       if (buffer.ne." -10000.       <") call abort
       WRITE(buffer,"(G16.5E5,'<')") -10000.
       if (buffer.ne."  -10000.       <") call abort

       STOP
       END


program test_rkmethod
  use RKMethod, only: dagrt_state_type, &
    timestep_initialize => initialize, &
    timestep_run => run, &
    timestep_shutdown => shutdown

  implicit none

  type(dagrt_state_type), target :: state
  type(dagrt_state_type), pointer :: state_ptr

  real*8, dimension(2) :: initial_condition
  real*8, dimension(100) :: step_sizes

  real*8 t_fin, dt_value, small_step_frac, big_step_frac, old_time
  parameter (t_fin=1d0)

  integer stderr
  parameter(stderr=0)

  integer istep, nruns, num_big_steps, num_small_steps
  parameter (nruns = 100)

  ! start code ----------------------------------------------------------------

  state_ptr => state

  initial_condition(1) = 2
  initial_condition(2) = 0

  dt_value = 1e-5
  old_time = 0d0
  num_big_steps = 0
  num_small_steps = 0

  call timestep_initialize( &
      dagrt_state=state_ptr, &
      state_y=initial_condition, &
      dagrt_t=0d0, &
      dagrt_dt=dt_value)

  do istep = 1, nruns

    call timestep_run(dagrt_state=state_ptr)

    step_sizes(istep) = state%ret_time_y - old_time
    old_time = state%ret_time_y

    if (step_sizes(istep)<0.01d0) then
      num_small_steps = num_small_steps + 1
    elseif (step_sizes(istep)>0.03d0) then
      num_big_steps = num_big_steps + 1
    endif

  enddo

  call timestep_shutdown(dagrt_state=state_ptr)
  write(*,*) 'done'

  big_step_frac = num_big_steps/real(nruns)
  small_step_frac = num_small_steps/real(nruns)

  if (big_step_frac>=0.16d0 .and. small_step_frac<=0.35d0) then
    write(*,*), "Test passes: big_step_frac = ", big_step_frac
    write(*,*), "Test passes: small_step_frac = ", small_step_frac
  else
    write(stderr,*), "Test fails: big_step_frac = ", big_step_frac
    write(stderr,*), "Test fails: small_step_frac = ", small_step_frac
  endif

end program


! { dg-do compile }
! { dg-options "-O3" }
SUBROUTINE calculates_green_opt()
  INTEGER, PARAMETER :: dp=8
  REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: green, green1
  ALLOCATE(green(-nrec:nrec),stat=i_all)
  DO ikern=1,nrec
     green(-ikern)=gleft+gright
     IF (ABS(green(ikern)) <= 1.e-20_dp) THEN
        nrec=ikern
        EXIT
     END IF
  END DO
  ALLOCATE(green1(-nrec:nrec),stat=i_all)
  CALL scf_recursion(nrec,green(-nrec),green1(-nrec))
END SUBROUTINE calculates_green_opt


      module MOD_GAUNTFF
      contains
      SUBROUTINE GAUNTFF (GIII,NCHARGE,XLAM,TEMP)
C***  THE MODULE COMPUTES THE G-III FACTOR FOR THERMAL BREMSSTRAHLUNG
C***  GIII = GAUNT FACTOR
C***  NCHARGE = REST CHARGE OF ION ( =1 FOR H+ AND HE+, =2 FOR HE++ )
C***  XLAM    = WAVELEGTH IN ANGSTROEM
C***  TEMP    = TEMPERATURE IN KELVIN
C***  THE GAUNT FACTORS ARE COMPILED FROM THE PUPLICATIONS OF BERGER (1956)
C***  APJ 124,P550  AND KARZAS AND LATTER (1961) APJ SUPPL 6,P167 (FIG 3,4,5)
C***  TO GET THE HERE TABULATED VALUES BICUBIC SPLINE INTERPOLATION WAS USED
C***  --------  TABULATED RANGE FOR NCHARGE = 1  -----------------------
C***  TEMPERATURE (KELVIN)             :  1577  ...  157 700
C***  WAVELENGTH (ANGSTROEM)           :   120  ...  1.2 E6
      !implicit real*8(a-h,o-z)
      implicit NONE
      !global intent(out)
      real*8,intent(out):: GIII
      !global in
      integer,intent(in):: NCHARGE
      real*8,intent(in) ::XLAM,TEMP
      !local
	REAL*8 AF,AT,GF1,GF2
	integer :: I,J,MF,MT
	integer :: NTUP,NTLOW,NFUP,NFLOW,NHELP ! Common /GIIIERR/ error constants
	REAL*8 :: TEMPLOG,TLOG,TZLOG
	REAL*8 :: ZLOG(6),XF,XLAMLOG,XLOG,XZLOG
      real*8,parameter :: ONE = 1.D+0
      COMMON /GIIIERR/  NTUP,NTLOW,NFUP,NFLOW,NHELP
      REAL*8 A(21,21)

      DATA      ZLOG / 0.d0,
     $                 0.30102999566398119d0,
     $                 0.47712125471966243d0,
     $                 0.60205999132796239d0,
     $                 0.69897000433601880d0,
     $                 0.77815125038364363d0/
      DATA ((A(I,J),I=1,21),J=1,6) /
     $ 1.331, 1.274, 1.232, 1.200, 1.177, 1.158, 1.143, 1.130, 1.120,
     * 1.115, 1.112, 1.108, 1.103, 1.100, 1.100, 1.101, 1.098, 1.090,
     $ 1.080, 1.069, 1.057,
     $ 1.412, 1.347, 1.299, 1.258, 1.214, 1.173, 1.145, 1.132, 1.126,
     * 1.122, 1.118,1.114, 1.110, 1.106, 1.102, 1.099, 1.098, 1.096,
     * 1.090, 1.078, 1.060,
     $ 1.503, 1.418, 1.350, 1.289, 1.230, 1.178, 1.146, 1.133, 1.129,
     * 1.125, 1.121, 1.117, 1.113, 1.109, 1.104, 1.100, 1.100, 1.100,
     $1.098, 1.084, 1.062,
     $ 1.601, 1.489, 1.394, 1.311, 1.239, 1.182, 1.148, 1.135, 1.131,
     $ 1.128, 1.123, 1.119, 1.115, 1.111, 1.106, 1.102, 1.102, 1.105,
     $ 1.102, 1.087, 1.064,
     $ 1.704, 1.566, 1.443, 1.338, 1.254, 1.193, 1.157, 1.142, 1.136,
     $ 1.131, 1.126, 1.121, 1.118, 1.114, 1.109, 1.105, 1.105, 1.104,
     $ 1.103, 1.087, 1.064,
     $ 1.807, 1.652, 1.509, 1.386, 1.288, 1.218, 1.176, 1.156, 1.147,
     * 1.139, 1.131, 1.126, 1.122, 1.119, 1.114, 1.110, 1.109, 1.107,
     $ 1.101, 1.085, 1.063 /
      DATA ((A(I,J),I=1,21),J=7,12) /
     $ 1.911, 1.750, 1.600, 1.466, 1.352, 1.264, 1.207, 1.179, 1.165,
     $ 1.153, 1.142, 1.129, 1.126, 1.126, 1.121, 1.116, 1.111, 1.106,
     $ 1.096, 1.081, 1.060,
     $ 2.016, 1.849, 1.702, 1.562, 1.431, 1.322, 1.248, 1.209, 1.188,
     $ 1.172, 1.158, 1.142, 1.136, 1.135, 1.130, 1.122, 1.114, 1.104,
     $ 1.091, 1.076, 1.059,
     $ 2.121, 1.947, 1.790, 1.644, 1.500, 1.375, 1.288, 1.241, 1.216,
     $ 1.196, 1.179, 1.158, 1.149, 1.145, 1.137, 1.128, 1.116, 1.103,
     $ 1.090, 1.076, 1.061,
     $ 2.226, 2.046, 1.876, 1.713, 1.561, 1.429, 1.335, 1.281, 1.250,
     $ 1.225, 1.204, 1.177, 1.164, 1.157, 1.144, 1.132, 1.119, 1.105,
     $ 1.091, 1.078, 1.064,
     $ 2.331, 2.146, 1.970,1.802, 1.644,  1.507, 1.407, 1.343, 1.301,
     $ 1.265, 1.234, 1.201, 1.182, 1.172, 1.145, 1.138, 1.122, 1.105,
     $ 1.090, 1.076, 1.061,
     $ 2.500, 2.307, 2.123, 1.947, 1.766, 1.623, 1.513, 1.435, 1.374,
     $ 1.318, 1.268, 1.229, 1.204, 1.189, 1.168, 1.147, 1.126, 1.105,
     $ 1.085, 1.067, 1.046 /
      DATA ((A(I,J),I=1,21),J=13,18) /
     $ 2.659, 2.460, 2.268,2.084, 1.907, 1.755, 1.633, 1.539, 1.458,
     $ 1.379, 1.309, 1.262, 1.229, 1.208, 1.185, 1.158, 1.132, 1.106,
     $ 1.081, 1.055, 1.026,
     $ 2.809, 2.604, 2.407, 2.217, 2.035, 1.873, 1.740, 1.634, 1.538,
     $ 1.442, 1.356, 1.300, 1.259, 1.230, 1.202, 1.172, 1.141, 1.112,
     $ 1.082, 1.049, 1.012,
     $ 2.953, 2.743, 2.541, 2.345, 2.156, 1.973, 1.830, 1.714, 1.610,
     $ 1.506, 1.410, 1.344, 1.294, 1.255, 1.221, 1.187, 1.155, 1.124,
     $ 1.090, 1.050, 1.005,
     $ 3.091, 2.878, 2.670, 2.469, 2.276, 2.090, 1.923, 1.797, 1.683,
     $ 1.573, 1.471, 1.394, 1.333, 1.285, 1.242, 1.204, 1.170, 1.136,
     $ 1.099, 1.054, 1.001,
     $ 3.261, 3.042, 2.829, 2.622, 2.421, 2.227, 2.039, 1.895, 1.766,
     $ 1.646, 1.537, 1.451, 1.378, 1.319, 1.268, 1.224, 1.184, 1.146,
     $ 1.104, 1.055, 0.997,
     $ 3.432, 3.208, 2.989, 2.776, 2.569, 2.368, 2.175, 2.008, 1.858,
     $ 1.725, 1.610, 1.514, 1.429, 1.358, 1.299, 1.246, 1.199, 1.155,
     $ 1.108, 1.054, 0.993 /
      DATA ((A(I,J),I=1,21),J=19,21) /
     $ 3.593, 3.365, 3.142, 2.924, 2.711, 2.505, 2.305, 2.127, 1.956,
     $ 1.811, 1.689, 1.583, 1.485, 1.403, 1.335, 1.271, 1.216, 1.166,
     $ 1.114, 1.057, 0.994,
     $ 3.747, 3.515, 3.289, 3.067, 2.850, 2.638, 2.432, 2.233, 2.055,
     $ 1.903, 1.776, 1.660, 1.549, 1.455, 1.374, 1.301, 1.239, 1.183,
     $ 1.127, 1.066, 1.001,
     $ 3.895, 3.661, 3.431, 3.205, 2.984, 2.768, 2.558, 2.354, 2.152,
     $ 2.000, 1.873, 1.743, 1.620, 1.513, 1.415, 1.336, 1.269, 1.209,
     $ 1.151, 1.083, 1.018 /
!	----- END HEADER / BEGIN SUBROUTINE
C***  LOGARITHM OF TEMP AND XLAM
      TEMPLOG=LOG10(TEMP)
      XLAMLOG=LOG10(XLAM)
      GOTO 1
C***  ENTRY FOR CALLING WITH LOGARITHMIC ARGUMENTS
      ENTRY GFFLOG (GIII,NCHARGE,XLOG,TLOG)
      	XLAMLOG=XLOG
      	TEMPLOG=TLOG
    1 CONTINUE

      IF (NCHARGE .LE. 0 .OR. NCHARGE .GT. 6) THEN
         PRINT *, ('NCHARGE OUTSIDE VALID RANGE')
         STOP 'ERROR'
      ENDIF

C***  AT THE FIRST CALL WITHIN A MAIN PROGRAMM, THE COUNTERS ARE SET ZERO.
C***  THESE COUNTERS INDICATE HOW OFTEN THIS ROUTINE HAS BEEN CALLED
C***  WITH PARAMETERS OUTSIDE OF THE TABULATED RANGE.
      IF (NHELP.NE.4HHELP) THEN
		NHELP=4HHELP
		NTUP=0
		NTLOW=0
		NFUP=0
		NFLOW=0
      ENDIF

C***  SCALE TEMP AND XLAM WITH THE REST IONIC CHARGE
      XZLOG=XLAMLOG+2.d0*ZLOG(NCHARGE)
      TZLOG=TEMPLOG-2d0*ZLOG(NCHARGE)

C***  CALCULATE TABULAR INDICES (BROKEN NUMBERS)
      AT=10.d0*TZLOG    -30.98364d0
      AF=31.3944035d0-5.d0*XZLOG

      MT=int(AT)
C***  LOWER TEMPERATURE BOUNDARY
      IF (MT.LT.1) THEN
         MT=1
         NTLOW=NTLOW+1
      ENDIF
C***  UPPER TEMPERATURE BOUNDARY
      IF (MT.GT.20) THEN
         MT=20
         NTUP=NTUP+1
      ENDIF

      MF=int(AF)
C***  LOWER FREQUENCY BOUNDARY
      IF (MF.LT.1) THEN
         MF=1
         NFLOW=NFLOW+1
         ENDIF
C***  UPPER FREQUENCY BOUNDARY
      IF (MF.GT.20) THEN
         GIII=one
C***     THIS APPROXIMATION BECOMES WORSE IN THE X-RAY REGION.
C***     BEYOND NU=10**17 BETTER VALUES SHOULD BE CALCULATED
         IF (MF .GT. 24) NFUP=NFUP+1
         RETURN
      ENDIF

C***  INTERPOLATION
      XF=AF-MF
      GF1=A(MF,MT)+XF*(A(MF+1,MT)-A(MF,MT))
      GF2=A(MF,MT+1)+XF*(A(MF+1,MT+1)-A(MF,MT+1))
      GIII=GF1+(AT-MT)*(GF2-GF1)

      RETURN
      END subroutine
      end module


c
c**************************************
c
      subroutine cldrft(x,nfreq,nch,dr,nwin,cdb,tset)

c    subroutine corrects for linear clock drift
c     clock time is tc; true time is t
c     then assuming tc = t + cdb*t  this routine corrects for
c     the phase shift in the complex fourier coefficients for
c     a window centered at time tset (where tset is in seconds after
c    clock reset) it is assumed that at t=0 (i.e. at clock reset)
c    that the clock time is correct

      complex tc,t
      real x(nch,2,nfreq)
      parameter(pi2 = 6.28318)

      t1 =  - pi2*cdb*tset/(dr*nwin)

      do 10 i = 1,nfreq
      tc = cmplx(0.,i*t1)
      tc = cexp(tc)
         do 5 j = 1,nch
         t = tc*cmplx(x(j,1,i),x(j,2,i))
         x(j,1,i) = real(t)
5        x(j,2,i) = aimag(t)
10    continue

      return
      end