C$Procedure      ROTMAT ( Rotate a matrix )

      SUBROUTINE ROTMAT ( M1, ANGLE, IAXIS, MOUT )

C$ Abstract
C
C     ROTMAT applies a rotation of ANGLE radians about axis IAXIS to a
C     matrix.  This rotation is thought of as rotating the coordinate
C     system.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C     ROTATION
C
C$ Declarations

      DOUBLE PRECISION   M1    ( 3,3 )
      DOUBLE PRECISION   ANGLE
      INTEGER            IAXIS
      DOUBLE PRECISION   MOUT  ( 3,3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     M1         I   Matrix to be rotated.
C     ANGLE      I   Angle of rotation (radians).
C     IAXIS      I   Axis of rotation (X=1, Y=2, Z=3).
C     MOUT       O   Resulting rotated matrix [ANGLE]      * M1
C                                                   IAXIS
C
C$ Detailed_Input
C
C     M1       This is a matrix to which a rotation is to be applied.
C              In matrix algebra, the components of the matrix are
C              relevant in one particular coordinate system. Applying
C              ROTMAT changes the components of M1 so that they are
C              relevant to a rotated coordinate system.
C
C     ANGLE    The angle in radians through which the original
C              coordinate system is to be rotated.
C
C     IAXIS    An index for the axis of the original coordinate system
C              about which the rotation by ANGLE is to be performed.
C              IAXIS = 1,2 or 3 designates the x-, y- or z-axis,
C              respectively.
C
C$ Detailed_Output
C
C     MOUT     The matrix resulting from the application of the
C              specified rotation to the input matrix M1.  If
C              [ANGLE]        denotes the rotation matrix by ANGLE
C                     IAXIS
C              radians about IAXIS, (refer to the routine ROTATE) then
C              MOUT is given by the following matrix equation:
C
C                 MOUT = [ANGLE]      * M1
C                               IAXIS
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the axis index is not in the range 1 to 3 it will be
C        treated the same as that integer 1, 2, or 3 that is congruent
C        to it mod 3.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     Suppose that to rotate a set of inertial axes to body fixed
C     axes, one must first roll the coordinate axes about the x-axis by
C     angle R to get x', y', z'.  From this one must pitch about the y'
C     axis by angle P to get x'', y'', z''.  And finally yaw the x'',
C     y'', z'' about the z'' axis by angle Y to obtain the
C     transformation to bodyfixed coordinates.  If ID is the identity
C     matrix, then the following code fragment generates the
C     transformation from inertial to body fixed.
C
C        CALL ROTMAT ( ID, R,     1,     M1   )
C        CALL ROTMAT ( M1, P,     2,     M2   )
C        CALL ROTMAT ( M2, Y,     3,     TIBF )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     rotate a matrix
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 3-JAN-1989 (WLT)
C
C     Upgrade the routine to work with negative axis indexes.  Also take
C     care of the funky way the indices (other than the input) were
C     obtained via the MOD function.  It works but isn't as clear
C     (or fast) as just reading the axes from data.
C
C-&

      DOUBLE PRECISION      S
      DOUBLE PRECISION      C

      INTEGER               TEMP
      INTEGER               I1
      INTEGER               I2
      INTEGER               I3
      INTEGER               I

      DOUBLE PRECISION      PRODM   (3,3)

      INTEGER               INDEXS  (5)
      SAVE                  INDEXS

      DATA                  INDEXS  / 3, 1, 2, 3, 1 /
C
C  Get the sine and cosine of ANGLE
C
      S = DSIN(ANGLE)
      C = DCOS(ANGLE)
C
C  Get indices for axes. The first index is for the axis of rotation.
C  The next two axes follow in right hand order (XYZ).  First get the
C  non-negative value of IAXIS mod 3 .
C
      TEMP = MOD ( MOD(IAXIS,3) + 3, 3 )

      I1   = INDEXS( TEMP + 1 )
      I2   = INDEXS( TEMP + 2 )
      I3   = INDEXS( TEMP + 3 )
C
C  Calculate the output matrix column by column
C
      DO I=1,3
         PRODM(I1,I) =  M1(I1,I)
         PRODM(I2,I) =            C*M1(I2,I) + S*M1(I3,I)
         PRODM(I3,I) =           -S*M1(I2,I) + C*M1(I3,I)
      END DO
C
C  Move the buffered matrix into MOUT.
C
      CALL MOVED (PRODM, 9, MOUT)
C
      RETURN
      END


program test_stats_var
    use forlab_io, only: disp
    use forlab_stats, only: var,randn,rng,mean,std
    real, allocatable :: x(:)
    call rng()
    allocate(X(5))
    x = randn(mean=0.0, std=1.0, ndim=5)
    call disp(x,'randn(n)')
    call disp(mean(x),'mean(randn(n)):')
    call disp(var(x),'var(randn(n)):')
    call disp(std(x), 'std(randn(n)):')
    if(allocated(X)) deallocate(X)
    allocate(X(4))  !!\FIXME:
    x = randn(mean=10.0, std=1.0, ndim=4)
    call disp(X,'call randn(X,10.,1.0)')
end program test_stats_var


      program ssvd
c
c     This example program is intended to illustrate the
c     the use of ARPACK to compute the Singular Value Decomposition.
c
c     This code shows how to use ARPACK to find a few of the
c     largest singular values(sigma) and corresponding right singular
c     vectors (v) for the the matrix A by solving the symmetric problem:
c
c                        (A'*A)*v = sigma*v
c
c     where A is an m by n real matrix.
c
c     This code may be easily modified to estimate the 2-norm
c     condition number  largest(sigma)/smallest(sigma) by setting
c     which = 'BE' below.  This will ask for a few of the smallest
c     and a few of the largest singular values simultaneously.
c     The condition number could then be estimated by taking
c     the ratio of the largest and smallest singular values.
c
c     This formulation is appropriate when  m  .ge.  n.
c     Reverse the roles of A and A' in the case that  m .le. n.
c
c     The main points illustrated here are
c
c        1) How to declare sufficient memory to find NEV
c           largest singular values of A .
c
c        2) Illustration of the reverse communication interface
c           needed to utilize the top level ARPACK routine SSAUPD
c           that computes the quantities needed to construct
c           the desired singular values and vectors(if requested).
c
c        3) How to extract the desired singular values and vectors
c           using the ARPACK routine SSEUPD.
c
c        4) How to construct the left singular vectors U from the
c           right singular vectors V to obtain the decomposition
c
c                        A*V = U*S
c
c           where S = diag(sigma_1, sigma_2, ..., sigma_k).
c
c     The only thing that must be supplied in order to use this
c     routine on your problem is to change the array dimensions
c     appropriately, to specify WHICH singular values you want to
c     compute and to supply a the matrix-vector products
c
c                         w <-  Ax
c                         y <-  A'w
c
c     in place of the calls  to AV( ) and ATV( ) respectively below.
c
c     Further documentation is available in the header of DSAUPD
c     which may be found in the SRC directory.
c
c     This codes implements
c
c\Example-1
c     ... Suppose we want to solve A'A*v = sigma*v in regular mode,
c         where A is derived from the simplest finite difference
c         discretization of the 2-dimensional kernel  K(s,t)dt  where
c
c                 K(s,t) =  s(t-1)   if 0 .le. s .le. t .le. 1,
c                           t(s-1)   if 0 .le. t .lt. s .le. 1.
c
c         See subroutines AV  and ATV for details.
c     ... OP = A'*A  and  B = I.
c     ... Assume "call av (n,x,y)" computes y = A*x
c     ... Assume "call atv (n,y,w)" computes w = A'*y
c     ... Assume exact shifts are used
c     ...
c
c\BeginLib
c
c\Routines called:
c     ssaupd  ARPACK reverse communication interface routine.
c     sseupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     snrm2   Level 1 BLAS that computes the norm of a vector.
c     saxpy   Level 1 BLAS that computes y <- alpha*x+y.
c     sscal   Level 1 BLAS thst computes x <- x*alpha.
c     scopy   Level 1 BLAS thst computes y <- x.
c
c\Author
c     Richard Lehoucq
c     Danny Sorensen
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: svd.F   SID: 2.4   DATE OF SID: 10/17/00   RELEASE: 2
c
c\Remarks
c     1. None
c
c\EndLib
c
c-----------------------------------------------------------------------
c
c     %------------------------------------------------------%
c     | Storage Declarations:                                |
c     |                                                      |
c     | It is assumed that A is M by N with M .ge. N.        |
c     |                                                      |
c     | The maximum dimensions for all arrays are            |
c     | set here to accommodate a problem size of            |
c     | M .le. MAXM  and  N .le. MAXN                        |
c     |                                                      |
c     | The NEV right singular vectors will be computed in   |
c     | the N by NCV array V.                                |
c     |                                                      |
c     | The NEV left singular vectors will be computed in    |
c     | the M by NEV array U.                                |
c     |                                                      |
c     | NEV is the number of singular values requested.      |
c     |     See specifications for ARPACK usage below.       |
c     |                                                      |
c     | NCV is the largest number of basis vectors that will |
c     |     be used in the Implicitly Restarted Arnoldi      |
c     |     Process.  Work per major iteration is            |
c     |     proportional to N*NCV*NCV.                       |
c     |                                                      |
c     | You must set:                                        |
c     |                                                      |
c     | MAXM:   Maximum number of rows of the A allowed.     |
c     | MAXN:   Maximum number of columns of the A allowed.  |
c     | MAXNEV: Maximum NEV allowed                          |
c     | MAXNCV: Maximum NCV allowed                          |
c     %------------------------------------------------------%
c
      integer          maxm, maxn, maxnev, maxncv, ldv, ldu
      parameter       (maxm = 500, maxn=250, maxnev=10, maxncv=25,
     &                 ldu = maxm, ldv=maxn )
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      Real
     &                 v(ldv,maxncv), u(ldu, maxnev),
     &                 workl(maxncv*(maxncv+8)), workd(3*maxn),
     &                 s(maxncv,2), resid(maxn), ax(maxm)
      logical          select(maxncv)
      integer          iparam(11), ipntr(11)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      character        bmat*1, which*2
      integer          ido, m, n, nev, ncv, lworkl, info, ierr,
     &                 j, ishfts, maxitr, mode1, nconv
      logical          rvec
      Real
     &                 tol, sigma, temp
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &                 one, zero
      parameter        (one = 1.0E+0, zero = 0.0E+0)
c
c     %-----------------------------%
c     | BLAS & LAPACK routines used |
c     %-----------------------------%
c
      Real
     &                 snrm2
      external         snrm2, saxpy, scopy, sscal
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %-------------------------------------------------%
c     | The following include statement and assignments |
c     | initiate trace output from the internal         |
c     | actions of ARPACK.  See debug.doc in the        |
c     | DOCUMENTS directory for usage.  Initially, the  |
c     | most useful information will be a breakdown of  |
c     | time spent in the various stages of computation |
c     | given by setting msaupd = 1.                    |
c     %-------------------------------------------------%
c
      include 'debug.h'
      ndigit = -3
      logfil = 6
      msgets = 0
      msaitr = 0
      msapps = 0
      msaupd = 1
      msaup2 = 0
      mseigt = 0
      mseupd = 0
c
c     %-------------------------------------------------%
c     | The following sets dimensions for this problem. |
c     %-------------------------------------------------%
c
      m = 500
      n = 100
c
c     %------------------------------------------------%
c     | Specifications for ARPACK usage are set        |
c     | below:                                         |
c     |                                                |
c     |    1) NEV = 4 asks for 4 singular values to be |
c     |       computed.                                |
c     |                                                |
c     |    2) NCV = 20 sets the length of the Arnoldi  |
c     |       factorization                            |
c     |                                                |
c     |    3) This is a standard problem               |
c     |         (indicated by bmat  = 'I')             |
c     |                                                |
c     |    4) Ask for the NEV singular values of       |
c     |       largest magnitude                        |
c     |         (indicated by which = 'LM')            |
c     |       See documentation in SSAUPD for the      |
c     |       other options SM, BE.                    |
c     |                                                |
c     | Note: NEV and NCV must satisfy the following   |
c     |       conditions:                              |
c     |                 NEV <= MAXNEV,                 |
c     |             NEV + 1 <= NCV <= MAXNCV           |
c     %------------------------------------------------%
c
      nev   = 4
      ncv   = 10
      bmat  = 'I'
      which = 'LM'
c
      if ( n .gt. maxn ) then
         print *, ' ERROR with _SVD: N is greater than MAXN '
         go to 9000
      else if ( m .gt. maxm ) then
         print *, ' ERROR with _SVD: M is greater than MAXM '
         go to 9000
      else if ( nev .gt. maxnev ) then
         print *, ' ERROR with _SVD: NEV is greater than MAXNEV '
         go to 9000
      else if ( ncv .gt. maxncv ) then
         print *, ' ERROR with _SVD: NCV is greater than MAXNCV '
         go to 9000
      end if
c
c     %-----------------------------------------------------%
c     | Specification of stopping rules and initial         |
c     | conditions before calling SSAUPD                    |
c     |                                                     |
c     |           abs(sigmaC - sigmaT) < TOL*abs(sigmaC)    |
c     |               computed   true                       |
c     |                                                     |
c     |      If TOL .le. 0,  then TOL <- macheps            |
c     |              (machine precision) is used.           |
c     |                                                     |
c     | IDO  is the REVERSE COMMUNICATION parameter         |
c     |      used to specify actions to be taken on return  |
c     |      from SSAUPD. (See usage below.)                |
c     |                                                     |
c     |      It MUST initially be set to 0 before the first |
c     |      call to SSAUPD.                                |
c     |                                                     |
c     | INFO on entry specifies starting vector information |
c     |      and on return indicates error codes            |
c     |                                                     |
c     |      Initially, setting INFO=0 indicates that a     |
c     |      random starting vector is requested to         |
c     |      start the ARNOLDI iteration.  Setting INFO to  |
c     |      a nonzero value on the initial call is used    |
c     |      if you want to specify your own starting       |
c     |      vector (This vector must be placed in RESID.)  |
c     |                                                     |
c     | The work array WORKL is used in SSAUPD as           |
c     | workspace.  Its dimension LWORKL is set as          |
c     | illustrated below.                                  |
c     %-----------------------------------------------------%
c
      lworkl = ncv*(ncv+8)
      tol = zero
      info = 0
      ido = 0
c
c     %---------------------------------------------------%
c     | Specification of Algorithm Mode:                  |
c     |                                                   |
c     | This program uses the exact shift strategy        |
c     | (indicated by setting IPARAM(1) = 1.)             |
c     | IPARAM(3) specifies the maximum number of Arnoldi |
c     | iterations allowed.  Mode 1 of SSAUPD is used     |
c     | (IPARAM(7) = 1). All these options can be changed |
c     | by the user. For details see the documentation in |
c     | SSAUPD.                                           |
c     %---------------------------------------------------%
c
      ishfts = 1
      maxitr = n
      mode1 = 1
c
      iparam(1) = ishfts
c
      iparam(3) = maxitr
c
      iparam(7) = mode1
c
c     %------------------------------------------------%
c     | M A I N   L O O P (Reverse communication loop) |
c     %------------------------------------------------%
c
 10   continue
c
c        %---------------------------------------------%
c        | Repeatedly call the routine SSAUPD and take |
c        | actions indicated by parameter IDO until    |
c        | either convergence is indicated or maxitr   |
c        | has been exceeded.                          |
c        %---------------------------------------------%
c
         call ssaupd ( ido, bmat, n, which, nev, tol, resid,
     &                 ncv, v, ldv, iparam, ipntr, workd, workl,
     &                 lworkl, info )
c
         if (ido .eq. -1 .or. ido .eq. 1) then
c
c           %---------------------------------------%
c           | Perform matrix vector multiplications |
c           |              w <--- A*x       (av())  |
c           |              y <--- A'*w      (atv()) |
c           | The user should supply his/her own    |
c           | matrix vector multiplication routines |
c           | here that takes workd(ipntr(1)) as    |
c           | the input, and returns the result in  |
c           | workd(ipntr(2)).                      |
c           %---------------------------------------%
c
            call av (m, n, workd(ipntr(1)), ax)
            call atv (m, n, ax, workd(ipntr(2)))
c
c           %-----------------------------------------%
c           | L O O P   B A C K to call SSAUPD again. |
c           %-----------------------------------------%
c
            go to 10
c
         end if
c
c     %----------------------------------------%
c     | Either we have convergence or there is |
c     | an error.                              |
c     %----------------------------------------%
c
      if ( info .lt. 0 ) then
c
c        %--------------------------%
c        | Error message. Check the |
c        | documentation in SSAUPD. |
c        %--------------------------%
c
         print *, ' '
         print *, ' Error with _saupd, info = ', info
         print *, ' Check documentation in _saupd '
         print *, ' '
c
      else
c
c        %--------------------------------------------%
c        | No fatal errors occurred.                  |
c        | Post-Process using SSEUPD.                 |
c        |                                            |
c        | Computed singular values may be extracted. |
c        |                                            |
c        | Singular vectors may also be computed now  |
c        | if desired.  (indicated by rvec = .true.)  |
c        |                                            |
c        | The routine SSEUPD now called to do this   |
c        | post processing                            |
c        %--------------------------------------------%
c
         rvec = .true.
c
         call sseupd ( rvec, 'All', select, s, v, ldv, sigma,
     &        bmat, n, which, nev, tol, resid, ncv, v, ldv,
     &        iparam, ipntr, workd, workl, lworkl, ierr )
c
c        %-----------------------------------------------%
c        | Singular values are returned in the first     |
c        | column of the two dimensional array S         |
c        | and the corresponding right singular vectors  |
c        | are returned in the first NEV columns of the  |
c        | two dimensional array V as requested here.    |
c        %-----------------------------------------------%
c
         if ( ierr .ne. 0) then
c
c           %------------------------------------%
c           | Error condition:                   |
c           | Check the documentation of SSEUPD. |
c           %------------------------------------%
c
            print *, ' '
            print *, ' Error with _seupd, info = ', ierr
            print *, ' Check the documentation of _seupd. '
            print *, ' '
c
         else
c
            nconv =  iparam(5)
            do 20 j=1, nconv
c
               s(j,1) = sqrt(s(j,1))
c
c              %-----------------------------%
c              | Compute the left singular   |
c              | vectors from the formula    |
c              |                             |
c              |     u = Av/sigma            |
c              |                             |
c              | u should have norm 1 so     |
c              | divide by norm(Av) instead. |
c              %-----------------------------%
c
               call av(m, n, v(1,j), ax)
               call scopy(m, ax, 1, u(1,j), 1)
               temp = one/snrm2(m, u(1,j), 1)
               call sscal(m, temp, u(1,j), 1)
c
c              %---------------------------%
c              |                           |
c              | Compute the residual norm |
c              |                           |
c              |   ||  A*v - sigma*u ||    |
c              |                           |
c              | for the NCONV accurately  |
c              | computed singular values  |
c              | and vectors.  (iparam(5)  |
c              | indicates how many are    |
c              | accurate to the requested |
c              | tolerance).               |
c              | Store the result in 2nd   |
c              | column of array S.        |
c              %---------------------------%
c
               call saxpy(m, -s(j,1), u(1,j), 1, ax, 1)
               s(j,2) = snrm2(m, ax, 1)
c
 20         continue
c
c           %-------------------------------%
c           | Display computed residuals    |
c           %-------------------------------%
c
            call smout(6, nconv, 2, s, maxncv, -6,
     &                'Singular values and direct residuals')
         end if
c
c        %------------------------------------------%
c        | Print additional convergence information |
c        %------------------------------------------%
c
         if ( info .eq. 1) then
            print *, ' '
            print *, ' Maximum number of iterations reached.'
            print *, ' '
         else if ( info .eq. 3) then
            print *, ' '
            print *, ' No shifts could be applied during implicit',
     &               ' Arnoldi update, try increasing NCV.'
            print *, ' '
         end if
c
         print *, ' '
         print *, ' _SVD '
         print *, ' ==== '
         print *, ' '
         print *, ' Size of the matrix is ', n
         print *, ' The number of Ritz values requested is ', nev
         print *, ' The number of Arnoldi vectors generated',
     &            ' (NCV) is ', ncv
         print *, ' What portion of the spectrum: ', which
         print *, ' The number of converged Ritz values is ',
     &              nconv
         print *, ' The number of Implicit Arnoldi update',
     &            ' iterations taken is ', iparam(3)
         print *, ' The number of OP*x is ', iparam(9)
         print *, ' The convergence criterion is ', tol
         print *, ' '
c
      end if
c
c     %-------------------------%
c     | Done with program ssvd. |
c     %-------------------------%
c
 9000 continue
c
      end
c
c ------------------------------------------------------------------
c     matrix vector subroutines
c
c     The matrix A is derived from the simplest finite difference
c     discretization of the integral operator
c
c                     f(s) = integral(K(s,t)x(t)dt).
c
c     Thus, the matrix A is a discretization of the 2-dimensional kernel
c     K(s,t)dt, where
c
c                 K(s,t) =  s(t-1)   if 0 .le. s .le. t .le. 1,
c                           t(s-1)   if 0 .le. t .lt. s .le. 1.
c
c     Thus A is an m by n matrix with entries
c
c                 A(i,j) = k*(si)*(tj - 1)  if i .le. j,
c                          k*(tj)*(si - 1)  if i .gt. j
c
c     where si = i/(m+1)  and  tj = j/(n+1)  and k = 1/(n+1).
c
c-------------------------------------------------------------------
c
      subroutine av (m, n, x, w)
c
c     computes  w <- A*x
c
      integer          m, n, i, j
      Real
     &                 x(n), w(m), one, zero, h, k, s, t
      parameter        ( one = 1.0E+0, zero = 0.0E+0 )
c
      h = one / real(m+1)
      k = one / real(n+1)
      do 5 i = 1,m
         w(i) = zero
 5    continue
      t = zero
c
      do 30 j = 1,n
         t = t+k
         s = zero
         do 10 i = 1,j
           s = s+h
           w(i) = w(i) + k*s*(t-one)*x(j)
 10      continue
         do 20 i = j+1,m
           s = s+h
           w(i) = w(i) + k*t*(s-one)*x(j)
 20      continue
 30   continue
c
      return
      end
c
c-------------------------------------------------------------------
c
      subroutine atv (m, n, w, y)
c
c     computes  y <- A'*w
c
      integer         m, n, i, j
      Real
     &                w(m), y(n), one, zero,  h, k, s, t
      parameter       ( one = 1.0E+0, zero = 0.0E+0 )
c
      h = one / real(m+1)
      k = one / real(n+1)
      do 5 i = 1,n
         y(i) = zero
 5    continue
      t = zero
c
      do 30 j = 1,n
         t = t+k
         s = zero
         do 10 i = 1,j
           s = s+h
           y(j) = y(j) + k*s*(t-one)*w(i)
 10      continue
         do 20 i = j+1,m
           s = s+h
           y(j) = y(j) + k*t*(s-one)*w(i)
 20      continue
 30   continue
c
      return
      end
c


*DECK DCHFIE
      DOUBLE PRECISION FUNCTION DCHFIE (X1, X2, F1, F2, D1, D2, A, B)
C***BEGIN PROLOGUE  DCHFIE
C***SUBSIDIARY
C***PURPOSE  Evaluates integral of a single cubic for DPCHIA
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (CHFIE-S, DCHFIE-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C          DCHFIE:  Cubic Hermite Function Integral Evaluator.
C
C     Called by  DPCHIA  to evaluate the integral of a single cubic (in
C     Hermite form) over an arbitrary interval (A,B).
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        DOUBLE PRECISION  X1, X2, F1, F2, D1, D2, A, B
C        DOUBLE PRECISION  VALUE, DCHFIE
C
C        VALUE = DCHFIE (X1, X2, F1, F2, D1, D2, A, B)
C
C   Parameters:
C
C     VALUE -- (output) value of the requested integral.
C
C     X1,X2 -- (input) endpoints if interval of definition of cubic.
C
C     F1,F2 -- (input) function values at the ends of the interval.
C
C     D1,D2 -- (input) derivative values at the ends of the interval.
C
C     A,B -- (input) endpoints of interval of integration.
C
C***SEE ALSO  DPCHIA
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820730  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870707  Corrected subroutine name from DCHIV to DCHFIV.
C   870813  Minor cosmetic changes.
C   890411  1. Added SAVE statements (Vers. 3.2).
C           2. Added SIX to DOUBLE PRECISION declaration.
C   890411  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR section in prologue.  (WRB)
C   930503  Corrected to set VALUE=0 when IERR.ne.0.  (FNF)
C   930504  Eliminated IERR and changed name DCHFIV to DCHFIE.  (FNF)
C***END PROLOGUE  DCHFIE
C
C  Programming notes:
C  1. There is no error return from this routine because zero is
C     indeed the mathematically correct answer when X1.EQ.X2 .
C**End
C
C  DECLARE ARGUMENTS.
C
      DOUBLE PRECISION  X1, X2, F1, F2, D1, D2, A, B
C
C  DECLARE LOCAL VARIABLES.
C
      DOUBLE PRECISION  DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2,
     *      PHIB1, PHIB2, PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2,
     *      TB1, TB2, THREE, TWO, UA1, UA2, UB1, UB2
      SAVE HALF, TWO, THREE, FOUR, SIX
C
C  INITIALIZE.
C
      DATA  HALF/.5D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, SIX/6.D0/
C
C  VALIDITY CHECK INPUT.
C
C***FIRST EXECUTABLE STATEMENT  DCHFIE
      IF (X1 .EQ. X2)  THEN
         DCHFIE = 0
      ELSE
         H = X2 - X1
         TA1 = (A - X1) / H
         TA2 = (X2 - A) / H
         TB1 = (B - X1) / H
         TB2 = (X2 - B) / H
C
         UA1 = TA1**3
         PHIA1 = UA1 * (TWO - TA1)
         PSIA1 = UA1 * (THREE*TA1 - FOUR)
         UA2 = TA2**3
         PHIA2 =  UA2 * (TWO - TA2)
         PSIA2 = -UA2 * (THREE*TA2 - FOUR)
C
         UB1 = TB1**3
         PHIB1 = UB1 * (TWO - TB1)
         PSIB1 = UB1 * (THREE*TB1 - FOUR)
         UB2 = TB2**3
         PHIB2 =  UB2 * (TWO - TB2)
         PSIB2 = -UB2 * (THREE*TB2 - FOUR)
C
         FTERM =   F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1)
         DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX)
C
         DCHFIE = (HALF*H) * (FTERM + DTERM)
      ENDIF
C
      RETURN
C------------- LAST LINE OF DCHFIE FOLLOWS -----------------------------
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1991  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine orthog  --  Gram-Schmidt orthogonalization  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "orthog" performs an orthogonalization of an input matrix
c     via the modified Gram-Schmidt algorithm
c
c     variables and parameters:
c
c     m     first dimension of the matrix to orthogonalize
c     n     second dimension of the matrix to orthogonalize
c     a     matrix to orthogonalize; contains result on exit
c
c
      subroutine orthog (m,n,a)
      implicit none
      integer i,j,k
      integer m,n
      real*8 rkk,rkj
      real*8 a(m,*)
c
c
c     compute the modified Gram-Schmidt orthogonalization
c
      do k = 1, n
         rkk = 0.0d0
         do i = 1, m
            rkk = rkk + a(i,k)**2
         end do
         rkk = sqrt(rkk)
         do i = 1, m
            a(i,k) = a(i,k) / rkk
         end do
         do j = k+1, n
            rkj = 0.0d0
            do i = 1, m
               rkj = rkj + a(i,k)*a(i,j)
            end do
            do i = 1, m
               a(i,j) = a(i,j) - a(i,k)*rkj
            end do
         end do
      end do
      return
      end


MODULE numerical_utilities
use num_types
implicit none
private
public equal
! Overloaded procedure for comparing real types
   INTERFACE equal
      MODULE PROCEDURE equal_scalar , &
                       equal_rank1,  &
                       equal_rank2,  &
                       equal_rank3,  &
                       equal_rank1_rank0, &
                       equal_rank2_rank0, &
                       equal_rank2_real_int, &
                       equal_rank1_real_int, &
                       equal_scalar_real_int, &
                       equal_scalar_int_int

   END INTERFACE

CONTAINS
  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second array to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank1(a, b, rtolerance, atolerance_)
    logical :: equal_rank1
    real(dp) :: a(:), b(:), rtolerance
    real(dp) :: atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank1 = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank1 = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionality would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),maxval(abs(b))))) then
       equal_rank1 = .true.
    end if
  end function equal_rank1

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second array to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank2(a, b, rtolerance, atolerance_)
    logical :: equal_rank2
    real(dp) :: a(:,:), b(:,:), rtolerance
    real(dp) :: atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank2 = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank2 = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),maxval(abs(b))))) then
       equal_rank2 = .true.
    end if
  end function equal_rank2

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second array to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank3(a, b, rtolerance, atolerance_)
    logical :: equal_rank3
    real(dp) :: a(:,:,:), b(:,:,:), rtolerance
    real(dp) :: atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank3 = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank3 = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),maxval(abs(b))))) then
       equal_rank3 = .true.
    end if
  end function equal_rank3

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first real scalar to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second real scalar to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_scalar(a, b, rtolerance, atolerance_)
    logical :: equal_scalar
    real(dp) :: a, b, rtolerance
    real(dp) :: atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_scalar = .false.
    if(abs(a-b) == 0.0) then
       equal_scalar = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(abs(a - b) < atolerance + rtolerance * max(abs(a),abs(b))) then
       equal_scalar = .true.
    end if
  end function equal_scalar

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first integer to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second real to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_scalar_real_int(a, b, rtolerance, atolerance_)
    logical :: equal_scalar_real_int
    integer :: b
    real(dp) :: a, rtolerance
    real(dp) :: atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_scalar_real_int = .false.
    if(abs(a-b) == 0.0) then
       equal_scalar_real_int = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(abs(a - b) < atolerance + rtolerance * max(abs(a),abs(real(b,dp)))) then
       equal_scalar_real_int = .true.
    end if
  end function equal_scalar_real_int

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first integer to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second integer to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_scalar_int_int(a, b, rtolerance, atolerance_)
    logical :: equal_scalar_int_int
    real(dp) ::  rtolerance, atolerance
    real(dp), OPTIONAL :: atolerance_
    integer :: a, b
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_scalar_int_int = .false.
    if(abs(a-b) == 0) then
       equal_scalar_int_int = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(abs(a - b) < atolerance + rtolerance * max(abs(real(a,dp)),abs(real(b,dp)))) then
       equal_scalar_int_int = .true.
    end if
  end function equal_scalar_int_int

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first 1D array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second real scalar to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank1_rank0(a, b, rtolerance, atolerance_)
    logical :: equal_rank1_rank0
    real(dp) :: a(:), b, rtolerance, atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank1_rank0 = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank1_rank0 = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),abs(b)))) then
       equal_rank1_rank0 = .true.
    end if
  end function equal_rank1_rank0

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first 2D array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second real scalar to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank2_rank0(a, b, rtolerance, atolerance_)
    logical :: equal_rank2_rank0
    real(dp) :: a(:,:), b, rtolerance, atolerance
    real(dp), OPTIONAL :: atolerance_
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank2_rank0 = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank2_rank0 = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),abs(b)))) then
       equal_rank2_rank0 = .true.
    end if
  end function equal_rank2_rank0

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first real 2D array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second integer 2D array to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank2_real_int(a, b, rtolerance, atolerance_)
    logical :: equal_rank2_real_int
    real(dp) :: a(:,:), rtolerance, atolerance
    real(dp), OPTIONAL :: atolerance_
    integer :: b(:,:)
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank2_real_int = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank2_real_int = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),maxval(abs(real(b,dp)))))) then
       equal_rank2_real_int = .true.
    end if
  end function equal_rank2_real_int

  !!This function takes two real entities and compares them
  !! to see if they are equal within some tolerance. This prevents
  !! failed comparisons due to numbers that are "equal" but differ due
  !! to small differences arising from finite precision.
  !!<parameter name="a" regular="true">The first 1D real array to be
  !!compared.</parameter>
  !!<parameter name="b" regular="true">The second 1D integer array to be
  !!compared.</parameter>
  !!<parameter name="rtolerance" regular="true">The relative tolerance for their comparison
  !! which is multiplied to the larger of a and b.</parameter>
  !!<parameter name="atolerance_" regular="true">The optional absolute
  !!tolerance for their comparison. Is added to the relative tolerance.
  !!Default value is 5E-4</parameter>
  function equal_rank1_real_int(a, b, rtolerance, atolerance_)
    logical :: equal_rank1_real_int
    real(dp) :: a(:), rtolerance, atolerance
    real(dp), OPTIONAL :: atolerance_
    integer :: b(:)
    if(present(atolerance_)) then; atolerance = atolerance_; else; atolerance = 5E-4_dp; endif

    equal_rank1_real_int = .false.
    if(all(abs(a-b) == 0.0)) then
       equal_rank1_real_int = .true. !This line was added so that if a user did
    !request a comparison with a tolerance of zero it would return the
    !correct result, or if the values are actually zero. We added this
    !line instead of making the following one <= so that the codes
    !original functionallity would be unaltered.
    else if(all(abs(a - b) < atolerance + rtolerance * max(maxval(abs(a)),maxval(abs(real(b,dp)))))) then
       equal_rank1_real_int = .true.
    end if
  end function equal_rank1_real_int

END MODULE numerical_utilities


PROGRAM F004

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: I, J, N
    LOGICAL :: IS_PALINDROME

    DO I = 999, 900, -1
        DO J = 999, 900, -1
            N = I * J
            IF (IS_PALINDROME(N)) THEN
                GOTO 10
            END IF
        END DO
    END DO

    10 CONTINUE

    PRINT ('(I0)'), N

END PROGRAM F004

LOGICAL FUNCTION IS_PALINDROME (N_VAL)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N_VAL
    INTEGER :: I, N_LEN_BY_2
    CHARACTER (LEN=10)  :: N_STR
    CHARACTER (LEN=5)   :: N_STR_SPLIT_1, N_STR_SPLIT_2

    WRITE (N_STR, '(I0)') N_VAL
    N_LEN_BY_2 = INT(CEILING(LEN_TRIM(N_STR) / 2.0))
    N_STR_SPLIT_1 = N_STR(1:3)
    N_STR_SPLIT_2 = N_STR(N_LEN_BY_2+1:)
    FORALL (I=1:N_LEN_BY_2) N_STR_SPLIT_2(I:I) &
         = N_STR_SPLIT_2(N_LEN_BY_2-I+1:N_LEN_BY_2-I+1)
    IF (N_STR_SPLIT_1 == N_STR_SPLIT_2) THEN
        IS_PALINDROME = .TRUE.
    ELSE
        IS_PALINDROME = .FALSE.
    END IF

END FUNCTION IS_PALINDROME


program main

        implicit none

        integer :: i

        i = 1

        do
                if(evenly_divis(i)) then
                        exit
                end if

                i = i + 1
        end do

        print *, i

contains

        function evenly_divis (a)
                integer :: a, i
                logical :: evenly_divis

                evenly_divis = .true.

                do i = 1, 20, 1

                        if(mod(a, i) /= 0) then
                                evenly_divis = .false.
                                exit
                        end if

                end do

                return

        end function evenly_divis

end program main


program descriptive_statistics
    use, intrinsic :: iso_fortran_env, only : error_unit, input_unit, output_unit
    use :: stats_mod
    implicit none
    type(descriptive_stats_t) :: stats
    real, dimension(3) :: data_values = [ 3.5, 5.7, 7.3 ]
    integer :: i

    do i = 1, size(data_values)
        call stats%add_data(data_values(i))
    end do
    print '(A, I0)', 'n      = ', stats%get_nr_values()
    print '(A, F10.3)', 'mean   = ', stats%get_mean()
    print '(A, F10.3)', 'stddev = ', stats%get_stddev()

    call stats%add_data(data_values)
    print '(A, I0)', 'n      = ', stats%get_nr_values()
    print '(A, F10.3)', 'mean   = ', stats%get_mean()
    print '(A, F10.3)', 'stddev = ', stats%get_stddev()

end program descriptive_statistics


      SUBROUTINE terint(ng,xg,yg,  n,x,y, c1,c2)
      IMPLICIT NONE

* SUBROUTINE to TERminate and INTerpolate a 1D input data array.
* INPUTS:
* working grid:

      INTEGER ng, ig
      REAL xg(ng)

* data array to be gridded:

      INTEGER n, i
      REAL x(n), y(n)

* multipliers for 4 y-values to be added:

      INTEGER c1, c2

* OUTPUT:
* gridded y-values, with proper termination at both ends

      REAL yg(ng)

* INTERNAL:
* input terminator points to be added:

      REAL xt1, yt1
      REAL xt2, yt2
      REAL xt3, yt3
      REAL xt4, yt4

* delta for adding points at beginning or end of data grids

      REAL deltax
      PARAMETER (deltax = 1.E-5)

* error flag:

      INTEGER ierr

* extended array:

      INTEGER n1, k1
      REAL x1(n+4), y1(n+4)

* check for valid input values of c1, c2:

      ierr = 0
      if(c1 .ne. 0 .and. c1 .ne. 1) ierr = 1
      if(c2 .ne. 0 .and. c2 .ne. 1) ierr = 1
      IF (ierr .NE. 0) THEN
         WRITE(*,*) ierr, 'entering terint.f'
         STOP
      ENDIF

* assign x-coordinate to 4 new points

      xt1 = -1.e36
      xt2 = x(1)*(1.-deltax)
      xt3 = x(n)*(1.+deltax)
      xt4 = 1.e36

* terminator multipliers  c1,c2 = e.g., = 1.,0.
* there are really only two practical options:  constant or zero

      yt1 = float(c1) * y(1)
      yt2 = float(c1) * y(1)

      yt3 = float(c2) * y(n)
      yt4 = float(c2) * y(n)

* transcribe input x,y array to avoid modifying it

      n1 = n
      do i = 1, n
         x1(i) = x(i)
         y1(i) = y(i)
      enddo

* extended data array, with up to 4 terminator points:
* note that n1 gets incremented by 1 for each call to ADDPNT

      k1 = n1 + 4
      call addpnt(x1,y1,k1,n1, xt1,yt1)
      call addpnt(x1,y1,k1,n1, xt2,yt2)
      call addpnt(x1,y1,k1,n1, xt3,yt3)
      call addpnt(x1,y1,k1,n1, xt4,yt4)

* point to grid interpolation:

      CALL inter2(ng,xg,yg, n1,x1,y1,ierr)
      IF (ierr .NE. 0) THEN
         WRITE(*,*) ierr, 'exiting terint.f'
         STOP
      ENDIF

      RETURN
      END


*DECK ZAIRY
      SUBROUTINE ZAIRY (ZR, ZI, ID, KODE, AIR, AII, NZ, IERR)
C***BEGIN PROLOGUE  ZAIRY
C***PURPOSE  Compute the Airy function Ai(z) or its derivative dAi/dz
C            for complex argument z.  A scaling option is available
C            to help avoid underflow and overflow.
C***LIBRARY   SLATEC
C***CATEGORY  C10D
C***TYPE      COMPLEX (CAIRY-C, ZAIRY-C)
C***KEYWORDS  AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD,
C             BESSEL FUNCTION OF ORDER TWO THIRDS
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C                      ***A DOUBLE PRECISION ROUTINE***
C         On KODE=1, ZAIRY computes the complex Airy function Ai(z)
C         or its derivative dAi/dz on ID=0 or ID=1 respectively. On
C         KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz
C         is provided to remove the exponential decay in -pi/3<arg(z)
C         <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where
C         zeta=(2/3)*z**(3/2).
C
C         While the Airy functions Ai(z) and dAi/dz are analytic in
C         the whole z-plane, the corresponding scaled functions defined
C         for KODE=2 have a cut along the negative real axis.
C
C         Input
C           ZR     - DOUBLE PRECISION real part of argument Z
C           ZI     - DOUBLE PRECISION imag part of argument Z
C           ID     - Order of derivative, ID=0 or ID=1
C           KODE   - A parameter to indicate the scaling option
C                    KODE=1  returns
C                            AI=Ai(z)  on ID=0
C                            AI=dAi/dz on ID=1
C                            at z=Z
C                        =2  returns
C                            AI=exp(zeta)*Ai(z)  on ID=0
C                            AI=exp(zeta)*dAi/dz on ID=1
C                            at z=Z where zeta=(2/3)*z**(3/2)
C
C         Output
C           AIR    - DOUBLE PRECISION real part of result
C           AII    - DOUBLE PRECISION imag part of result
C           NZ     - Underflow indicator
C                    NZ=0    Normal return
C                    NZ=1    AI=0 due to underflow in
C                            -pi/3<arg(Z)<pi/3 on KODE=1
C           IERR   - Error flag
C                    IERR=0  Normal return     - COMPUTATION COMPLETED
C                    IERR=1  Input error       - NO COMPUTATION
C                    IERR=2  Overflow          - NO COMPUTATION
C                            (Re(Z) too large with KODE=1)
C                    IERR=3  Precision warning - COMPUTATION COMPLETED
C                            (Result has less than half precision)
C                    IERR=4  Precision error   - NO COMPUTATION
C                            (Result has no precision)
C                    IERR=5  Algorithmic error - NO COMPUTATION
C                            (Termination condition not met)
C
C *Long Description:
C
C         Ai(z) and dAi/dz are computed from K Bessel functions by
C
C                Ai(z) =  c*sqrt(z)*K(1/3,zeta)
C               dAi/dz = -c*   z   *K(2/3,zeta)
C                    c =  1/(pi*sqrt(3))
C                 zeta =  (2/3)*z**(3/2)
C
C         when abs(z)>1 and from power series when abs(z)<=1.
C
C         In most complex variable computation, one must evaluate ele-
C         mentary functions.  When the magnitude of Z is large, losses
C         of significance by argument reduction occur.  Consequently, if
C         the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR),
C         then losses exceeding half precision are likely and an error
C         flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is
C         double precision unit roundoff limited to 18 digits precision.
C         Also, if the magnitude of ZETA is larger than U2=0.5/UR, then
C         all significance is lost and IERR=4.  In order to use the INT
C         function, ZETA must be further restricted not to exceed
C         U3=I1MACH(9)=LARGEST INTEGER.  Thus, the magnitude of ZETA
C         must be restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2,
C         and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single
C         precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision.
C         This makes U2 limiting is single precision and U3 limiting
C         in double precision.  This means that the magnitude of Z
C         cannot exceed approximately 3.4E+4 in single precision and
C         2.1E+6 in double precision.  This also means that one can
C         expect to retain, in the worst cases on 32-bit machines,
C         no digits in single precision and only 6 digits in double
C         precision.
C
C         The approximate relative error in the magnitude of a complex
C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
C         sents the increase in error due to argument reduction in the
C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
C         have only absolute accuracy.  This is most likely to occur
C         when one component (in magnitude) is larger than the other by
C         several orders of magnitude.  If one component is 10**K larger
C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
C         0) significant digits; or, stated another way, when K exceeds
C         the exponent of P, no significant digits remain in the smaller
C         component.  However, the phase angle retains absolute accuracy
C         because, in complex arithmetic with precision P, the smaller
C         component will not (as a rule) decrease below P times the
C         magnitude of the larger component. In these extreme cases,
C         the principal phase angle is on the order of +P, -P, PI/2-P,
C         or -PI/2+P.
C
C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
C                 matical Functions, National Bureau of Standards
C                 Applied Mathematics Series 55, U. S. Department
C                 of Commerce, Tenth Printing (1972) or later.
C               2. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument and Large Order, Report SAND83-0643,
C                 Sandia National Laboratories, Albuquerque, NM, May
C                 1983.
C               3. D. E. Amos, A Subroutine Package for Bessel Functions
C                 of a Complex Argument and Nonnegative Order, Report
C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
C                 NM, May 1985.
C               4. D. E. Amos, A portable package for Bessel functions
C                 of a complex argument and nonnegative order, ACM
C                 Transactions on Mathematical Software, 12 (September
C                 1986), pp. 265-273.
C
C***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZACAI, ZBKNU, ZEXP, ZSQRT
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   890801  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   920811  Prologue revised.  (DWL)
C   930122  Added ZEXP and ZSQRT to EXTERNAL statement.  (RWC)
C***END PROLOGUE  ZAIRY
C     COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
      DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK,
     * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG,
     * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR,
     * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI,
     * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB
      INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH
      DIMENSION CYR(1), CYI(1)
      EXTERNAL ZABS, ZEXP, ZSQRT
      DATA TTH, C1, C2, COEF /6.66666666666666667D-01,
     * 3.55028053887817240D-01,2.58819403792806799D-01,
     * 1.83776298473930683D-01/
      DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/
C***FIRST EXECUTABLE STATEMENT  ZAIRY
      IERR = 0
      NZ=0
      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (IERR.NE.0) RETURN
      AZ = ZABS(ZR,ZI)
      TOL = MAX(D1MACH(4),1.0D-18)
      FID = ID
      IF (AZ.GT.1.0D0) GO TO 70
C-----------------------------------------------------------------------
C     POWER SERIES FOR ABS(Z).LE.1.
C-----------------------------------------------------------------------
      S1R = CONER
      S1I = CONEI
      S2R = CONER
      S2I = CONEI
      IF (AZ.LT.TOL) GO TO 170
      AA = AZ*AZ
      IF (AA.LT.TOL/AZ) GO TO 40
      TRM1R = CONER
      TRM1I = CONEI
      TRM2R = CONER
      TRM2I = CONEI
      ATRM = 1.0D0
      STR = ZR*ZR - ZI*ZI
      STI = ZR*ZI + ZI*ZR
      Z3R = STR*ZR - STI*ZI
      Z3I = STR*ZI + STI*ZR
      AZ3 = AZ*AA
      AK = 2.0D0 + FID
      BK = 3.0D0 - FID - FID
      CK = 4.0D0 - FID
      DK = 3.0D0 + FID + FID
      D1 = AK*DK
      D2 = BK*CK
      AD = MIN(D1,D2)
      AK = 24.0D0 + 9.0D0*FID
      BK = 30.0D0 - 9.0D0*FID
      DO 30 K=1,25
        STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
        TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
        TRM1R = STR
        S1R = S1R + TRM1R
        S1I = S1I + TRM1I
        STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
        TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
        TRM2R = STR
        S2R = S2R + TRM2R
        S2I = S2I + TRM2I
        ATRM = ATRM*AZ3/AD
        D1 = D1 + AK
        D2 = D2 + BK
        AD = MIN(D1,D2)
        IF (ATRM.LT.TOL*AD) GO TO 40
        AK = AK + 18.0D0
        BK = BK + 18.0D0
   30 CONTINUE
   40 CONTINUE
      IF (ID.EQ.1) GO TO 50
      AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I)
      AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R)
      IF (KODE.EQ.1) RETURN
      CALL ZSQRT(ZR, ZI, STR, STI)
      ZTAR = TTH*(ZR*STR-ZI*STI)
      ZTAI = TTH*(ZR*STI+ZI*STR)
      CALL ZEXP(ZTAR, ZTAI, STR, STI)
      PTR = AIR*STR - AII*STI
      AII = AIR*STI + AII*STR
      AIR = PTR
      RETURN
   50 CONTINUE
      AIR = -S2R*C2
      AII = -S2I*C2
      IF (AZ.LE.TOL) GO TO 60
      STR = ZR*S1R - ZI*S1I
      STI = ZR*S1I + ZI*S1R
      CC = C1/(1.0D0+FID)
      AIR = AIR + CC*(STR*ZR-STI*ZI)
      AII = AII + CC*(STR*ZI+STI*ZR)
   60 CONTINUE
      IF (KODE.EQ.1) RETURN
      CALL ZSQRT(ZR, ZI, STR, STI)
      ZTAR = TTH*(ZR*STR-ZI*STI)
      ZTAI = TTH*(ZR*STI+ZI*STR)
      CALL ZEXP(ZTAR, ZTAI, STR, STI)
      PTR = STR*AIR - STI*AII
      AII = STR*AII + STI*AIR
      AIR = PTR
      RETURN
C-----------------------------------------------------------------------
C     CASE FOR ABS(Z).GT.1.0
C-----------------------------------------------------------------------
   70 CONTINUE
      FNU = (1.0D0+FID)/3.0D0
C-----------------------------------------------------------------------
C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18.
C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
C-----------------------------------------------------------------------
      K1 = I1MACH(15)
      K2 = I1MACH(16)
      R1M5 = D1MACH(5)
      K = MIN(ABS(K1),ABS(K2))
      ELIM = 2.303D0*(K*R1M5-3.0D0)
      K1 = I1MACH(14) - 1
      AA = R1M5*K1
      DIG = MIN(AA,18.0D0)
      AA = AA*2.303D0
      ALIM = ELIM + MAX(-AA,-41.45D0)
      RL = 1.2D0*DIG + 3.0D0
      ALAZ = LOG(AZ)
C-----------------------------------------------------------------------
C     TEST FOR PROPER RANGE
C-----------------------------------------------------------------------
      AA=0.5D0/TOL
      BB=I1MACH(9)*0.5D0
      AA=MIN(AA,BB)
      AA=AA**TTH
      IF (AZ.GT.AA) GO TO 260
      AA=SQRT(AA)
      IF (AZ.GT.AA) IERR=3
      CALL ZSQRT(ZR, ZI, CSQR, CSQI)
      ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
      ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
C-----------------------------------------------------------------------
C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
C-----------------------------------------------------------------------
      IFLAG = 0
      SFAC = 1.0D0
      AK = ZTAI
      IF (ZR.GE.0.0D0) GO TO 80
      BK = ZTAR
      CK = -ABS(BK)
      ZTAR = CK
      ZTAI = AK
   80 CONTINUE
      IF (ZI.NE.0.0D0) GO TO 90
      IF (ZR.GT.0.0D0) GO TO 90
      ZTAR = 0.0D0
      ZTAI = AK
   90 CONTINUE
      AA = ZTAR
      IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
      IF (KODE.EQ.2) GO TO 100
C-----------------------------------------------------------------------
C     OVERFLOW TEST
C-----------------------------------------------------------------------
      IF (AA.GT.(-ALIM)) GO TO 100
      AA = -AA + 0.25D0*ALAZ
      IFLAG = 1
      SFAC = TOL
      IF (AA.GT.ELIM) GO TO 270
  100 CONTINUE
C-----------------------------------------------------------------------
C     CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
C-----------------------------------------------------------------------
      MR = 1
      IF (ZI.LT.0.0D0) MR = -1
      CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL,
     * ELIM, ALIM)
      IF (NN.LT.0) GO TO 280
      NZ = NZ + NN
      GO TO 130
  110 CONTINUE
      IF (KODE.EQ.2) GO TO 120
C-----------------------------------------------------------------------
C     UNDERFLOW TEST
C-----------------------------------------------------------------------
      IF (AA.LT.ALIM) GO TO 120
      AA = -AA - 0.25D0*ALAZ
      IFLAG = 2
      SFAC = 1.0D0/TOL
      IF (AA.LT.(-ELIM)) GO TO 210
  120 CONTINUE
      CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM,
     * ALIM)
  130 CONTINUE
      S1R = CYR(1)*COEF
      S1I = CYI(1)*COEF
      IF (IFLAG.NE.0) GO TO 150
      IF (ID.EQ.1) GO TO 140
      AIR = CSQR*S1R - CSQI*S1I
      AII = CSQR*S1I + CSQI*S1R
      RETURN
  140 CONTINUE
      AIR = -(ZR*S1R-ZI*S1I)
      AII = -(ZR*S1I+ZI*S1R)
      RETURN
  150 CONTINUE
      S1R = S1R*SFAC
      S1I = S1I*SFAC
      IF (ID.EQ.1) GO TO 160
      STR = S1R*CSQR - S1I*CSQI
      S1I = S1R*CSQI + S1I*CSQR
      S1R = STR
      AIR = S1R/SFAC
      AII = S1I/SFAC
      RETURN
  160 CONTINUE
      STR = -(S1R*ZR-S1I*ZI)
      S1I = -(S1R*ZI+S1I*ZR)
      S1R = STR
      AIR = S1R/SFAC
      AII = S1I/SFAC
      RETURN
  170 CONTINUE
      AA = 1.0D+3*D1MACH(1)
      S1R = ZEROR
      S1I = ZEROI
      IF (ID.EQ.1) GO TO 190
      IF (AZ.LE.AA) GO TO 180
      S1R = C2*ZR
      S1I = C2*ZI
  180 CONTINUE
      AIR = C1 - S1R
      AII = -S1I
      RETURN
  190 CONTINUE
      AIR = -C2
      AII = 0.0D0
      AA = SQRT(AA)
      IF (AZ.LE.AA) GO TO 200
      S1R = 0.5D0*(ZR*ZR-ZI*ZI)
      S1I = ZR*ZI
  200 CONTINUE
      AIR = AIR + C1*S1R
      AII = AII + C1*S1I
      RETURN
  210 CONTINUE
      NZ = 1
      AIR = ZEROR
      AII = ZEROI
      RETURN
  270 CONTINUE
      NZ = 0
      IERR=2
      RETURN
  280 CONTINUE
      IF(NN.EQ.(-1)) GO TO 270
      NZ=0
      IERR=5
      RETURN
  260 CONTINUE
      IERR=4
      NZ=0
      RETURN
      END


!-------------------------------------------------------------------------------
!
!+  Program mkvlayer
!
!-------------------------------------------------------------------------------
program prg_mkvlayer
  !-----------------------------------------------------------------------------
  !
  !++ Description:
  !       This program makes grid systems based on the icosahedral grid
  !       configuration.
  !
  !++ Current Corresponding Author : H.Tomita
  !
  !++ History:
  !      Version   Date       Comment
  !      -----------------------------------------------------------------------
  !      0.00      04-02-17  Imported from igdc-4.34
  !      -----------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  !
  !++ Used modules ( shared )
  !
  !=============================================================================
  integer, parameter :: kdum=1
  integer, parameter :: fid=11
  integer :: num_of_layer = 10
  real(8) :: ztop = 1.0D+4
  character(256) :: outfname = 'outfile'
  character(256) :: infname = 'infile'
  character(16) :: layer_type = 'POWER'
  real(8) :: fact = 1.0D0

  namelist / mkvlayer_cnf / &
       num_of_layer,        & !--- number of layers
       ztop,                & !--- height of model top
       outfname,            & !--- output file name
       layer_type,          & !--- type of layer
       fact,                & !--- factor  if layer_type='POWER'
       infname                !--- input file name if layer_type='GIVEN'

  real(8),allocatable :: z_c(:)
  real(8),allocatable :: z_h(:)

  integer :: kmin
  integer :: kmax
  integer :: kall

  open(fid,file='mkvlayer.cnf',status='old',form='formatted')
  read(fid,nml=mkvlayer_cnf)
  close(fid)

  select case(trim(layer_type))
  case('POWER')
     call mk_layer_powerfunc(fact)
  case('GIVEN')
     call mk_layer_given(infname)
  end select
  !
  call output_layer(outfname)

  !=============================================================================
contains
  !-----------------------------------------------------------------------------
  subroutine mk_layer_powerfunc( fact )
    implicit none
    real(8) :: a
    integer :: k
    real(8),intent(in) :: fact

    kmin=kdum+1
    kmax=kdum+num_of_layer
    kall=kdum+num_of_layer+kdum
    allocate(z_c(kall))
    allocate(z_h(kall))
    !
    a = ztop/(dble(num_of_layer)**fact)
    !
    do k = kmin, kmax+1
       z_h(k) = a * (dble(k-kmin)**fact)
    enddo
    !
    z_h(kmin-1) = z_h(kmin) - ( z_h(kmin+1) - z_h(kmin) )
    !
    do k= kmin-1, kmax
       z_c(k) = z_h(k) + ( z_h(k+1) - z_h(k) )*0.5D0
    enddo
    z_c(kmax+1) = z_h(kmax+1) + ( z_h(kmax+1) - z_h(kmax) )*0.5D0
    !
  end subroutine mk_layer_powerfunc

  subroutine mk_layer_given( infname )
    implicit none
    character(len=*), intent(in) :: infname
    integer,parameter :: fid=10
    integer :: k
    !
    open(fid,file=trim(infname),status='old',form='formatted')
    read(fid,*) num_of_layer
    !
    kmin=kdum+1
    kmax=kdum+num_of_layer
    kall=kdum+num_of_layer+kdum
    allocate(z_c(kall))
    allocate(z_h(kall))
    !
    do k = kmin, kmax+1
       read(fid,*) z_h(k)
    enddo
    !
    z_h(kmin-1) = z_h(kmin) - ( z_h(kmin+1) - z_h(kmin) )
    !
    do k= kmin-1, kmax
       z_c(k) = z_h(k) + ( z_h(k+1) - z_h(k) )*0.5D0
    enddo
    z_c(kmax+1) = z_h(kmax+1) + ( z_h(kmax+1) - z_h(kmax) )*0.5D0
    !
    close(fid)
    !
  end subroutine mk_layer_given

  !-----------------------------------------------------------------------------
  subroutine output_layer( outfname )
    implicit none

    character(len=*), intent(in) :: outfname

    character(len=128) :: fname_all
    character(len=128) :: fname_def
    integer :: kall, kmin, kmax

    integer :: fid = 10
    integer :: k
    !---------------------------------------------------------------------------

    open( unit = fid,            &
          file = trim(outfname), &
          form = 'unformatted'   )
       write(fid) num_of_layer
       write(fid) z_c
       write(fid) z_h
    close(fid)

    kmin = kdum + 1
    kmax = kdum + num_of_layer
    kall = kdum + num_of_layer + kdum

    if ( kall > 100 ) then
       write(fname_all,'(A5,I3.3,A4)') 'ZSALL', kall,         '.txt'
       write(fname_def,'(A5,I3.3,A4)') 'ZSDEF', num_of_layer, '.txt'
    else
       write(fname_all,'(A5,I2.2,A4)') 'ZSALL', kall,         '.txt'
       write(fname_def,'(A5,I2.2,A4)') 'ZSDEF', num_of_layer, '.txt'
    endif

    open( unit = fid,             &
          file = trim(fname_all), &
          form = 'formatted'      )
       write(fid,'(I4)') kall
       do k = 1, kall
          write(fid,'(f12.3)') z_c(k)
       enddo
    close(fid)

    open( unit = fid,             &
          file = trim(fname_def), &
          form = 'formatted'      )
       write(fid,'(I4)') num_of_layer
       do k = kmin, kmax
          write(fid,'(f12.3)') z_c(k)
       enddo
    close(fid)

    return
  end subroutine output_layer

end program prg_mkvlayer
!-------------------------------------------------------------------------------


! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on the Laplacian.
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: var       => array of data
! ::: nd        => number of components in var array (should be 1)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_laplac_error(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                                  set,clear, &
                                  var,varl1,varl2,varl3,varh1,varh2,varh3, &
                                  lo,hi,nd,domlo,domhi, &
                                  delta,xlo,problo,time,level)
      use probdata_module
      use amrex_fort_module, only : rt => amrex_real
      implicit none

      integer          :: set, clear, nd, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: varl1,varl2,varl3,varh1,varh2,varh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: var(varl1:varh1,varl2:varh2,varl3:varh3)
      real(rt) :: delta(3), xlo(3), problo(3), time
      integer          :: i,j,k

      real(rt) ::  delu(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1,lo(3)-1:hi(3)+1,3)
      real(rt) :: delua(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1,lo(3)-1:hi(3)+1,3)
      real(rt) :: delu2(9), delu3(9), delu4(9)
      real(rt) :: num, denom, error

      ! This value is  taken from FLASH
      real(rt), parameter :: ctore=0.8
      real(rt), parameter:: epsil=0.02

      ! adapted from ref_marking.f90 in FLASH2.5

      ! d/dx
      do k=lo(3)-1,hi(3)+1
      do j=lo(2)-1,hi(2)+1
      do i=lo(1)-1,hi(1)+1
          delu(i,j,k,1) =     var(i+1,j,k)  -     var(i-1,j,k)
         delua(i,j,k,1) = abs(var(i+1,j,k)) + abs(var(i-1,j,k))
      end do
      end do
      end do

      ! d/dy
      do k=lo(3)-1,hi(3)+1
      do j=lo(2)-1,hi(2)+1
      do i=lo(1)-1,hi(1)+1
          delu(i,j,k,2) =     var(i,j+1,k)  -     var(i,j-1,k)
         delua(i,j,k,2) = abs(var(i,j+1,k)) + abs(var(i,j-1,k))
      end do
      end do
      end do

      ! d/dz
      do k=lo(3)-1,hi(3)+1
      do j=lo(2)-1,hi(2)+1
      do i=lo(1)-1,hi(1)+1
          delu(i,j,k,3) =     var(i,j,k+1)  -     var(i,j,k-1)
         delua(i,j,k,3) = abs(var(i,j,k+1)) + abs(var(i,j,k-1))
      end do
      end do
      end do

      do k = lo(3),hi(3)
      do j = lo(2),hi(2)
      do i = lo(1),hi(1)

         ! d/dxdx
          delu2(1) =     delu(i+1,j,k,1)  -     delu(i-1,j,k,1)
          delu3(1) = abs(delu(i+1,j,k,1)) + abs(delu(i-1,j,k,1))
          delu4(1) =    delua(i+1,j,k,1)  +    delua(i-1,j,k,1)

          ! d/dydx
          delu2(2) =     delu(i,j+1,k,1)  -     delu(i,j-1,k,1)
          delu3(2) = abs(delu(i,j+1,k,1)) + abs(delu(i,j-1,k,1))
          delu4(2) =    delua(i,j+1,k,1)  +    delua(i,j-1,k,1)

          ! d/dxdy
          delu2(3) =     delu(i+1,j,k,2)  -     delu(i-1,j,k,2)
          delu3(3) = abs(delu(i+1,j,k,2)) + abs(delu(i-1,j,k,2))
          delu4(3) =    delua(i+1,j,k,2)  +    delua(i-1,j,k,2)

          ! d/dydy
          delu2(4) =     delu(i,j+1,k,2)  -     delu(i,j-1,k,2)
          delu3(4) = abs(delu(i,j+1,k,2)) + abs(delu(i,j-1,k,2))
          delu4(4) =    delua(i,j+1,k,2)  +    delua(i,j-1,k,2)

          ! d/dzdx
          delu2(5) =     delu(i,j,k+1,1)  -     delu(i,j,k-1,1)
          delu3(5) = abs(delu(i,j,k+1,1)) + abs(delu(i,j,k-1,1))
          delu4(5) =    delua(i,j,k+1,1)  +    delua(i,j,k-1,1)

          ! d/dzdy
          delu2(6) =     delu(i,j,k+1,2)  -     delu(i,j,k-1,2)
          delu3(6) = abs(delu(i,j,k+1,2)) + abs(delu(i,j,k-1,2))
          delu4(6) =    delua(i,j,k+1,2)  +    delua(i,j,k-1,2)

          ! d/dxdz
          delu2(7) =     delu(i+1,j,k,3)  -     delu(i-1,j,k,3)
          delu3(7) = abs(delu(i+1,j,k,3)) + abs(delu(i-1,j,k,3))
          delu4(7) =    delua(i+1,j,k,3)  +    delua(i-1,j,k,3)

          ! d/dydz
          delu2(8) =     delu(i,j+1,k,3)  -     delu(i,j-1,k,3)
          delu3(8) = abs(delu(i,j+1,k,3)) + abs(delu(i,j-1,k,3))
          delu4(8) =    delua(i,j+1,k,3)  +    delua(i,j-1,k,3)

          ! d/dzdz
          delu2(9) =     delu(i,j,k+1,3)  -     delu(i,j,k-1,3)
          delu3(9) = abs(delu(i,j,k+1,3)) + abs(delu(i,j,k-1,3))
          delu4(9) =    delua(i,j,k+1,3)  +    delua(i,j,k-1,3)

         ! compute the error
         num   =  delu2(1)**2 + delu2(2)**2 + delu2(3)**2 + delu2(4)**2 &
                 +delu2(5)**2 + delu2(6)**2 + delu2(7)**2 + delu2(8)**2 &
                 +delu2(9)**2

         denom = (delu3(1) + (epsil*delu4(1)+1.d-99))**2 + &
                 (delu3(2) + (epsil*delu4(2)+1.d-99))**2 + &
                 (delu3(3) + (epsil*delu4(3)+1.d-99))**2 + &
                 (delu3(4) + (epsil*delu4(4)+1.d-99))**2 + &
                 (delu3(5) + (epsil*delu4(5)+1.d-99))**2 + &
                 (delu3(6) + (epsil*delu4(6)+1.d-99))**2 + &
                 (delu3(7) + (epsil*delu4(7)+1.d-99))**2 + &
                 (delu3(8) + (epsil*delu4(8)+1.d-99))**2 + &
                 (delu3(9) + (epsil*delu4(9)+1.d-99))**2

         error = sqrt(num/denom)

         if (error .gt. ctore) tag(i,j,k)=set

      end do
      end do
      end do

      end subroutine tag_laplac_error

! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on the density
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: den       => density array
! ::: nd        => number of components in den array (should be 1)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_denerror(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                              set,clear, &
                              den,denl1,denl2,denl3,denh1,denh2,denh3, &
                              lo,hi,nd,domlo,domhi, &
                              delta,xlo,problo,time,level)
      use probdata_module
      implicit none

      integer          :: set, clear, nd, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: denl1,denl2,denl3,denh1,denh2,denh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: den(denl1:denh1,denl2:denh2,denl3:denh3,nd)
      real(rt) :: delta(3), xlo(3), problo(3), time

      integer          :: i,j,k
      real(rt) :: ax,ay,az

!     Tag on regions of high density
      if (level .lt. max_denerr_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  if (den(i,j,k,1) .ge. denerr) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

!     Tag on regions of high density gradient
      if (level .lt. max_dengrad_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  ax = ABS(den(i+1,j,k,1) - den(i,j,k,1))
                  ay = ABS(den(i,j+1,k,1) - den(i,j,k,1))
                  az = ABS(den(i,j,k+1,1) - den(i,j,k,1))
                  ax = MAX(ax,ABS(den(i,j,k,1) - den(i-1,j,k,1)))
                  ay = MAX(ay,ABS(den(i,j,k,1) - den(i,j-1,k,1)))
                  az = MAX(az,ABS(den(i,j,k,1) - den(i,j,k-1,1)))
                  if ( MAX(ax,ay,az) .ge. dengrad) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

      end subroutine tag_denerror

! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on the temperature
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: temp      => temperature array
! ::: np        => number of components in temp array (should be 1)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------

      subroutine tag_temperror(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                               set,clear, &
                               temp,templ1,templ2,templ3,temph1, &
                               temph2,temph3, &
                               lo,hi,np,domlo,domhi, &
                               delta,xlo,problo,time,level)

      use probdata_module
      implicit none

      integer          :: set, clear, np, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: templ1,templ2,templ3,temph1,temph2,temph3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: temp(templ1:temph1,templ2:temph2, &
                            templ3:temph3,np)
      real(rt) :: delta(3), xlo(3), problo(3), time

      integer          :: i,j,k
      real(rt) :: ax,ay,az

!     Tag on regions of high temperature
      if (level .lt. max_temperr_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  if (temp(i,j,k,1) .ge. temperr) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

!     Tag on regions of high temperature gradient
      if (level .lt. max_tempgrad_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  ax = ABS(temp(i+1,j,k,1) - temp(i,j,k,1))
                  ay = ABS(temp(i,j+1,k,1) - temp(i,j,k,1))
                  az = ABS(temp(i,j,k+1,1) - temp(i,j,k,1))
                  ax = MAX(ax,ABS(temp(i,j,k,1) - temp(i-1,j,k,1)))
                  ay = MAX(ay,ABS(temp(i,j,k,1) - temp(i,j-1,k,1)))
                  az = MAX(az,ABS(temp(i,j,k,1) - temp(i,j,k-1,1)))
                  if ( MAX(ax,ay,az) .ge. tempgrad) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

      end subroutine tag_temperror

! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on the pressure
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: press     => pressure array
! ::: np        => number of components in press array (should be 1)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_presserror(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                                set,clear, &
                                press,pressl1,pressl2,pressl3,pressh1, &
                                pressh2,pressh3, &
                                lo,hi,np,domlo,domhi, &
                                delta,xlo,problo,time,level)

      use probdata_module
      implicit none

      integer          :: set, clear, np, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: pressl1,pressl2,pressl3,pressh1,pressh2,pressh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: press(pressl1:pressh1,pressl2:pressh2, &
                                pressl3:pressh3,np)
      real(rt) :: delta(3), xlo(3), problo(3), time

      integer          :: i,j,k
      real(rt) :: ax,ay,az

!     Tag on regions of high pressure
      if (level .lt. max_presserr_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  if (press(i,j,k,1) .ge. presserr) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

!     Tag on regions of high pressure gradient
      if (level .lt. max_pressgrad_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  ax = ABS(press(i+1,j,k,1) - press(i,j,k,1))
                  ay = ABS(press(i,j+1,k,1) - press(i,j,k,1))
                  az = ABS(press(i,j,k+1,1) - press(i,j,k,1))
                  ax = MAX(ax,ABS(press(i,j,k,1) - press(i-1,j,k,1)))
                  ay = MAX(ay,ABS(press(i,j,k,1) - press(i,j-1,k,1)))
                  az = MAX(az,ABS(press(i,j,k,1) - press(i,j,k-1,1)))
                  if ( MAX(ax,ay,az) .ge. pressgrad) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

      end subroutine tag_presserror

! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on the velocity
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: vel       => velocity array
! ::: nv        => number of components in vel array (should be 3)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_velerror(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                              set,clear, &
                              vel,vell1,vell2,vell3,velh1,velh2,velh3, &
                              lo,hi,nv,domlo,domhi, &
                              delta,xlo,problo,time,level)

      use probdata_module
      implicit none

      integer          :: set, clear, nv, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: vell1,vell2,vell3,velh1,velh2,velh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: vel(vell1:velh1,vell2:velh2,vell3:velh3,nv)
      real(rt) :: delta(3), xlo(3), problo(3), time

      integer          :: i,j,k
      real(rt) :: ax,ay,az

!     Tag on regions of high velocity gradient
      if (level .lt. max_velgrad_lev) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  ax = ABS(vel(i+1,j,k,1) - vel(i,j,k,1))
                  ay = ABS(vel(i,j+1,k,1) - vel(i,j,k,1))
                  az = ABS(vel(i,j,k+1,1) - vel(i,j,k,1))
                  ax = MAX(ax,ABS(vel(i,j,k,1) - vel(i-1,j,k,1)))
                  ay = MAX(ay,ABS(vel(i,j,k,1) - vel(i,j-1,k,1)))
                  az = MAX(az,ABS(vel(i,j,k,1) - vel(i,j,k-1,1)))
                  if ( MAX(ax,ay,az) .ge. velgrad) then
                     tag(i,j,k) = set
                  endif
               enddo
            enddo
         enddo
      endif

      end subroutine tag_velerror

! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on overdensity
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: den       => density array
! ::: nc        => number of components in density array
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_overdensity(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                                 set,clear, &
                                 den,denl1,denl2,denl3,denh1,denh2,denh3, &
                                 lo,hi,nc,domlo,domhi,delta,level,avg_den)

      use probdata_module
      implicit none

      integer          :: set, clear, nc, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: denl1,denl2,denl3,denh1,denh2,denh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: den(denl1:denh1,denl2:denh2,denl3:denh3,nc)
      real(rt) :: delta(3), avg_den

      integer          :: i,j,k
      real(rt) :: over_den

      over_den = 1.1d0 * avg_den

!     Tag on regions of overdensity
      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               if ( den(i,j,k,1) .gt. over_den ) then
                  tag(i,j,k) = set
               endif
            enddo
         enddo
      enddo

      end subroutine tag_overdensity

! ::: -----------------------------------------------------------
! ::: This routine will tag high error cells based on the number of particles.
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: var       => array of data
! ::: nd        => number of components in var array (should be 1)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_part_cnt_err(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                                  set,clear, &
                                  var,varl1,varl2,varl3,varh1,varh2,varh3, &
                                  lo,hi,nd,domlo,domhi, &
                                  delta,xlo,problo,time,level)
      use probdata_module
      implicit none

      integer          :: set, clear, nd, level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: varl1,varl2,varl3,varh1,varh2,varh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: var(varl1:varh1,varl2:varh2,varl3:varh3,nd)
      real(rt) :: delta(3), xlo(3), problo(3), time

      integer          :: ilo,jlo,klo,ihi,jhi,khi
      integer          :: i,j,k

      do k = lo(3),hi(3)
      do j = lo(2),hi(2)
      do i = lo(1),hi(1)
         if (var(i,j,k,1) .gt. max_num_part) then
            tag(i,j,k) = set
         end if
      end do
      end do
      end do

      end subroutine tag_part_cnt_err

! ::: -----------------------------------------------------------
! ::: This routine will tag a specific region.
! :::
! ::: INPUTS/OUTPUTS:
! :::
! ::: tag      <=  integer tag array
! ::: lo,hi     => index extent of tag array
! ::: set       => integer value to tag cell for refinement
! ::: clear     => integer value to untag cell
! ::: var       => array of data
! ::: nd        => number of components in var array (should be 1)
! ::: domlo,hi  => index extent of problem domain
! ::: delta     => cell spacing
! ::: xlo       => physical location of lower left hand
! :::              corner of tag array
! ::: problo    => phys loc of lower left corner of prob domain
! ::: time      => problem evolution time
! ::: level     => refinement level of this array
! ::: -----------------------------------------------------------
      subroutine tag_region(tag,tagl1,tagl2,tagl3,tagh1,tagh2,tagh3, &
                            set,lo,hi,domlo,domhi, &
                            delta,xlo,problo,level)

      use probdata_module
      implicit none

      integer          :: set,level
      integer          :: tagl1,tagl2,tagl3,tagh1,tagh2,tagh3
      integer          :: lo(3), hi(3), domlo(3), domhi(3)
      integer          :: tag(tagl1:tagh1,tagl2:tagh2,tagl3:tagh3)
      real(rt) :: delta(3), xlo(3), problo(3), time

      integer          :: ilo,jlo,klo,ihi,jhi,khi
      integer          :: i,j,k

      if (level .eq. 0) then
         ilo = (domhi(1)+1)*1/4
         ihi = (domhi(1)+1)*3/4 - 1
         jlo = (domhi(2)+1)*1/4
         jhi = (domhi(2)+1)*3/4 - 1
         klo = (domhi(3)+1)*1/4
         khi = (domhi(3)+1)*3/4 - 1
         do k = lo(3),hi(3)
         do j = lo(2),hi(2)
         do i = lo(1),hi(1)
            if (i.ge.ilo .and. i.le.ihi .and. &
                j.ge.jlo .and. j.le.jhi .and. &
                k.ge.klo .and. k.le.khi) then
               tag(i,j,k) = set
            end if
         end do
         end do
         end do
      else
         ilo = (domhi(1)+1)*3/8
         ihi = (domhi(1)+1)*5/8 - 1
         jlo = (domhi(2)+1)*3/8
         jhi = (domhi(2)+1)*5/8 - 1
         klo = (domhi(3)+1)*3/8
         khi = (domhi(3)+1)*5/8 - 1
         do k = lo(3),hi(3)
         do j = lo(2),hi(2)
         do i = lo(1),hi(1)
            if (i.ge.ilo .and. i.le.ihi .and. &
                j.ge.jlo .and. j.le.jhi .and. &
                k.ge.klo .and. k.le.khi) then
               tag(i,j,k) = set
            end if
         end do
         end do
         end do
      endif

      end subroutine tag_region