!  *******************************************************************
!  *                                                                 *
!  *                       Subroutine las3g                          *
!  *                                                                 *
!  *******************************************************************
!  Single Precision Version 3.42
!  Written by Gordon A. Fenton, Jan. 1990.
!  Latest Update: Jun 21, 2000
!
!  PURPOSE  produces a 3-D quadrant symmetric homogeneous Gaussian random field
!           using the Local Average Subdivision algorithm.
!
!  This routine creates a zero-mean realization of a 3-D random process given
!  its variance function (as defined by E.H. Vanmarcke in "Random Fields:
!  Analysis and Synthesis", MIT Press, 1984). Each discrete value generated
!  herein represents the local average of a realization of the process over
!  the volume Dx x Dy x Dz, where (Dx,Dy,Dz) is the grid spacing of the
!  desired field.
!  The construction of the realization proceeds recursively as follows;
!
!    1) generate a low resolution field of size k1 x k2 x k3. If (N1 x N2 x N3)
!       is the desired field resolution, then k1, k2, and k3 are determined so
!       that N1 = k1*2**m, N2 = k2*2**m, and N3 = k3*2**m, where 2**m is a
!       common factor and k1*k2*k3 <= MXK. Generally k1, k2, and k3 are
!       maximized where possible since this improves the covariance structure
!       of anisotropic fields. However, the direct generation of the k1 x k2 x
!       k3 field involves the Cholesky decomposition of a (k1*k2*k3) x
!       (k1*k2*k3) matrix, and so MXK should not be too large. This is
!       refered to subsequently as the Stage 0 generation.
!
!    2) subdivide the domain m times by dividing each cell into 8 equal
!       parts (2 x 2 x 2). In each subdivision, new random values are generated
!       for each new cell. The parent cells of the previous stage are used
!       to obtain best linear estimates of the mean of each new cell so that
!       the spatial correlation is approximated. Also upwards averaging is
!       preserved (ie the average of the 8 new values is the same as the
!       parent cell value). Only parent cells in a neighbourhood of 3 x 3 x 3
!       are considered (thus the approximation to the spatial correlation).
!
!  The linear estimation of the mean is accomplished by using the covariance
!  between local averages over each cell, consistent with the goal of
!  producing a local average field. Note that this conditioning process
!  implies that the construction of cells near the edge of the boundary will
!  require the use of values which are, strictly speaking, outside the
!  boundary of the field in question. This is handled by using specially
!  reduced neighbourhoods along the boundaries (equivalent to saying that
!  what goes on beyond the boundary has no effect on the process within the
!  boundary).
!
!  Note that this routine sets up a number of parameters on the
!  first call and thus the time required to produce the first realization
!  is substantially greater than on subsequent calls (see INIT). For
!  more information on local average processes, see
!
!   1) G.A. Fenton, "Simulation and Analysis of Random Fields", Ph.D. thesis,
!      Dept. of Civil Eng. and Op. Research, Princeton University, Princeton,
!      New Jersey, 1990.
!   2) G.A. Fenton and E.H. Vanmarcke "Simulation of Random Fields
!      via Local Average Subdivision", ASCE Journal of Engineering Mechanics,
!      Vol. 116, No. 8, August 1990.
!   3) E. H. Vanmarcke, Random Fields: Analysis and Synthesis, MIT Press,
!      1984
!   4) G.A. Fenton, Error evaluation of three random field generators,
!      ASCE Journal of Engineering Mechanics (to appear), 1993.
!
!  Arguments to this routine are as follows;
!
!   Z     real array of size at least N1*N2*N3*(9/8) which on output will
!         contain the realization of the 3-D process in the first N1 x N2 x N3
!         locations. When dimensioned as Z(N1,N2,9*N3/8) in the calling routine
!         and indexed as Z(i,j,k), Z(1,1,1) is the lower left front cell,
!         Z(2,1,1) is the next cell in the X direction (to the right), etc.,
!         while Z(1,2,1) is the next cell in the Y direction (upwards), etc.
!         The extra space is required for workspace (specifically to store
!         the previous stage in the subdivision). (output)
!
!   N1    number of cells to discretize the field in the x, y, and z directions
!   N2    respectively (corresponding to the first, second, and third indices
!   N3    of Z respectively). Each N1, N2 and N3 must have the form
!         N_i = k_i * 2**m where m is common to all and k1, k2, and k3 are
!         positive integers satisfying k1*k2*k3 <= MXK. Generally k1 and k2
!         are chosen to be as large as possible and still satisfy the above
!         requirements so the the first stage involves directly simulating
!         a k1 x k2 x k3 field by Cholesky decomposition of a covariance
!         matrix. A possible example would be (N1,N2,N3) = (24,80,72) which
!         gives k1 = 3, k2 = 10, k3 = 9 (note k1*k2*k3 = 270 < 1000, OK) and
!         m = 3. Note that in general N1, N2, and N3 cannot be chosen
!         arbitrarily - it is usually best to choose m first then k1, k2, and
!         k3 so as to satisfy or exceed the problem requirements. (input)
!
!   XL    physical dimensions of the field in the x, y, and z directions.
!   YL    (input)
!   ZL
!
!   dvfn  external real*8 function which returns the variance of the random
!         process averaged over a given area. dvfn is referenced as follows
!
!                var = dvfn( V1, V2, V3 )
!
!         where (V1,V2,V3) are the side dimensions of the rectangular averaging
!         domain. Any other parameters to the function must be passed by
!         common block from the calling routine. Note that the variance of
!         the random process averaged over the volume (V1 x V2 x V3) is the
!         product of the point variance and the traditionally defined
!         "variance" function, as discussed by Vanmarcke (pg 186). This
!         function must return the final variance.
!
!   KSEED integer seed to be used for the pseudo-random number generator.
!         If KSEED = 0, then a random seed will be used (based on the
!         clock time when this routine is called for the first time).
!         On output, KSEED is set to the value of the actual seed used.
!
!   INIT  integer flag which must be 1 when parameters of the process
!         are to be calculated or recalculated. If multiple realizations
!         of the same process are desired, then subsequent calls should
!         use INIT equal to 0 and M less than or equal to the value used
!         initially. Note that if INIT = -1 is used, then only the
!         initialization is performed.
!
!   IOUT  unit number to which error and warning messages are to be logged.
!         (input)
!  -------------------------------------------------------------------------
!  PARAMETERS:
!   MXM   represents the maximum value that m can have in the decomposition
!         N = k * 2**m. This is the maximum number of subdivisions. (Note
!         that MXM = 6 allows a field of size 512 x 512 x 512.)
!
!   MXK   represents the maximum number of cells (k1 x k2 x k3) in the initial
!         field, k1*k2*k3 <= MXK. If the value of MXK is changed here, it must
!         also be changed in LAS3I.
!
!   NGS   represents the maximum number of random Gaussian variates that can
!         be produced on each call to VNORM. NGS should be at least
!         7*N1/2, but not less than MXK. Since N1 is not known ahead of
!         time, I've taken the worst case NGS = 1000*2**5 = 32000
!         (corresponding to k1=MXK, k2=k3=1, M = 6)
!
!  Notes:
!    1) Simulation timing is available through common block LASTYM where
!       TI is the time required to initialize the parameters of the
!       process and TS is the cumulative simulation time. These timings
!       are obtained through the function SECOND which returns elapsed
!       user time in seconds since the start of the program.
!    2) In 2 and higher dimensions, the LAS method yeilds a slight pattern
!       in the point variance field. This is due to the neighborhood
!       approximations. This error lessens for larger scales of fluctuation
!       and smaller numbers of subdivisions.
!    3) The parameter `tol' is the maximum relative error allowed on the
!       Cholesky decomposition of covariance matrices before a warning
!       message is emitted. The relative error is estimated by computing
!       the lower-right most element of L*L' and comparing to the original
!       element of A (where L*L' = A is the decomposition). This give some
!       measure of the roundoff errors accumulated in the computation of L.
!
!  Requires:
!    1) from libGAFsim:	ISEED, LAS3I, DCVIT3, DCVMT3, DCHOL2, CORN3D, EDGE3D,
!			SIDE3D, INTR3D, DCVAA3, DCVAB3, DSIFA, DSISL, DAXPY,
!			DSWAP, IDAMAX, DDOT, DOT3D, VNORM, RANDF, SECOND
!    2) user defined external variance function (see DVFN)
!
!  REVISION HISTORY:
!  3.4	accommodated M = 0 case where k1, k2, and/or k3 = 1
!  3.41	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!  3.42	saved k1, k2, k3, kk, NN, and M from initialization (Jun 21/00)
! ==========================================================================
      subroutine las3g( Z, N1, N2, N3, XL, YL, ZL, dvfn, kseed, init,     &
                       iout )
      parameter( MXM = 6, MXK = 512, NGS = 32000 )
      real Z(*)
      real C0(MXK*(MXK + 1)/2), U(NGS)
      real CC(28,8,MXM), CE(28,12,MXM), CS(28,6,MXM), CI(28,MXM)
      real AC(8,7,8,MXM), AE(12,7,12,MXM), AS(18,7,6,MXM), AI(27,7,MXM)
      real ATC(4,7,4), ATS(6,7,4), ATI(9,7)
      real CTC(28,4), CTS(28,4), CTI(28)
      save C0, CC, CS, CE, CI, AC, AE, AS, AI
      save ATC, ATS, ATI, CTC, CTS, CTI
      save M, k1, k2, k3, kk, NN
      external dvfn, dot1, dot2, dot3, dot4, dot5, dot6, dot7
      common/LASTYM/ ti, ts
      data ifirst/1/, zero/0.0/, eight/8.0/
      data tol/1.e-3/
!-----------------------------------------------------------------------------
!-------------------------------------- initialize LAS generator -------------

      if( ifirst .eq. 1 .or. iabs(init) .eq. 1 ) then
!						start timer
         ti = second()
         call las3i( dvfn, N1, N2, N3, XL, YL, ZL, kseed, MXM,            &
                    C0, CC, CE, CS, CI, AC, AE, AS, AI,                   &
                    ATC, ATS, ATI, CTC, CTS, CTI,                         &
                    M, k1, k2, k3, kk, iout, tol )
         NN = N1*N2*N3
         ifirst = 0
!						all done, set timers
         ts   = zero
         ti   = second() - ti
         if( init .eq. -1 ) return
      endif
!-----------------------------------------------------------------------------
!-------------------------------------- generate realization -----------------
      tt = second()
      if( mod(M,2) .eq. 0 ) then
         iq = 0
         jq = NN
      else
         iq = NN
         jq = 0
      endif
!					generate stage 0 field
      call vnorm( U, kk )
      L = 1
      do 20 i = 1, kk
         Z(iq+i) = C0(L)*U(1)
         do 10 j = 2, i
            Z(iq+i) = Z(iq+i) + C0(L+j-1)*U(j)
  10     continue
         L = L + i
  20  continue
!					generate stage 1, 2, ..., M sub-fields
      if( M .eq. 0 ) return
      if( (k1 .eq. 1) .or. (k2 .eq. 1) .or. (k3 .eq. 1) ) then
         ms = 2
         it = jq
         jq = iq
         iq = it
         call plan3d(Z,iq,jq,k1,k2,k3,ATC,ATS,ATI,CTC,CTS,CTI,U,iout)
         jx = 2*k1
         jy = 2*k2
         jz = 2*k3
      else
         jx = k1
         jy = k2
         jz = k3
         ms = 1
      endif

      do 160 i = ms, M
!						swap current and prev fields
         it = jq
         jq = iq
         iq = it
!						new field dimensions
         ix  = 2*jx
         iy  = 2*jy
         iz  = 2*jz
         ixy = ix*iy
         jxy = jx*jy
!						pointers into parent field
         j0 = jq + 1
         j1 = j0 + jx
         j3 = j0 + jxy
         j4 = j3 + jx
!						pointers into new field
         i0 = iq + 1
         i1 = i0 + ix
         i2 = i0 + ixy
         i3 = i2 + ix
         call vnorm( U, 7*jx )
!								corner #1
         Z(i0)   = dot8c(Z,AC(1,1,1,i),CC( 1,1,i),U(1),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,1,i),CC( 2,1,i),U(1),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,1,i),CC( 4,1,i),U(1),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,1,i),CC( 7,1,i),U(1),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,1,i),CC(11,1,i),U(1),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,1,i),CC(16,1,i),U(1),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,1,i),CC(22,1,i),U(1),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j0) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								edge #1
         L = 8
         do 30 js = 1, jx-2
          i0 = i0 + 2
          i1 = i1 + 2
          i2 = i2 + 2
          i3 = i3 + 2
          Z(i0)  =dot12h(Z,AE(1,1,1,i),CE( 1,1,i),U(L),dot1,j0,j1,j3,j4)
          Z(i0+1)=dot12h(Z,AE(1,2,1,i),CE( 2,1,i),U(L),dot2,j0,j1,j3,j4)
          Z(i1)  =dot12h(Z,AE(1,3,1,i),CE( 4,1,i),U(L),dot3,j0,j1,j3,j4)
          Z(i1+1)=dot12h(Z,AE(1,4,1,i),CE( 7,1,i),U(L),dot4,j0,j1,j3,j4)
          Z(i2)  =dot12h(Z,AE(1,5,1,i),CE(11,1,i),U(L),dot5,j0,j1,j3,j4)
          Z(i2+1)=dot12h(Z,AE(1,6,1,i),CE(16,1,i),U(L),dot6,j0,j1,j3,j4)
          Z(i3)  =dot12h(Z,AE(1,7,1,i),CE(22,1,i),U(L),dot7,j0,j1,j3,j4)
          Z(i3+1)=eight*Z(j0+1) - Z(i0) - Z(i0+1) - Z(i1)                 &
                     - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
          j0 = j0 + 1
          j1 = j1 + 1
          j3 = j3 + 1
          j4 = j4 + 1
          L  = L  + 7
  30     continue
!								corner #2
         i0 = i0 + 2
         i1 = i1 + 2
         i2 = i2 + 2
         i3 = i3 + 2
         Z(i0)   = dot8c(Z,AC(1,1,2,i),CC( 1,2,i),U(L),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,2,i),CC( 2,2,i),U(L),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,2,i),CC( 4,2,i),U(L),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,2,i),CC( 7,2,i),U(L),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,2,i),CC(11,2,i),U(L),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,2,i),CC(16,2,i),U(L),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,2,i),CC(22,2,i),U(L),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j0+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                      - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

         j0 = jq + 1
         do 50 ks = 1, jy-2
            j1 = j0 + jx
            j2 = j1 + jx
            j3 = j0 + jxy
            j4 = j3 + jx
            j5 = j4 + jx
            i0 = i1 + 2
            i1 = i0 + ix
            i2 = i0 + ixy
            i3 = i2 + ix
            call vnorm( U, 7*jx )
!								edge #2
            Z(i0)   = dot12v(Z,AE(1,1,2,i),CE( 1,2,i),U(1),dot1,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i0+1) = dot12v(Z,AE(1,2,2,i),CE( 2,2,i),U(1),dot2,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i1)   = dot12v(Z,AE(1,3,2,i),CE( 4,2,i),U(1),dot3,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i1+1) = dot12v(Z,AE(1,4,2,i),CE( 7,2,i),U(1),dot4,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i2)   = dot12v(Z,AE(1,5,2,i),CE(11,2,i),U(1),dot5,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i2+1) = dot12v(Z,AE(1,6,2,i),CE(16,2,i),U(1),dot6,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i3)   = dot12v(Z,AE(1,7,2,i),CE(22,2,i),U(1),dot7,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i3+1) = eight*Z(j1  ) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!							side #1
            L = 8
            do 40 js = 1, jx-2
               i0 = i0 + 2
               i1 = i1 + 2
               i2 = i2 + 2
               i3 = i3 + 2
               Z(i0  ) = dot18a(Z,AS(1,1,1,i),CS( 1,1,i),U(L),dot1,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i0+1) = dot18a(Z,AS(1,2,1,i),CS( 2,1,i),U(L),dot2,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i1  ) = dot18a(Z,AS(1,3,1,i),CS( 4,1,i),U(L),dot3,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i1+1) = dot18a(Z,AS(1,4,1,i),CS( 7,1,i),U(L),dot4,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i2  ) = dot18a(Z,AS(1,5,1,i),CS(11,1,i),U(L),dot5,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i2+1) = dot18a(Z,AS(1,6,1,i),CS(16,1,i),U(L),dot6,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i3  ) = dot18a(Z,AS(1,7,1,i),CS(22,1,i),U(L),dot7,       &
                               j0,j1,j2,j3,j4,j5)
               Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)          &
                            - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

               j0 = j0 + 1
               j1 = j1 + 1
               j2 = j2 + 1
               j3 = j3 + 1
               j4 = j4 + 1
               j5 = j5 + 1
               L  = L  + 7
  40        continue
!								edge #3
            i0 = i0 + 2
            i1 = i1 + 2
            i2 = i2 + 2
            i3 = i3 + 2
            Z(i0)   = dot12v(Z,AE(1,1,3,i),CE( 1,3,i),U(L),dot1,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i0+1) = dot12v(Z,AE(1,2,3,i),CE( 2,3,i),U(L),dot2,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i1)   = dot12v(Z,AE(1,3,3,i),CE( 4,3,i),U(L),dot3,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i1+1) = dot12v(Z,AE(1,4,3,i),CE( 7,3,i),U(L),dot4,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i2)   = dot12v(Z,AE(1,5,3,i),CE(11,3,i),U(L),dot5,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i2+1) = dot12v(Z,AE(1,6,3,i),CE(16,3,i),U(L),dot6,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i3)   = dot12v(Z,AE(1,7,3,i),CE(22,3,i),U(L),dot7,          &
                            j0,j1,j2,j3,j4,j5)
            Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

            j0 = j0 + 2
  50     continue

         j1 = j0 + jx
         j3 = j0 + jxy
         j4 = j3 + jx
         i0 = i1 + 2
         i1 = i0 + ix
         i2 = i0 + ixy
         i3 = i2 + ix
         call vnorm( U, 7*jx )
!								corner #3
         Z(i0)   = dot8c(Z,AC(1,1,3,i),CC( 1,3,i),U(1),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,3,i),CC( 2,3,i),U(1),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,3,i),CC( 4,3,i),U(1),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,3,i),CC( 7,3,i),U(1),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,3,i),CC(11,3,i),U(1),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,3,i),CC(16,3,i),U(1),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,3,i),CC(22,3,i),U(1),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j1) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								edge #4
         L = 8
         do 60 js = 1, jx-2
          i0 = i0 + 2
          i1 = i1 + 2
          i2 = i2 + 2
          i3 = i3 + 2
          Z(i0)  =dot12h(Z,AE(1,1,4,i),CE( 1,4,i),U(L),dot1,j0,j1,j3,j4)
          Z(i0+1)=dot12h(Z,AE(1,2,4,i),CE( 2,4,i),U(L),dot2,j0,j1,j3,j4)
          Z(i1)  =dot12h(Z,AE(1,3,4,i),CE( 4,4,i),U(L),dot3,j0,j1,j3,j4)
          Z(i1+1)=dot12h(Z,AE(1,4,4,i),CE( 7,4,i),U(L),dot4,j0,j1,j3,j4)
          Z(i2)  =dot12h(Z,AE(1,5,4,i),CE(11,4,i),U(L),dot5,j0,j1,j3,j4)
          Z(i2+1)=dot12h(Z,AE(1,6,4,i),CE(16,4,i),U(L),dot6,j0,j1,j3,j4)
          Z(i3)  =dot12h(Z,AE(1,7,4,i),CE(22,4,i),U(L),dot7,j0,j1,j3,j4)
          Z(i3+1)=eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)                 &
                     - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
          j0 = j0 + 1
          j1 = j1 + 1
          j3 = j3 + 1
          j4 = j4 + 1
          L  = L  + 7
  60     continue
!								corner #4
         i0 = i0 + 2
         i1 = i1 + 2
         i2 = i2 + 2
         i3 = i3 + 2
         Z(i0)   = dot8c(Z,AC(1,1,4,i),CC( 1,4,i),U(L),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,4,i),CC( 2,4,i),U(L),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,4,i),CC( 4,4,i),U(L),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,4,i),CC( 7,4,i),U(L),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,4,i),CC(11,4,i),U(L),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,4,i),CC(16,4,i),U(L),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,4,i),CC(22,4,i),U(L),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j1+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                      - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

         j00 = jq + 1
         do 110 ls = 1, jz-2
            j0 = j00
            j1 = j0 + jx
            j3 = j0 + jxy
            j4 = j3 + jx
            j6 = j3 + jxy
            j7 = j6 + jx
            i0 = i3 + 2
            i1 = i0 + ix
            i2 = i0 + ixy
            i3 = i2 + ix
            call vnorm( U, 7*jx )
!								edge #5
            Z(i0)   = dot12v(Z,AE(1,1,5,i),CE( 1,5,i),U(1),dot1,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i0+1) = dot12v(Z,AE(1,2,5,i),CE( 2,5,i),U(1),dot2,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i1)   = dot12v(Z,AE(1,3,5,i),CE( 4,5,i),U(1),dot3,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i1+1) = dot12v(Z,AE(1,4,5,i),CE( 7,5,i),U(1),dot4,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i2)   = dot12v(Z,AE(1,5,5,i),CE(11,5,i),U(1),dot5,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i2+1) = dot12v(Z,AE(1,6,5,i),CE(16,5,i),U(1),dot6,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i3)   = dot12v(Z,AE(1,7,5,i),CE(22,5,i),U(1),dot7,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i3+1) = eight*Z(j3  ) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								side #2
            L = 8
            do 70 js = 1, jx-2
               i0 = i0 + 2
               i1 = i1 + 2
               i2 = i2 + 2
               i3 = i3 + 2
               Z(i0  ) = dot18a(Z,AS(1,1,2,i),CS( 1,2,i),U(L),dot1,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i0+1) = dot18a(Z,AS(1,2,2,i),CS( 2,2,i),U(L),dot2,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i1  ) = dot18a(Z,AS(1,3,2,i),CS( 4,2,i),U(L),dot3,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i1+1) = dot18a(Z,AS(1,4,2,i),CS( 7,2,i),U(L),dot4,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i2  ) = dot18a(Z,AS(1,5,2,i),CS(11,2,i),U(L),dot5,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i2+1) = dot18a(Z,AS(1,6,2,i),CS(16,2,i),U(L),dot6,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i3  ) = dot18a(Z,AS(1,7,2,i),CS(22,2,i),U(L),dot7,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i3+1) = eight*Z(j3+1) - Z(i0) - Z(i0+1) - Z(i1)          &
                            - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

               j0 = j0 + 1
               j1 = j1 + 1
               j3 = j3 + 1
               j4 = j4 + 1
               j6 = j6 + 1
               j7 = j7 + 1
               L  = L  + 7
  70        continue
! 						edge #6
            i0 = i0 + 2
            i1 = i1 + 2
            i2 = i2 + 2
            i3 = i3 + 2
            Z(i0)   = dot12v(Z,AE(1,1,6,i),CE( 1,6,i),U(L),dot1,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i0+1) = dot12v(Z,AE(1,2,6,i),CE( 2,6,i),U(L),dot2,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i1)   = dot12v(Z,AE(1,3,6,i),CE( 4,6,i),U(L),dot3,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i1+1) = dot12v(Z,AE(1,4,6,i),CE( 7,6,i),U(L),dot4,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i2)   = dot12v(Z,AE(1,5,6,i),CE(11,6,i),U(L),dot5,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i2+1) = dot12v(Z,AE(1,6,6,i),CE(16,6,i),U(L),dot6,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i3)   = dot12v(Z,AE(1,7,6,i),CE(22,6,i),U(L),dot7,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i3+1) = eight*Z(j3+1) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

            j0 = j00
            do 90 ks = 1, jy-2
               j1 = j0 + jx
               j2 = j1 + jx
               j3 = j0 + jxy
               j4 = j3 + jx
               j5 = j4 + jx
               j6 = j3 + jxy
               j7 = j6 + jx
               j8 = j7 + jx
               i0 = i1 + 2
               i1 = i0 + ix
               i2 = i0 + ixy
               i3 = i2 + ix
               call vnorm( U, 7*jx )
!								side #3
               Z(i0  ) = dot18s(Z,AS(1,1,3,i),CS( 1,3,i),U(1),dot1,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i0+1) = dot18s(Z,AS(1,2,3,i),CS( 2,3,i),U(1),dot2,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i1  ) = dot18s(Z,AS(1,3,3,i),CS( 4,3,i),U(1),dot3,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i1+1) = dot18s(Z,AS(1,4,3,i),CS( 7,3,i),U(1),dot4,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i2  ) = dot18s(Z,AS(1,5,3,i),CS(11,3,i),U(1),dot5,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i2+1) = dot18s(Z,AS(1,6,3,i),CS(16,3,i),U(1),dot6,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i3  ) = dot18s(Z,AS(1,7,3,i),CS(22,3,i),U(1),dot7,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i3+1) = eight*Z(j4  ) - Z(i0) - Z(i0+1) - Z(i1)          &
                            - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

               L = 8
               do 80 js = 1, jx-2
                  i0 = i0 + 2
                  i1 = i1 + 2
                  i2 = i2 + 2
                  i3 = i3 + 2
!							interior
                  Z(i0  ) = dot27i(Z,AI(1,1,i),CI( 1,i),U(L),dot1,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i0+1) = dot27i(Z,AI(1,2,i),CI( 2,i),U(L),dot2,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i1  ) = dot27i(Z,AI(1,3,i),CI( 4,i),U(L),dot3,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i1+1) = dot27i(Z,AI(1,4,i),CI( 7,i),U(L),dot4,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i2  ) = dot27i(Z,AI(1,5,i),CI(11,i),U(L),dot5,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i2+1) = dot27i(Z,AI(1,6,i),CI(16,i),U(L),dot6,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i3  ) = dot27i(Z,AI(1,7,i),CI(22,i),U(L),dot7,        &
                                  j0,j1,j2,j3,j4,j5,j6,j7,j8)
                  Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)       &
                               - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
                  j0 = j0 + 1
                  j1 = j1 + 1
                  j2 = j2 + 1
                  j3 = j3 + 1
                  j4 = j4 + 1
                  j5 = j5 + 1
                  j6 = j6 + 1
                  j7 = j7 + 1
                  j8 = j8 + 1
                  L  = L + 7
  80           continue
!								side #4
               i0 = i0 + 2
               i1 = i1 + 2
               i2 = i2 + 2
               i3 = i3 + 2
               Z(i0  ) = dot18s(Z,AS(1,1,4,i),CS( 1,4,i),U(L),dot1,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i0+1) = dot18s(Z,AS(1,2,4,i),CS( 2,4,i),U(L),dot2,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i1  ) = dot18s(Z,AS(1,3,4,i),CS( 4,4,i),U(L),dot3,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i1+1) = dot18s(Z,AS(1,4,4,i),CS( 7,4,i),U(L),dot4,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i2  ) = dot18s(Z,AS(1,5,4,i),CS(11,4,i),U(L),dot5,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i2+1) = dot18s(Z,AS(1,6,4,i),CS(16,4,i),U(L),dot6,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i3  ) = dot18s(Z,AS(1,7,4,i),CS(22,4,i),U(L),dot7,       &
                               j0,j1,j2,j3,j4,j5,j6,j7,j8)
               Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)          &
                            - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
               j0 = j0 + 2
  90        continue
            j1 = j0 + jx
            j3 = j0 + jxy
            j4 = j3 + jx
            j6 = j3 + jxy
            j7 = j6 + jx
            i0 = i1 + 2
            i1 = i0 + ix
            i2 = i0 + ixy
            i3 = i2 + ix
            call vnorm( U, 7*jx )
!								edge #7
            Z(i0)   = dot12v(Z,AE(1,1,7,i),CE( 1,7,i),U(1),dot1,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i0+1) = dot12v(Z,AE(1,2,7,i),CE( 2,7,i),U(1),dot2,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i1)   = dot12v(Z,AE(1,3,7,i),CE( 4,7,i),U(1),dot3,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i1+1) = dot12v(Z,AE(1,4,7,i),CE( 7,7,i),U(1),dot4,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i2)   = dot12v(Z,AE(1,5,7,i),CE(11,7,i),U(1),dot5,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i2+1) = dot12v(Z,AE(1,6,7,i),CE(16,7,i),U(1),dot6,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i3)   = dot12v(Z,AE(1,7,7,i),CE(22,7,i),U(1),dot7,         &
                            j0,j1,j3,j4,j6,j7)
            Z(i3+1) = eight*Z(j4  ) - Z(i0) - Z(i0+1) - Z(i1)            &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								side #5
            L = 8
            do 100 js = 1, jx-2
               i0 = i0 + 2
               i1 = i1 + 2
               i2 = i2 + 2
               i3 = i3 + 2
               Z(i0  ) = dot18a(Z,AS(1,1,5,i),CS( 1,5,i),U(L),dot1,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i0+1) = dot18a(Z,AS(1,2,5,i),CS( 2,5,i),U(L),dot2,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i1  ) = dot18a(Z,AS(1,3,5,i),CS( 4,5,i),U(L),dot3,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i1+1) = dot18a(Z,AS(1,4,5,i),CS( 7,5,i),U(L),dot4,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i2  ) = dot18a(Z,AS(1,5,5,i),CS(11,5,i),U(L),dot5,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i2+1) = dot18a(Z,AS(1,6,5,i),CS(16,5,i),U(L),dot6,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i3  ) = dot18a(Z,AS(1,7,5,i),CS(22,5,i),U(L),dot7,       &
                               j0,j1,j3,j4,j6,j7)
               Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)          &
                            - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

               j0 = j0 + 1
               j1 = j1 + 1
               j3 = j3 + 1
               j4 = j4 + 1
               j6 = j6 + 1
               j7 = j7 + 1
               L  = L  + 7
 100        continue
!								edge #8
            i0 = i0 + 2
            i1 = i1 + 2
            i2 = i2 + 2
            i3 = i3 + 2
            Z(i0)   = dot12v(Z,AE(1,1,8,i),CE( 1,8,i),U(L),dot1,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i0+1) = dot12v(Z,AE(1,2,8,i),CE( 2,8,i),U(L),dot2,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i1)   = dot12v(Z,AE(1,3,8,i),CE( 4,8,i),U(L),dot3,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i1+1) = dot12v(Z,AE(1,4,8,i),CE( 7,8,i),U(L),dot4,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i2)   = dot12v(Z,AE(1,5,8,i),CE(11,8,i),U(L),dot5,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i2+1) = dot12v(Z,AE(1,6,8,i),CE(16,8,i),U(L),dot6,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i3)   = dot12v(Z,AE(1,7,8,i),CE(22,8,i),U(L),dot7,          &
                            j0,j1,j3,j4,j6,j7)
            Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

            j00 = j00 + jxy
 110     continue
         j0 = j00
         j1 = j0 + jx
         j3 = j0 + jxy
         j4 = j3 + jx
         i0 = i3 + 2
         i1 = i0 + ix
         i2 = i0 + ixy
         i3 = i2 + ix
         call vnorm( U, 7*jx )
!								corner #5
         Z(i0)   = dot8c(Z,AC(1,1,5,i),CC( 1,5,i),U(1),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,5,i),CC( 2,5,i),U(1),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,5,i),CC( 4,5,i),U(1),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,5,i),CC( 7,5,i),U(1),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,5,i),CC(11,5,i),U(1),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,5,i),CC(16,5,i),U(1),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,5,i),CC(22,5,i),U(1),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j3) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								edge #9
         L = 8
         do 120 js = 1, jx-2
          i0 = i0 + 2
          i1 = i1 + 2
          i2 = i2 + 2
          i3 = i3 + 2
          Z(i0)  =dot12h(Z,AE(1,1,9,i),CE( 1,9,i),U(L),dot1,j0,j1,j3,j4)
          Z(i0+1)=dot12h(Z,AE(1,2,9,i),CE( 2,9,i),U(L),dot2,j0,j1,j3,j4)
          Z(i1)  =dot12h(Z,AE(1,3,9,i),CE( 4,9,i),U(L),dot3,j0,j1,j3,j4)
          Z(i1+1)=dot12h(Z,AE(1,4,9,i),CE( 7,9,i),U(L),dot4,j0,j1,j3,j4)
          Z(i2)  =dot12h(Z,AE(1,5,9,i),CE(11,9,i),U(L),dot5,j0,j1,j3,j4)
          Z(i2+1)=dot12h(Z,AE(1,6,9,i),CE(16,9,i),U(L),dot6,j0,j1,j3,j4)
          Z(i3)  =dot12h(Z,AE(1,7,9,i),CE(22,9,i),U(L),dot7,j0,j1,j3,j4)
          Z(i3+1)=eight*Z(j3+1) - Z(i0) - Z(i0+1) - Z(i1)                 &
                     - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
          j0 = j0 + 1
          j1 = j1 + 1
          j3 = j3 + 1
          j4 = j4 + 1
          L  = L  + 7
 120     continue
! 						corner #6
         i0 = i0 + 2
         i1 = i1 + 2
         i2 = i2 + 2
         i3 = i3 + 2
         Z(i0)   = dot8c(Z,AC(1,1,6,i),CC( 1,6,i),U(L),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,6,i),CC( 2,6,i),U(L),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,6,i),CC( 4,6,i),U(L),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,6,i),CC( 7,6,i),U(L),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,6,i),CC(11,6,i),U(L),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,6,i),CC(16,6,i),U(L),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,6,i),CC(22,6,i),U(L),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j3+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                      - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

         j0 = j00
         do 140 ks = 1, jy-2
            j1 = j0 + jx
            j2 = j1 + jx
            j3 = j0 + jxy
            j4 = j3 + jx
            j5 = j4 + jx
            i0 = i1 + 2
            i1 = i0 + ix
            i2 = i0 + ixy
            i3 = i2 + ix
            call vnorm( U, 7*jx )
!								edge #10
            Z(i0)   = dot12v(Z,AE(1,1,10,i),CE( 1,10,i),U(1),dot1,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i0+1) = dot12v(Z,AE(1,2,10,i),CE( 2,10,i),U(1),dot2,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i1)   = dot12v(Z,AE(1,3,10,i),CE( 4,10,i),U(1),dot3,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i1+1) = dot12v(Z,AE(1,4,10,i),CE( 7,10,i),U(1),dot4,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i2)   = dot12v(Z,AE(1,5,10,i),CE(11,10,i),U(1),dot5,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i2+1) = dot12v(Z,AE(1,6,10,i),CE(16,10,i),U(1),dot6,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i3)   = dot12v(Z,AE(1,7,10,i),CE(22,10,i),U(1),dot7,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i3+1) = eight*Z(j4  ) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!							side #6
            L = 8
            do 130 js = 1, jx-2
               i0 = i0 + 2
               i1 = i1 + 2
               i2 = i2 + 2
               i3 = i3 + 2
               Z(i0  ) = dot18a(Z,AS(1,1,6,i),CS( 1,6,i),U(L),dot1,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i0+1) = dot18a(Z,AS(1,2,6,i),CS( 2,6,i),U(L),dot2,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i1  ) = dot18a(Z,AS(1,3,6,i),CS( 4,6,i),U(L),dot3,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i1+1) = dot18a(Z,AS(1,4,6,i),CS( 7,6,i),U(L),dot4,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i2  ) = dot18a(Z,AS(1,5,6,i),CS(11,6,i),U(L),dot5,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i2+1) = dot18a(Z,AS(1,6,6,i),CS(16,6,i),U(L),dot6,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i3  ) = dot18a(Z,AS(1,7,6,i),CS(22,6,i),U(L),dot7,      &
                               j0,j1,j2,j3,j4,j5)
               Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)         &
                            - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

               j0 = j0 + 1
               j1 = j1 + 1
               j2 = j2 + 1
               j3 = j3 + 1
               j4 = j4 + 1
               j5 = j5 + 1
               L  = L  + 7
 130        continue
!								edge #11
            i0 = i0 + 2
            i1 = i1 + 2
            i2 = i2 + 2
            i3 = i3 + 2
            Z(i0)   = dot12v(Z,AE(1,1,11,i),CE( 1,11,i),U(L),dot1,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i0+1) = dot12v(Z,AE(1,2,11,i),CE( 2,11,i),U(L),dot2,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i1)   = dot12v(Z,AE(1,3,11,i),CE( 4,11,i),U(L),dot3,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i1+1) = dot12v(Z,AE(1,4,11,i),CE( 7,11,i),U(L),dot4,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i2)   = dot12v(Z,AE(1,5,11,i),CE(11,11,i),U(L),dot5,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i2+1) = dot12v(Z,AE(1,6,11,i),CE(16,11,i),U(L),dot6,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i3)   = dot12v(Z,AE(1,7,11,i),CE(22,11,i),U(L),dot7,        &
                            j0,j1,j2,j3,j4,j5)
            Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)             &
                         - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

            j0 = j0 + 2
 140     continue

         j1 = j0 + jx
         j3 = j0 + jxy
         j4 = j3 + jx
         i0 = i1 + 2
         i1 = i0 + ix
         i2 = i0 + ixy
         i3 = i2 + ix
         call vnorm( U, 7*jx )
!								corner #7
         Z(i0)   = dot8c(Z,AC(1,1,7,i),CC( 1,7,i),U(1),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,7,i),CC( 2,7,i),U(1),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,7,i),CC( 4,7,i),U(1),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,7,i),CC( 7,7,i),U(1),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,7,i),CC(11,7,i),U(1),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,7,i),CC(16,7,i),U(1),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,7,i),CC(22,7,i),U(1),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j4) - Z(i0) - Z(i0+1) - Z(i1)                  &
                    - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
!								edge #12
         L = 8
         do 150 js = 1, jx-2
          i0 = i0 + 2
          i1 = i1 + 2
          i2 = i2 + 2
          i3 = i3 + 2
          Z(i0)  =dot12h(Z,AE(1,1,12,i),CE( 1,12,i),U(L),dot1,            &
                        j0,j1,j3,j4)
          Z(i0+1)=dot12h(Z,AE(1,2,12,i),CE( 2,12,i),U(L),dot2,            &
                        j0,j1,j3,j4)
          Z(i1)  =dot12h(Z,AE(1,3,12,i),CE( 4,12,i),U(L),dot3,            &
                        j0,j1,j3,j4)
          Z(i1+1)=dot12h(Z,AE(1,4,12,i),CE( 7,12,i),U(L),dot4,            &
                        j0,j1,j3,j4)
          Z(i2)  =dot12h(Z,AE(1,5,12,i),CE(11,12,i),U(L),dot5,            &
                        j0,j1,j3,j4)
          Z(i2+1)=dot12h(Z,AE(1,6,12,i),CE(16,12,i),U(L),dot6,            &
                        j0,j1,j3,j4)
          Z(i3)  =dot12h(Z,AE(1,7,12,i),CE(22,12,i),U(L),dot7,            &
                        j0,j1,j3,j4)
          Z(i3+1)=eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)                 &
                     - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)
          j0 = j0 + 1
          j1 = j1 + 1
          j3 = j3 + 1
          j4 = j4 + 1
          L  = L  + 7
 150     continue
!								corner #8
         i0 = i0 + 2
         i1 = i1 + 2
         i2 = i2 + 2
         i3 = i3 + 2
         Z(i0)   = dot8c(Z,AC(1,1,8,i),CC( 1,8,i),U(L),dot1,j0,j1,j3,j4)
         Z(i0+1) = dot8c(Z,AC(1,2,8,i),CC( 2,8,i),U(L),dot2,j0,j1,j3,j4)
         Z(i1)   = dot8c(Z,AC(1,3,8,i),CC( 4,8,i),U(L),dot3,j0,j1,j3,j4)
         Z(i1+1) = dot8c(Z,AC(1,4,8,i),CC( 7,8,i),U(L),dot4,j0,j1,j3,j4)
         Z(i2)   = dot8c(Z,AC(1,5,8,i),CC(11,8,i),U(L),dot5,j0,j1,j3,j4)
         Z(i2+1) = dot8c(Z,AC(1,6,8,i),CC(16,8,i),U(L),dot6,j0,j1,j3,j4)
         Z(i3)   = dot8c(Z,AC(1,7,8,i),CC(22,8,i),U(L),dot7,j0,j1,j3,j4)
         Z(i3+1) = eight*Z(j4+1) - Z(i0) - Z(i0+1) - Z(i1)                &
                      - Z(i1+1) - Z(i2) - Z(i2+1) - Z(i3)

         jx = ix
         jy = iy
         jz = iz
 160  continue
!						all done, compute elapsed time
      ts = ts + (second() - tt)

      return
      end


| http://www.tempest-sw.com/benchmark/
| Direct port from the C code

variable pi
variable numdigits
variable alength
variable a
variable pilength
variable nines
variable predigit
variable Q
variable P

: computepi
	| allocate work area:
	numdigits @ 10 3 */ dup alength ! cells allocate dup a !
	| initialize work area to '2'
	alength @ 0 do 2 over ! cell+ loop  drop
	| main loop
	numdigits @ 0 do
		Q off
        | int p = 2 * alength - 1;
		alength @ 2* 1- P !
		| downto loop:
		alength @ 0 do
			| x = 10*a[i] + q*(i+1)
			remains dup 1+ | i i+1
			Q @ * swap | q*(i+1) i
			cells a @ + dup >r @ | q*(i+1) a[i]
			10 * + | x ( r:a+i)
			| a[i] = x%p
			dup P @ mod | x x*p
			r> !  | a[i] = x*p
			| q = x / p
			P @ / Q !
			| p -= 2
			P -- P --
		loop

		| a[0] = q % 10
		| q /= 10
		Q @ 10 /mod Q ! a @ !
		Q @ 9 =if
			nines ++
		else
			Q @ 10 =if
|				pi[piLength] = (char) (predigit + 1 + '0');
				predigit @ 1+ '0 + pi @ pilength @ + c!
|				for (k = 1; k <= nines; ++k)
|					pi[piLength+k] = '0';
				nines @ 1+ 1 do
					'0 pi @ pilength @ + i + c!
				loop
|				predigit = 0;
				predigit off
			else
|				pi[piLength] = (char)(predigit + '0');
				predigit @ '0 + pi @ pilength @ + c!
|				predigit = q;
				Q @ predigit !
|				for (k = 1; k <= nines; ++k)
|					pi[piLength + k] = '9';
				nines @ 1+ 1 do
					'9 pi @ pilength @ i + + c!
				loop
			then
|			piLength += nines + 1;
			nines @ 1+ pilength +!
|			nines = 0;
			nines off
		then
	loop
    | pi[piLength] = (char)(predigit + '0');
	predigit @ '0 +
	pilength @ pi @ + c!
	;
: setup
	argc 3 <>if ." usage: pi #DIGITS" cr bye then
	2 argv >single 0if ." #DIGITS must be a number!" cr bye then
	dup numdigits !
	1+ allocate pi !
	;
: printpi pi @ numdigits @ type cr ;
: cleanup pi @ free a @ free ;
setup computepi printpi cleanup bye


      FUNCTION BESSK(N,X)
      IF (N.LT.2) PAUSE 'bad argument N in BESSK'
      TOX=2.0/X
      BKM=BESSK0(X)
      BK=BESSK1(X)
      DO 11 J=1,N-1
        BKP=BKM+J*TOX*BK
        BKM=BK
        BK=BKP
11    CONTINUE
      BESSK=BK
      RETURN
      END


MODULE Snowdensitymod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_snowdensity(ps_t1, &
        Sdepth_t1, &
        Sdry_t1, &
        Swet_t1, &
        ps)
        IMPLICIT NONE
        REAL, INTENT(IN) :: ps_t1
        REAL, INTENT(IN) :: Sdepth_t1
        REAL, INTENT(IN) :: Sdry_t1
        REAL, INTENT(IN) :: Swet_t1
        REAL, INTENT(OUT) :: ps
        !- Name: SnowDensity -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: Density of snow cover calculation
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: density of snow cover
        !- inputs:
    !            * name: ps_t1
    !                          ** description : density of snow cover in previous day
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 100.0
    !                          ** unit : kg/m**3
    !                          ** uri :
    !            * name: Sdepth_t1
    !                          ** description : snow cover depth Calculation in previous day
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : m
    !                          ** uri :
    !            * name: Sdry_t1
    !                          ** description : water in solid state in the snow cover in previous day
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : mmW
    !                          ** uri :
    !            * name: Swet_t1
    !                          ** description : water in liquid state in the snow cover
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 100.0
    !                          ** unit : mmW
    !                          ** uri :
        !- outputs:
    !            * name: ps
    !                          ** description : density of snow cover
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : kg/m**3
    !                          ** uri :
        ps = 0.0
        IF(ABS(Sdepth_t1) .GT. 0.0) THEN
            IF(ABS(Sdry_t1 + Swet_t1) .GT. 0.0) THEN
                ps = (Sdry_t1 + Swet_t1) / Sdepth_t1
            ELSE
                ps = ps_t1
            END IF
        END IF
    END SUBROUTINE model_snowdensity

END MODULE


!	Estimate the cross information matrix.
!	adjust indicates adjustment for means.
!	grads is the array of observation gradients.
!	grads1 is another array of observation gradients.
!	obsweight contains observation weights.

function crossinformation(adjust,grads,grads1,obsweight)
implicit none
logical,intent(in)::adjust
real(kind=8),intent(in)::grads(:,:),grads1(:,:),obsweight(:)
real(kind=8)::crossinformation(size(grads,1),size(grads1,1))
!	al indicates allocation error.
!	col counts columns.
!	col1 counts columns.
!	counts count strata.
!	locpsu is psu locator.
!	obs is an observation counter.
!	point indicates the location of a psu.
!	row counts rows.
!	row1 counts rows.
integer::al,col,obs,point,row,row1
!	avegrad is used for weighted summations for grads.
!	avegrad1 is used for weighted summations for grads1.
!	diff is for differences for grads.
!	diff1 is for differences for grads1.

!	totalweight is the sum of weights.

real(kind=8)::avegrad(size(grads,1)),avegrad1(size(grads1,1)),&
	diff(size(grads,1)),diff1(size(grads1,1)),totalweight

crossinformation=0.0_8
!	Something must be present.
if(adjust)then
	totalweight=sum(obsweight)
	avegrad=0.0_8
	avegrad1=0.0_8
	do obs=1,size(obsweight)
		if(obsweight(obs)<=0.0_8)cycle
		do row=1,size(grads,1)
			if(grads(row,obs)/=0.0_8)avegrad(row)=avegrad(row)+obsweight(obs)*grads(row,obs)
		end do
		do row=1,size(grads1,1)
			if(grads1(row,obs)/=0.0_8)avegrad1(row)=avegrad1(row)+obsweight(obs)*grads1(row,obs)
		end do
	end do
	avegrad=avegrad/totalweight
	avegrad1=avegrad1/totalweight
end if
do obs=1,size(obsweight)
	if(obsweight(obs)<=0.0_8) cycle
	do row=1,size(grads,1)
		diff(row)=grads(row,obs)
		if(adjust)diff(row)=diff(row)-avegrad(row)
	end do
	do row=1,size(grads1,1)
		diff1(row)=grads1(row,obs)
		if(adjust)diff1(row)=diff1(row)-avegrad1(row)
	end do
	do row=1,size(grads,1)
		if(diff(row)/=0.0_8)then
			do col=1,size(grads1,1)
				if(diff1(col)/=0.0_8)crossinformation(row,col)&
					=crossinformation(row,col)+obsweight(obs)*diff(row)*diff1(col)
			end do
		end if
	end do
end do

return
end function crossinformation


PROGRAM F011

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: I, J, TEMP_PRODUCT, MAX_PRODUCT
    LOGICAL, DIMENSION(3) :: IS_RC_SAFE

    INTEGER, DIMENSION(20, 20), PARAMETER :: GRID = RESHAPE( (/ &
         8,  2, 22, 97, 38, 15,  0, 40,  0, 75,  4,  5,  7, 78, 52, 12, 50, 77, 91,  8, &
        49, 49, 99, 40, 17, 81, 18, 57, 60, 87, 17, 40, 98, 43, 69, 48,  4, 56, 62,  0, &
        81, 49, 31, 73, 55, 79, 14, 29, 93, 71, 40, 67, 53, 88, 30,  3, 49, 13, 36, 65, &
        52, 70, 95, 23,  4, 60, 11, 42, 69, 24, 68, 56,  1, 32, 56, 71, 37,  2, 36, 91, &
        22, 31, 16, 71, 51, 67, 63, 89, 41, 92, 36, 54, 22, 40, 40, 28, 66, 33, 13, 80, &
        24, 47, 32, 60, 99,  3, 45,  2, 44, 75, 33, 53, 78, 36, 84, 20, 35, 17, 12, 50, &
        32, 98, 81, 28, 64, 23, 67, 10, 26, 38, 40, 67, 59, 54, 70, 66, 18, 38, 64, 70, &
        67, 26, 20, 68,  2, 62, 12, 20, 95, 63, 94, 39, 63,  8, 40, 91, 66, 49, 94, 21, &
        24, 55, 58,  5, 66, 73, 99, 26, 97, 17, 78, 78, 96, 83, 14, 88, 34, 89, 63, 72, &
        21, 36, 23,  9, 75,  0, 76, 44, 20, 45, 35, 14,  0, 61, 33, 97, 34, 31, 33, 95, &
        78, 17, 53, 28, 22, 75, 31, 67, 15, 94,  3, 80,  4, 62, 16, 14,  9, 53, 56, 92, &
        16, 39,  5, 42, 96, 35, 31, 47, 55, 58, 88, 24,  0, 17, 54, 24, 36, 29, 85, 57, &
        86, 56,  0, 48, 35, 71, 89,  7,  5, 44, 44, 37, 44, 60, 21, 58, 51, 54, 17, 58, &
        19, 80, 81, 68,  5, 94, 47, 69, 28, 73, 92, 13, 86, 52, 17, 77,  4, 89, 55, 40, &
         4, 52,  8, 83, 97, 35, 99, 16,  7, 97, 57, 32, 16, 26, 26, 79, 33, 27, 98, 66, &
        88, 36, 68, 87, 57, 62, 20, 72,  3, 46, 33, 67, 46, 55, 12, 32, 63, 93, 53, 69, &
         4, 42, 16, 73, 38, 25, 39, 11, 24, 94, 72, 18,  8, 46, 29, 32, 40, 62, 76, 36, &
        20, 69, 36, 41, 72, 30, 23, 88, 34, 62, 99, 69, 82, 67, 59, 85, 74,  4, 36, 16, &
        20, 73, 35, 29, 78, 31, 90,  1, 74, 31, 49, 71, 48, 86, 81, 16, 23, 57,  5, 54, &
         1, 70, 54, 71, 83, 51, 54, 69, 16, 92, 33, 48, 61, 43, 52,  1, 89, 19, 67, 48  &
    /), SHAPE(GRID) )

    MAX_PRODUCT = 1788695

    I = 1
    DO WHILE (I <= 20)

        J = 1
        DO WHILE (J <= 20)

            IS_RC_SAFE = (/ .FALSE., .FALSE., .FALSE. /)

            IF ((I + 3) <= 20) THEN
                IF   ( (GRID(I,   J) /= 0) .AND. (GRID(I+1, J) /= 0)            &
               .AND.   (GRID(I+2, J) /= 0) .AND. (GRID(I+3, J) /= 0)            &
               .AND.  ((GRID(I,   J) > 50) .OR.  (GRID(I+1, J) > 50)            &
               .OR.    (GRID(I+2, J) > 50) .OR.  (GRID(I+3, J) > 50)) ) THEN

                    TEMP_PRODUCT = GRID(I, J)   * GRID(I+1, J)                  &
                                 * GRID(I+2, J) * GRID(I+3, J);

                    IF (TEMP_PRODUCT > MAX_PRODUCT) THEN
                        MAX_PRODUCT = TEMP_PRODUCT;
                    END IF

                    IS_RC_SAFE(1) = .TRUE.;

                END IF
            END IF

            IF ((J + 3) <= 20) THEN
                IF   ( (GRID(I, J)   /= 0) .AND. (GRID(I, J+1) /= 0)            &
               .AND.   (GRID(I, J+2) /= 0) .AND. (GRID(I, J+3) /= 0)            &
               .AND.  ((GRID(I, J)   > 50) .OR.  (GRID(I, J+1) > 50)            &
               .OR.    (GRID(I, J+2) > 50) .OR.  (GRID(I, J+3) > 50)) ) THEN

                    TEMP_PRODUCT = GRID(I, J)   * GRID(I, J+1)                  &
                                 * GRID(I, J+2) * GRID(I, J+3);

                    IF (TEMP_PRODUCT > MAX_PRODUCT) THEN
                        MAX_PRODUCT = TEMP_PRODUCT;
                    END IF

                    IS_RC_SAFE(2) = .TRUE.;

                END IF
            END IF

            IF ((I > 3) .AND. IS_RC_SAFE(2)) THEN
                IS_RC_SAFE(3) = .TRUE.;
            END IF

            IF (IS_RC_SAFE(1) .AND. IS_RC_SAFE(2)) THEN
                IF   ( (GRID(I+1, J+1)   /= 0) .AND. (GRID(I+2, J+2) /= 0)      &
               .AND.   (GRID(I+3, J+3) /= 0)                                    &
               .AND.  ((GRID(I+1, J+1)   > 50) .OR.  (GRID(I+2, J+2) > 50)      &
               .OR.    (GRID(I+3, J+3) > 50)) ) THEN

                    TEMP_PRODUCT = GRID(I, J)     * GRID(I+1, J+1)              &
                                 * GRID(I+2, J+2) * GRID(I+3, J+3);

                    IF (TEMP_PRODUCT > MAX_PRODUCT) THEN
                        MAX_PRODUCT = TEMP_PRODUCT;
                    END IF

                END IF
            END IF

            IF (IS_RC_SAFE(3)) THEN
                IF   ( (GRID(I-1, J+1)   /= 0) .AND. (GRID(I-2, J+2) /= 0)      &
               .AND.   (GRID(I-3, J+3) /= 0)                                    &
               .AND.  ((GRID(I-1, J+1)   > 50) .OR.  (GRID(I-2, J+2) > 50)      &
               .OR.    (GRID(I-3, J+3) > 50)) ) THEN

                    TEMP_PRODUCT = GRID(I, J)     * GRID(I-1, J+1)              &
                                 * GRID(I-2, J+2) * GRID(I-3, J+3);

                    IF (TEMP_PRODUCT > MAX_PRODUCT) THEN
                        MAX_PRODUCT = TEMP_PRODUCT;
                    END IF

                END IF
            END IF

            J = J + 1

        END DO

        I = I + 1

    END DO

    PRINT ('(I0)'), MAX_PRODUCT

END PROGRAM F011


!
! Bubble Sort
! CSC 308
! FVCproductions
!

PROGRAM Bubble_Sort

parameter(MAX = 1024)

! array of integers

integer A(1:MAX)
  n = 10
  A = 0
  A(1) = 34;
  A(2) = 56;
  A(3) = 4;
  A(4) = 10;
  A(5) = 77
  A(6) = 51;
  A(7) = 93;
  A(8) = 30;
  A(9) = 5;
  A(10) = 52;

! print unsorted array

  print *,'Unsorted Array'
  write(*, 10) (A(i), i = 1, n)
  print *,' '

! calling bubble sort function defined below

  call BubbleSort(A, n)

! print sorted array

  print *,'Sorted Array'
  write(*, 10) (A(i), i = 1, n)
  stop

10 format(10I5)

END

! END of Bubble Sort program

! return p, q in ascending order

Subroutine Order(p,q)
integer p, q, temp
  if (p > q) then
    temp = p
    p = q
    q = temp
  end if
  return
end

! bubble sort

Subroutine BubbleSort(A, n)
integer A(1:n)
  do i = 1, n
    do j = n, i + 1, -1
      call Order(A(j - 1), A(j))
    end do
  end do
  return
end

! end of Bubble_Sort.f95 program

! Expected Output
! Unsorted Array
! 34   56    4   10   77   51   93   30    5   52
! Sorted Array
! 4    5   10   30   34   51


module tower

  implicit none

  ! user inputs
  real :: tower_D, tower_x, tower_ybot, tower_ytop
  integer :: Itower, tower_Npts

  real :: tower_CD, theta0
  real, parameter :: Delta_wake = 0.289, W0_wake = 1.75
  real, parameter :: S_wake = 0.083, alpha_wake = 0.693

  real, allocatable, dimension(:) :: tower_y, tower_Vx

contains

  subroutine setup_tower

    implicit none

    integer :: i

    Allocate(tower_y(tower_Npts), tower_Vx(tower_Npts))

    If (tower_Npts .LE. 1) Then
       Write(*,'(''Inadequate number of tower points.'')')
    End If

    Do i = 1,tower_Npts
       tower_y(i) = tower_ybot + (REAL(i)-1) / &
            (REAL(tower_Npts) - 1) * (tower_ytop-tower_ybot)
       tower_Vx(i) = 0.0
    End Do

    theta0 = 0.5 * tower_CD * tower_D

  end subroutine setup_tower

  FUNCTION interp_tower_Vx(y)

    implicit none

    real :: interp_tower_Vx, y
    integer :: i

    interp_tower_Vx = 0.0
    Do i = 1,tower_Npts-1
       If ((y .GE. tower_y(i)) .AND. (y .LE. tower_y(i+1))) Then
          interp_tower_Vx = tower_Vx(i) + (y - tower_y(i)) &
               / (tower_y(i+1) - tower_y(i)) * (tower_Vx(i+1) - &
               tower_Vx(i))
          Exit
       End If
    End Do

    return

  END FUNCTION interp_tower_Vx

  FUNCTION wake_defect_velocity(x,y,z)

    implicit none

    real :: x, y, z, wake_defect_velocity
    real :: W, xi, Vx_tow, u0, f_wake

    If (x .LE. tower_x) Then
       wake_defect_velocity = 0.0
       return
    End If

    If ((y .LT. tower_ybot) .OR. (y .GT. tower_ytop)) Then
       wake_defect_velocity = 0.0
       return
    End If

    ! Calculate the wake half-width at this x location
    W = Delta_wake * sqrt((x-tower_x)*theta0)
    xi = z / W ! non-dimensional transverse coordinate
    Vx_tow = interp_tower_Vx(y)  ! x-dir fluid velocity at tower
    !Write(20,'(F20.12)') Vx_tow
    u0 = W0_wake * sqrt(theta0/(x-tower_x )) * Vx_tow ! max velocity
    !  defect at this x location
    f_wake = exp(-alpha_wake * xi * xi) ! non-dimensional velocity defect
    wake_defect_velocity = u0 * f_wake ! dimensional velocity defect

    if (wake_defect_velocity .GT. 0.9 * Vx_tow) then
       wake_defect_velocity = 0.9 * Vx_tow
    end if

    return

  END FUNCTION wake_defect_velocity

end module tower


module CFIE_mod
    use meshread_mod
    use tools
    implicit none

    real(8), parameter, private :: pi = 4d0 * atan(1d0)
    complex(8), parameter, private :: IU = (0d0, 1d0)

    private :: Dipole

contains
    ! Computes the Dipole and the CurlDipole fields on the evaluation mesh
    subroutine DipoleFieldsOnEvlMsh(pol, src, k, xEvl, Eeval, Heval)
        real(8), intent(in) :: xEvl(:, :)
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8), allocatable, intent(out) :: Eeval(:, :), Heval(:, :)
        integer :: j, nEvl

        nEvl = size(xEvl, 1)
        allocate(Eeval(nEvl, 3))
        allocate(Heval(nEvl, 3))

        do j = 1, nEvl
            Eeval(j,:) = Dipole(pol, src, k, xEvl(j, :))
            Heval(j,:) = CurlDipole(pol, src, k, xEvl(j, :))
        end do
    end subroutine DipoleFieldsOnEvlMsh

    ! Computes the Dipole and the CurlDipole fields on the nodes of the mesh
    subroutine DipoleFieldsOnMesh(pol, src, k, msh, Einc, Hinc)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8), allocatable, intent(out) :: Einc(:, :), Hinc(:, :)
        integer :: j

        allocate(Einc(1:msh%nbNod, 3))
        allocate(Hinc(1:msh%nbNod, 3))

        do j = 1, msh%nbNod
            Einc(j,:) = Dipole(pol, src, k, msh%POS(j,:))
            Hinc(j,:) = CurlDipole(pol, src, k, msh%POS(j,:))
        end do
    end subroutine DipoleFieldsOnMesh

    ! Computes the CurlDipole field on the nodes of the mesh
    function CurlDipoleOnMesh(pol, src, k, msh) result(F)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k, pol(3), src(3)
        complex(8) :: F(msh%nbNod, 3)
        integer :: j

        do j=1,msh%nbNod
            F(j,:) = CurlDipole(pol, src, k, msh%POS(j,:))
        end do
    end function CurlDipoleOnMesh

    ! Computes the curl of a dipole: curl(cross(p, grad(G)))
    function CurlDipole(pol, src, k, pt) result(res)
        real(8), intent(in) :: k, pol(3), src(3), pt(3)
        complex(8) :: res(3)
        real(8) :: R, Rvec(3), Rhat(3)
        real(8) :: kR, kR2

        Rvec = pt - src
        R = sqrt(sum(Rvec * Rvec))
        Rhat = Rvec / R
        kR = k * R
        kR2 = kR ** 2

        res = -(1 + IU/kR - 1/kR2)*pol  &
              + (1 + 3*IU/kR - 3/kR2)*sum(pol*Rhat)*Rhat
        res = res * k**2 * exp(IU*k*R)/(4*pi*R)
    end function CurlDipole

    ! Computes a dipole: cross(p, grad(G))
    function Dipole(pol, src, k, pt) result(F)
        complex(8), parameter :: iu = (0.0d0, 1.0d0)
        real(8), intent(in) :: k, pol(3), src(3), pt(3)
        complex(8) :: F(3)
        complex(8) :: G, dG
        real(8) :: R,Rvec(3)

        Rvec = pt-src
        R = sqrt(sum(Rvec*Rvec))
        G = exp(iu*k*R)/(4d0*PI*R)
        dG = (iu*k-1.0d0/R)*G
        F = dG/R*cross(pol,Rvec)
    end function Dipole

    subroutine save_array(array, filename)
        real(8), intent(in) :: array(:)
        character(len=*), intent(in) :: filename

        integer :: n
        integer :: n_points
        integer, parameter :: file_id = 1

        n_points = size(array, 1)
        open(unit=file_id, file=filename, status="REPLACE", action="WRITE")

        ! print to file
        do n = 1, n_points
            write(file_id, *) array(n)
        end do

        close(file_id)
    end subroutine

end module


!
!     file tpois3d.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_pois3d

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    !-----------------------------------------------
    ! Dictionary
    !-----------------------------------------------
    integer(ip), parameter :: L = 30, M = 30, N = 10
    integer(ip), parameter :: LDIMF = L + 2, MDIMF = M + 3
    integer(ip)            :: lperod, mperod, nperod, i, j, k, ierror
    real(wp)               :: x(L), y(M), f(LDIMF, MDIMF, N)
    real(wp), dimension(M) :: a, b, c, z
    real(wp)               :: dx, c1, dy, c2, dz, dz2
    real(wp), parameter    :: ZERO = 0.0_wp, ONE = 1.0_wp, TWO = 2.0_wp
    !-----------------------------------------------

    ! Set boundary conditions
    lperod = 0
    mperod = 0
    nperod = 1

    ! Set mesh sizes
    dx = TWO_PI/L
    dy = TWO_PI/M
    dz = ONE/N
    dz2 = ONE/dz**2

    ! Define constants
    c1 = ONE/dx**2
    c2 = ONE/dy**2

    ! Generate grid points for later use
    do i = 1, L
        x(i) = -PI + real(i - 1, kind=wp)*dx
    end do

    do j = 1, M
        y(j) = -PI + real(j - 1, kind=wp)*dy
    end do

    ! Generate coefficients
    block
        real(wp) :: t, t2

        a(1) = ZERO
        b(1) = -TWO *dz2
        c(1) = -b(1)
        z(1) = ZERO
        do k = 2, N
            z(k) = real(k - 1, kind=wp)*dz
            t = ONE + z(k)
            t2 = t**2
            a(k) = t2 * dz2 + t/dz
            b(k) = -TWO * t2 * dz2
            c(k) = t2 * dz2 - t/dz
        end do
    end block

    ! Generate right hand side of equation
    block
        real(wp), parameter :: EIGHT = 8.0_wp
        real(wp), parameter :: TEN = 10.0_wp
        real(wp), parameter :: SIXTEEN = 16.0_wp

        do i = 1, L
            do j = 1, M
                do k = 2, N
                    f(i, j, k) = TWO *sin(x(i))*sin(y(j))*(ONE + z(k))**4
                end do
            end do
        end do
        do i = 1, L
            do j = 1, L
                f(i,j,1) = (TEN + (EIGHT/dz)) * sin(x(i)) * sin(y(j))
                f(i,j,N) = f(i,j,N) - c(N) * SIXTEEN * sin(x(i)) * sin(y(j))
            end do
        end do
        c(N) = ZERO
    end block

    ! Solve 3D real linear system on centered grid
    call pois3d(lperod, L, c1, mperod, M, c2, nperod, N, a, b, c, &
        LDIMF, MDIMF, f, ierror)

    ! Compute discretization error. The exact solution is
    !
    ! u(x, y, z) = sin(x)*sin(y)*(1+z)**4
    !
    block
        real(wp), parameter :: KNOWN_ERROR = 0.293277049861086e-001_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(L,M,N)

        do k = 1, N
            do j = 1, M
                do i = 1, L
                    exact_solution(i,j,k) = sin(x(i)) * sin(y(j)) * (ONE + z(k))**4
                end do
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:L,:M,:N)))

        call check_output('pois3d', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_pois3d


! @Copyright 2007 Kristjan Haule
!

SUBROUTINE kramarskronig(gr, fi, om, i0, nom)
  IMPLICIT NONE
  REAL*8, intent(out):: gr
  REAL*8, intent(in) :: fi(nom)
  REAL*8, intent(in) :: om(nom)
  INTEGER, intent(in) :: i0, nom
  !f2py integer intent(hide), depend(om)  :: nom = shape(om,0)
  !locals
  REAL*8, PARAMETER :: pi=3.14159265
  REAL*8 :: sm
  REAL*8 :: dh(nom)
  REAL*8 :: S0, x
  INTEGER :: j, i0f

  i0f = i0+1
  S0 = fi(i0f)
  x = om(i0f)

  dh(1) = 0.5*(om(2)-om(1))
  do j=2,nom-1
     dh(j) = 0.5*(om(j+1)-om(j-1))
  enddo
  dh(nom) = 0.5*(om(nom)-om(nom-1))

  sm=0
  do j=1,i0f-2
     sm = sm + (fi(j)-S0)*dh(j)/(om(j)-x)
  enddo

  if (i0f>1)   sm = sm + (fi(i0f-1)-S0)*(dh(i0f-1)+0.5*dh(i0f))/(om(i0f-1)-x)

  if (i0f<nom) sm = sm + (fi(i0f+1)-S0)*(dh(i0f+1)+0.5*dh(i0f))/(om(i0f+1)-x)

  do j=i0f+2,nom
     sm = sm + (fi(j)-S0)*dh(j)/(om(j)-x)
  enddo

  if (.NOT.(i0f .EQ. 1 .OR. i0f.EQ.nom)) then
     sm = sm + S0*log(abs((om(nom)-x)/(x-om(1))))
  endif

  gr = sm/pi

  RETURN

END SUBROUTINE kramarskronig


program fourPointWing
  use libMath
  implicit none
  integer, parameter :: nc = 15  ! No. of chordwise panels per semispan
  integer, parameter :: ns = 20  ! No. of spanwise panels per semispan

  integer :: nx, ny, nyStart, nz  ! No. of grid points
  real(dp), dimension(3,nc+1,2*ns+1) :: PC
  integer :: i,ic,is
  real(dp) :: xShift, yShift, zShift, xc
  real(dp), dimension(3) :: P1,P2,P3,P4,Pshift
  real(dp) :: sweep_rad, semispan, rootChord, tipChord
  character(len=4) :: airfoil
  real(dp) :: camberM  ! Max camber
  real(dp) :: camberP  ! Position of max camber
  real(dp) :: localChord
  integer :: spacingMethod, isFullspan, inputMethod

  ! ==== INPUTS ====
  ! Input method
  ! [1]Parameters [2]Coordinates
  inputMethod = 1

  ! Spacing method
  ! [1]linspace  [2]cosspace
  spacingMethod = 2

  ! Input geometry of wing
  sweep_rad = 00._dp*pi/180._dp
  semispan  = 0.25_dp
  rootChord = 0.04_dp
  tipChord  = 0.04_dp

  ! Shift in coordinates
  xShift = 0._dp
  yShift = 0.025_dp
  zShift = 0._dp

  ! Input four digit airfoil
  ! NACA MPXX
  airfoil = "6904"

  ! Output selection
  ! [0]semispan [1]full-span
  isFullspan = 0

  ! ==== ===== ====

  read(airfoil(1:1),*) camberM
  camberM = camberM/100._dp
  read(airfoil(2:2),*) camberP
  camberP = camberP/10._dp

  if (inputMethod == 1) then
    ! Rectangular swept wing
    P1=(/0.0000_dp,0.0000_dp,0.0000_dp/)
    P2=(/rootChord,0.0000_dp,0.0000_dp/)
    P3=(/tipChord+semispan*tan(sweep_rad),semispan,0.0000_dp/)
    P4=(/0.0000_dp+semispan*tan(sweep_rad),semispan,0.0000_dp/)

    Pshift = (/xShift, yShift, zShift/)
    P1 = P1 + Pshift
    P2 = P2 + Pshift
    P3 = P3 + Pshift
    P4 = P4 + Pshift
  else

    ! Schematic of wing
    !
    !   O----------------> Y
    !   |
    !   |  P1--------P4
    !   |  |          |
    !   |  |          |
    !   |  |          |
    !   |  P2--------P3
    !   |
    ! X V

    ! Input coordinates

    ! TN-3304
    !P1=(/-0.21336_dp,0.0000_dp,0.0000_dp/)
    !P2=(/ 0.32004_dp,0.0000_dp,0.0000_dp/)
    !P3=(/ 0.22860_dp,1.0414_dp,0.0000_dp/)
    !P4=(/-0.15240_dp,1.0414_dp,0.0000_dp/)

    ! Rectangular wing
    !P1=(/0.0000_dp,0.0000_dp,0.0000_dp/)
    !P2=(/0.3048_dp,0.0000_dp,0.0000_dp/)
    !P3=(/0.3048_dp,0.4313_dp,0.0000_dp/)
    !P4=(/0.0000_dp,0.4313_dp,0.0000_dp/)

    ! Warren-12
    !P1=(/0.0000_dp,0.0000_dp,0.0000_dp/)
    !P2=(/0.4572_dp,0.0000_dp,0.0000_dp/)
    !P3=(/0.7346_dp,0.4313_dp,0.0000_dp/)
    !P4=(/0.5822_dp,0.4313_dp,0.0000_dp/)

    ! TR-1208
    !P1=(/00.000_dp,00.000_dp,00.000_dp/)
    !P2=(/21.941_dp,00.000_dp,00.000_dp/)
    !P3=(/76.520_dp,63.630_dp,00.000_dp/)
    !P4=(/66.647_dp,63.630_dp,00.000_dp/)

  endif

  ! Print out area
  print*,'Full span Area = ',norm2(cross3(P3-P1,P4-P2))

  select case (spacingMethod)
  case (1)
    ! Construct LE and TE of right wing
    do i=1,3
      PC(i,nc+1,ns+1:2*ns+1)   = linspace(P2(i),P3(i),ns+1)
      PC(i,1,ns+1:2*ns+1)      = linspace(P1(i),P4(i),ns+1)
    enddo

    ! Construct inner mesh of right wing
    do i=1,3
      do is=ns+1,2*ns+1
        PC(i,:,is) = linspace(PC(i,1,is),PC(i,nc+1,is),nc+1)
      enddo
    enddo

  case (2)
    ! Construct LE and TE of right wing
    do i=1,3
      PC(i,nc+1,ns+1:2*ns+1)   = cosspace(P2(i),P3(i),ns+1)
      PC(i,1,ns+1:2*ns+1)      = cosspace(P1(i),P4(i),ns+1)
    enddo

    ! Construct inner mesh of right wing
    do i=1,3
      do is=ns+1,2*ns+1
        PC(i,:,is) = cosspace(PC(i,1,is),PC(i,nc+1,is),nc+1)
      enddo
    enddo

  end select

  if (camberM > 0._dp) then
    do is=ns+1,2*ns+1
      localChord = PC(1,nc+1,is)-PC(1,1,is)
      do ic=1,nc+1
        ! xc has to be used since the formula only
        ! works for unit chord airfoil
        xc = PC(1,ic,is)/localChord
        if (xc .lt. camberP) then
          PC(3,ic,is) = localChord*camberM/camberP**2._dp &
            *(2._dp*camberP*xc-xc**2._dp)
        else
          PC(3,ic,is) = localChord*camberM/(1._dp-camberP)**2._dp &
            *(1._dp-2._dp*camberP+2._dp*camberP*xc-xc**2._dp)
        endif
      enddo
    enddo
  endif

  ! Mirror right wing to left wing
  do is=1,ns
    PC(1,:,is) = PC(1,:,(2*ns+1)-is+1)
    PC(2,:,is) = PC(2,:,(2*ns+1)-is+1)*(-1_dp)
    PC(3,:,is) = PC(3,:,(2*ns+1)-is+1)
  enddo

  ! No. of grid points to write to file
  nx = nc+1
  if (isFullspan == 1) then
    nyStart = 1
  else
    nyStart = ns+1
  endif
  ny = 2*ns+1
  nz = 1

  ! Write to output file
  open(unit=11,file='output.xyz')
  write(11,*) nx, ny-nyStart+1, nz
  write(11,*) &
    ((PC(1,ic,is),ic=1,nx),is=nyStart,ny), &
    ((PC(2,ic,is),ic=1,nx),is=nyStart,ny), &
    ((PC(3,ic,is),ic=1,nx),is=nyStart,ny)
  close(11)

end program fourPointWing


*> \brief \b ZLARFG generates an elementary reflector (Householder matrix).
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
*       .. Scalar Arguments ..
*       INTEGER            INCX, N
*       COMPLEX*16         ALPHA, TAU
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         X( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZLARFG generates a complex elementary reflector H of order n, such
*> that
*>
*>       H**H * ( alpha ) = ( beta ),   H**H * H = I.
*>              (   x   )   (   0  )
*>
*> where alpha and beta are scalars, with beta real, and x is an
*> (n-1)-element complex vector. H is represented in the form
*>
*>       H = I - tau * ( 1 ) * ( 1 v**H ) ,
*>                     ( v )
*>
*> where tau is a complex scalar and v is a complex (n-1)-element
*> vector. Note that H is not hermitian.
*>
*> If the elements of x are all zero and alpha is real, then tau = 0
*> and H is taken to be the unit matrix.
*>
*> Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*>          ALPHA is COMPLEX*16
*>          On entry, the value alpha.
*>          On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension
*>                         (1+(N-2)*abs(INCX))
*>          On entry, the vector x.
*>          On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>          The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is COMPLEX*16
*>          The value tau.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup complex16OTHERauxiliary
*
*  =====================================================================
      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
*
*  -- LAPACK auxiliary routine (version 3.8.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      COMPLEX*16         ALPHA, TAU
*     ..
*     .. Array Arguments ..
      COMPLEX*16         X( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J, KNT
      DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
      COMPLEX*16         ZLADIV
      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZDSCAL, ZSCAL
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.0 ) THEN
         TAU = ZERO
         RETURN
      END IF
*
      XNORM = DZNRM2( N-1, X, INCX )
      ALPHR = DBLE( ALPHA )
      ALPHI = DIMAG( ALPHA )
*
      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
*
*        H  =  I
*
         TAU = ZERO
      ELSE
*
*        general case
*
         BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
         RSAFMN = ONE / SAFMIN
*
         KNT = 0
         IF( ABS( BETA ).LT.SAFMIN ) THEN
*
*           XNORM, BETA may be inaccurate; scale X and recompute them
*
   10       CONTINUE
            KNT = KNT + 1
            CALL ZDSCAL( N-1, RSAFMN, X, INCX )
            BETA = BETA*RSAFMN
            ALPHI = ALPHI*RSAFMN
            ALPHR = ALPHR*RSAFMN
            IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) )
     $         GO TO 10
*
*           New BETA is at most 1, at least SAFMIN
*
            XNORM = DZNRM2( N-1, X, INCX )
            ALPHA = DCMPLX( ALPHR, ALPHI )
            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
         END IF
         TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
         ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
         CALL ZSCAL( N-1, ALPHA, X, INCX )
*
*        If ALPHA is subnormal, it may lose relative accuracy
*
         DO 20 J = 1, KNT
            BETA = BETA*SAFMIN
 20      CONTINUE
         ALPHA = BETA
      END IF
*
      RETURN
*
*     End of ZLARFG
*
      END


C
C $Id: ngdots.f,v 1.14 2008-07-27 00:17:17 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 NGDOTS(X,Y,NUM,SIZE,ICOLOR)
C
C  Draws filled dots at positions (X(I),Y(I),I=1,NUM) at size
C  SIZE with color given by the color index ICOLOR.  Size is
C  the diameter of the dot in world coordinates along the vertical
C  axis.
C
C  The dots are scaled appropriately so that they will be circular
C  when the normalization transformation does not preserve aspect
C  ratio.
C
C  The algorithm is to construct a single circle and then translate
C  it to the various coordinate positions.  The original circle is
C  computed by using trig functions to get points in the first
C  octant, and then using symmetries to get the rest of the points
C  on the circle.
C
C  The number of points used for the circle is adjusted depending
C  on the relative size of the circle.  The maximum number of points
C  is 512 and the minimum is 8.
C
      SAVE
C
      include 'ngcomn.h'
C
      DIMENSION X(NUM),Y(NUM),TWIN(4),TVPT(4)
      DIMENSION CIRCX(513),CIRCY(513),CIRCXX(513),CIRCYY(513)
      INTEGER   OLDASF(13),NEWASF(13)
C
C  PI and number of points per unit of arc length.
C
      DATA PI,NPU/3.1415927,1200/
C
C  Size below which markers are drawn in addition to the filled dots
C  to insure that the dots do not disappear by falling between pixels.
C
      DATA DM/.05/
C
C  Size cutoff for increasing the number of points at smaller sizes
C  so that the dots look round.
C
      DATA PC/.03/
C
C  Minimum dot size.  Below this tolerance, only dot markers are drawn.
C
      DATA SM/.001/
C
      DATA IFIRST/0/
C
C  If log scaling or mirror imaging has been requested, issue a
C  warning that only GKS world coordinates are accepted.
C
      CALL GETUSV('LS',LSV)
      CALL GETUSV('MI',MIV)
      IF ((LSV.NE.1 .OR. MIV.NE.1) .AND. IFIRST.EQ.0) THEN
        PRINT *, 'NGDOTS -- **Warning**'
        PRINT *, '          Log scaling or mirror-imaging have been requ
     +ested via a SET call;'
        PRINT *, '          NGDOTS accepts only GKS world coordinates.'
        IFIRST = 1
      ENDIF
C
C  Calculate the number of points to use in calculating the points
C  in the first octant of the circle.
C
      CALL GQCNTN(IER,NTNR)
      CALL GQNT(NTNR,IER,TWIN,TVPT)
C
C  Normalize the size.
C
      SD = SIZE*(TVPT(4)-TVPT(3))/(TWIN(4)-TWIN(3))
C
C  Set a minimum dot size.
C
      IF (SD .LT. SM) THEN
        SD = SM
        TSIZE = SD*(TWIN(4)-TWIN(3))/(TVPT(4)-TVPT(3))
      ELSE
        TSIZE = SIZE
      ENDIF
C
C  Calculate the number of points on the curve.
C
      NP = INT(NPU*PI*SD)
C
C  Increase the number of points for smaller circles.
C
      IF (SD .LE. PC) NP = NP*2
      NP = NP/8
      NP = NP+1
      NP = MAX(NP,2)
      NP = MIN(NP,64)
C
C  Center the dot at (0.,0.) and translate it to the (X,Y)
C  coordinates later.
C
C  Calculate the points in the first octant.
C
      AINC = .25*PI/REAL(NP)
      R = .5*TSIZE
      DO 10 I=1,NP
        T = REAL(I-1)*AINC
        CIRCX(I) = R*COS(T)
        CIRCY(I) = R*SIN(T)
   10 CONTINUE
C
C  Use symmetries to get the other points on the circle.
C
      NP2 = 2*NP
      DO 30 I=NP+1,NP2-1
        CIRCX(I) = CIRCY(NP2-I)
        CIRCY(I) = CIRCX(NP2-I)
   30 CONTINUE
      NP = NP2-1
      NP2 = 2*NP
      DO 40 I=NP+1,NP2-1
        CIRCX(I) = -CIRCX(NP2-I)
        CIRCY(I) =  CIRCY(NP2-I)
   40 CONTINUE
      NP = NP2-1
      NP2 = 2*NP
      DO 50 I=NP+1,NP2-1
        CIRCX(I) =  CIRCX(NP2-I)
        CIRCY(I) = -CIRCY(NP2-I)
   50 CONTINUE
      NP = NP2-1
C
C  Scale factor for non-square aspect ratios.
C
      WSCALE = (TWIN(2)-TWIN(1))/(TWIN(4)-TWIN(3))
      VSCALE = (TVPT(4)-TVPT(3))/(TVPT(2)-TVPT(1))
      DO 20 I=1,NP
        CIRCX(I) = WSCALE*VSCALE*CIRCX(I)
   20 CONTINUE
C
C  Draw filled dots if the size is large enough.
C
      IF (SD .GE. SM) THEN
C
C  Save the fill color index and interior style.
C
        CALL GQFACI(IER,ICOLRO)
        CALL GQFAIS(IER,ISTYLO)
C
C  Set the fill style to solid and the fill collor to ICOLOR.
C
        CALL GSFAIS(1)
        CALL GSFACI(ICOLOR)
C
C  Draw the dots or circles, depending on ICDFLG.
C
        DO 60 I=1,NUM
          DO 70 J=1,NP
            CIRCXX(J) = X(I) + CIRCX(J)
            CIRCYY(J) = Y(I) + CIRCY(J)
   70     CONTINUE
          IF (ICDFLG .EQ. 0) THEN
            CALL GFA(NP,CIRCXX,CIRCYY)
          ELSE
            CALL GQPLCI(IER,IPLCO)
            CALL GSPLCI(ICOLOR)
            CALL GPL(NP,CIRCXX,CIRCYY)
            CALL GSPLCI(IPLCO)
          ENDIF
   60   CONTINUE
C
C  Restore the fill color and style.
C
        CALL GSFACI(ICOLRO)
        CALL GSFAIS(ISTYLO)
      ENDIF
C
C  Draw polymarkers if the size is small enough (note that there is
C  an overlap where both dots and markers are drawn).  The polymarkers
C  are drawn only when filled dots are requested and not when circles
C  are requested.
C
      IF (SD.LT.DM .AND. ICDFLG.EQ.0) THEN
C
C  Save current GKS attributes.
C
        CALL GQASF(IER,OLDASF)
        CALL GQMK (IER,MTYPEO)
        CALL GQMKSC(IER,SZSFO)
        CALL GQPMCI(IER,IMCOLO)
C
C  Set attributes for polymarkers and draw them.
C
        DO 80 I=1,13
          NEWASF(I) = OLDASF(I)
   80   CONTINUE
        NEWASF(4) = 1
        NEWASF(5) = 1
        NEWASF(6) = 1
        CALL GSASF(NEWASF)
        CALL GSMK(1)
        CALL GSMKSC(1.0)
        CALL GSPMCI(ICOLOR)
        CALL GPM(NUM,X,Y)
C
C  Restore original attributes.
C
        CALL GSASF(OLDASF)
        CALL GSMK(MTYPEO)
        CALL GSMKSC(SZSFO)
        CALL GSPMCI(IMCOLO)
      ENDIF
C
      RETURN
      END


! This routine performs an interpolation of the curve that
! passes through x,y to xx,yy. The interpolation is performed joining
! adjacent points by a straight line and then smoothing the result
! by convolving it with a Gaussian whose width is a half of the distance
! between the two closest nodes.
!
Subroutine Smoothed_lines(n, nn, x, y, xx, yy)
  Implicit None
  Integer :: n, nn, inode, ipoint, jpoint, i
  Real, dimension (n) :: x, y
  Real, dimension (nn) :: xx, yy, yy2
  Real :: x1, x2, y1, y2, closest, expo, Norm
!
! Compute segments
!
  yy=0.
  Do inode=1, n-1
     x1=x(inode)
     x2=x(inode+1)
     y1=y(inode)
     y2=y(inode+1)
     Do ipoint=1, nn
        If (xx(ipoint) .ge. x1 .and. xx(ipoint) .le. x2) then
           yy(ipoint)=y1+(y2-y1)/(x2-x1)*(xx(ipoint)-x1)
        End If
     End do
  End do

! Do not smooth ! DEBUG
! For some reason the inversions don't work very well with this option
  Return

!
! Smooth the result
!
!     Find the closest nodes
!
  closest=abs(x(1)-x(2))
  Do inode=2, n-1
     If (abs(x(inode)-x(inode+1)) .lt. closest) &
          closest=abs(x(inode)-x(inode+1))
  End do
!
! Convolve (note that the model is not necessarily equispaced)
!
  closest=closest/2.
  yy2=0.
  Do ipoint=1, nn
     Norm=0.
     Do jpoint=1,nn
        x1=xx(jpoint)-xx(ipoint)
        If (x1*x1/closest/closest .lt. 25.) then
           expo=exp(-x1*x1/(closest*closest))
           yy2(ipoint)=yy2(ipoint)+yy(jpoint)*expo
           Norm=Norm+expo
        End If
     End Do
     yy2(ipoint)=yy2(ipoint)/Norm
  End Do
  yy=yy2
!
! Done
!
  Return
End Subroutine Smoothed_lines