      SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
     $                   M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
     $                   IWORK, LIWORK, INFO )
      IMPLICIT NONE
*
*  -- LAPACK computational routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE
      LOGICAL            TRYRAC
      INTEGER            IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
      REAL               VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            ISUPPZ( * ), IWORK( * )
      REAL               D( * ), E( * ), W( * ), WORK( * )
      REAL               Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  SSTEMR computes selected eigenvalues and, optionally, eigenvectors
*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
*  a well defined set of pairwise different real eigenvalues, the corresponding
*  real eigenvectors are pairwise orthogonal.
*
*  The spectrum may be computed either completely or partially by specifying
*  either an interval (VL,VU] or a range of indices IL:IU for the desired
*  eigenvalues.
*
*  Depending on the number of desired eigenvalues, these are computed either
*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
*  computed by the use of various suitable L D L^T factorizations near clusters
*  of close eigenvalues (referred to as RRRs, Relatively Robust
*  Representations). An informal sketch of the algorithm follows.
*
*  For each unreduced block (submatrix) of T,
*     (a) Compute T - sigma I  = L D L^T, so that L and D
*         define all the wanted eigenvalues to high relative accuracy.
*         This means that small relative changes in the entries of D and L
*         cause only small relative changes in the eigenvalues and
*         eigenvectors. The standard (unfactored) representation of the
*         tridiagonal matrix T does not have this property in general.
*     (b) Compute the eigenvalues to suitable accuracy.
*         If the eigenvectors are desired, the algorithm attains full
*         accuracy of the computed eigenvalues only right before
*         the corresponding vectors have to be computed, see steps c) and d).
*     (c) For each cluster of close eigenvalues, select a new
*         shift close to the cluster, find a new factorization, and refine
*         the shifted eigenvalues to suitable accuracy.
*     (d) For each eigenvalue with a large enough relative separation compute
*         the corresponding eigenvector by forming a rank revealing twisted
*         factorization. Go back to (c) for any clusters that remain.
*
*  For more details, see:
*  - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
*  - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
*    Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
*    2004.  Also LAPACK Working Note 154.
*  - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
*    tridiagonal eigenvalue/eigenvector problem",
*    Computer Science Division Technical Report No. UCB/CSD-97-971,
*    UC Berkeley, May 1997.
*
*  Notes:
*  1.SSTEMR works only on machines which follow IEEE-754
*  floating-point standard in their handling of infinities and NaNs.
*  This permits the use of efficient inner loops avoiding a check for
*  zero divisors.
*
*  Arguments
*  =========
*
*  JOBZ    (input) CHARACTER*1
*          = 'N':  Compute eigenvalues only;
*          = 'V':  Compute eigenvalues and eigenvectors.
*
*  RANGE   (input) CHARACTER*1
*          = 'A': all eigenvalues will be found.
*          = 'V': all eigenvalues in the half-open interval (VL,VU]
*                 will be found.
*          = 'I': the IL-th through IU-th eigenvalues will be found.
*
*  N       (input) INTEGER
*          The order of the matrix.  N >= 0.
*
*  D       (input/output) REAL array, dimension (N)
*          On entry, the N diagonal elements of the tridiagonal matrix
*          T. On exit, D is overwritten.
*
*  E       (input/output) REAL array, dimension (N)
*          On entry, the (N-1) subdiagonal elements of the tridiagonal
*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
*          input, but is used internally as workspace.
*          On exit, E is overwritten.
*
*  VL      (input) REAL
*  VU      (input) REAL
*          If RANGE='V', the lower and upper bounds of the interval to
*          be searched for eigenvalues. VL < VU.
*          Not referenced if RANGE = 'A' or 'I'.
*
*  IL      (input) INTEGER
*  IU      (input) INTEGER
*          If RANGE='I', the indices (in ascending order) of the
*          smallest and largest eigenvalues to be returned.
*          1 <= IL <= IU <= N, if N > 0.
*          Not referenced if RANGE = 'A' or 'V'.
*
*  M       (output) INTEGER
*          The total number of eigenvalues found.  0 <= M <= N.
*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*
*  W       (output) REAL array, dimension (N)
*          The first M elements contain the selected eigenvalues in
*          ascending order.
*
*  Z       (output) REAL array, dimension (LDZ, max(1,M) )
*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
*          contain the orthonormal eigenvectors of the matrix T
*          corresponding to the selected eigenvalues, with the i-th
*          column of Z holding the eigenvector associated with W(i).
*          If JOBZ = 'N', then Z is not referenced.
*          Note: the user must ensure that at least max(1,M) columns are
*          supplied in the array Z; if RANGE = 'V', the exact value of M
*          is not known in advance and can be computed with a workspace
*          query by setting NZC = -1, see below.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  LDZ >= 1, and if
*          JOBZ = 'V', then LDZ >= max(1,N).
*
*  NZC     (input) INTEGER
*          The number of eigenvectors to be held in the array Z.
*          If RANGE = 'A', then NZC >= max(1,N).
*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
*          If RANGE = 'I', then NZC >= IU-IL+1.
*          If NZC = -1, then a workspace query is assumed; the
*          routine calculates the number of columns of the array Z that
*          are needed to hold the eigenvectors.
*          This value is returned as the first entry of the Z array, and
*          no error message related to NZC is issued by XERBLA.
*
*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
*          The support of the eigenvectors in Z, i.e., the indices
*          indicating the nonzero elements in Z. The i-th computed eigenvector
*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
*
*  TRYRAC  (input/output) LOGICAL
*          If TRYRAC.EQ..TRUE., indicates that the code should check whether
*          the tridiagonal matrix defines its eigenvalues to high relative
*          accuracy.  If so, the code uses relative-accuracy preserving
*          algorithms that might be (a bit) slower depending on the matrix.
*          If the matrix does not define its eigenvalues to high relative
*          accuracy, the code can uses possibly faster algorithms.
*          If TRYRAC.EQ..FALSE., the code is not required to guarantee
*          relatively accurate eigenvalues and can use the fastest possible
*          techniques.
*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
*          does not define its eigenvalues to high relative accuracy.
*
*  WORK    (workspace/output) REAL array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal
*          (and minimal) LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,18*N)
*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
*  LIWORK  (input) INTEGER
*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
*          if only the eigenvalues are to be computed.
*          If LIWORK = -1, then a workspace query is assumed; the
*          routine only calculates the optimal size of the IWORK array,
*          returns this value as the first entry of the IWORK array, and
*          no error message related to LIWORK is issued by XERBLA.
*
*  INFO    (output) INTEGER
*          On exit, INFO
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = 1X, internal error in SLARRE,
*                if INFO = 2X, internal error in SLARRV.
*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
*                the nonzero error code returned by SLARRE or
*                SLARRV, respectively.
*
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Beresford Parlett, University of California, Berkeley, USA
*     Jim Demmel, University of California, Berkeley, USA
*     Inderjit Dhillon, University of Texas, Austin, USA
*     Osni Marques, LBNL/NERSC, USA
*     Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, FOUR, MINRGP
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
     $                     FOUR = 4.0E0,
     $                     MINRGP = 3.0E-3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
      INTEGER            I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
     $                   IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
     $                   INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
     $                   ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
     $                   NZCMIN, OFFSET, WBEGIN, WEND
      REAL               BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
     $                   RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
     $                   THRESH, TMP, TNRM, WL, WU
*     ..
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH, SLANST
      EXTERNAL           LSAME, SLAMCH, SLANST
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLAE2, SLAEV2, SLARRC, SLARRE, SLARRJ,
     $                   SLARRR, SLARRV, SLASRT, SSCAL, SSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
*
      LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
      ZQUERY = ( NZC.EQ.-1 )

*     SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
*     In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
*     Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
      IF( WANTZ ) THEN
         LWMIN = 18*N
         LIWMIN = 10*N
      ELSE
*        need less workspace if only the eigenvalues are wanted
         LWMIN = 12*N
         LIWMIN = 8*N
      ENDIF

      WL = ZERO
      WU = ZERO
      IIL = 0
      IIU = 0

      IF( VALEIG ) THEN
*        We do not reference VL, VU in the cases RANGE = 'I','A'
*        The interval (WL, WU] contains all the wanted eigenvalues.
*        It is either given by the user or computed in SLARRE.
         WL = VL
         WU = VU
      ELSEIF( INDEIG ) THEN
*        We do not reference IL, IU in the cases RANGE = 'V','A'
         IIL = IL
         IIU = IU
      ENDIF
*
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
         INFO = -7
      ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
         INFO = -8
      ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
         INFO = -9
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -17
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -19
      END IF
*
*     Get machine constants.
*
      SAFMIN = SLAMCH( 'Safe minimum' )
      EPS = SLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
*
         IF( WANTZ .AND. ALLEIG ) THEN
            NZCMIN = N
         ELSE IF( WANTZ .AND. VALEIG ) THEN
            CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
     $                            NZCMIN, ITMP, ITMP2, INFO )
         ELSE IF( WANTZ .AND. INDEIG ) THEN
            NZCMIN = IIU-IIL+1
         ELSE
*           WANTZ .EQ. FALSE.
            NZCMIN = 0
         ENDIF
         IF( ZQUERY .AND. INFO.EQ.0 ) THEN
            Z( 1,1 ) = NZCMIN
         ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
            INFO = -14
         END IF
      END IF

      IF( INFO.NE.0 ) THEN
*
         CALL XERBLA( 'SSTEMR', -INFO )
*
         RETURN
      ELSE IF( LQUERY .OR. ZQUERY ) THEN
         RETURN
      END IF
*
*     Handle N = 0, 1, and 2 cases immediately
*
      M = 0
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = D( 1 )
         ELSE
            IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
               M = 1
               W( 1 ) = D( 1 )
            END IF
         END IF
         IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
            Z( 1, 1 ) = ONE
            ISUPPZ(1) = 1
            ISUPPZ(2) = 1
         END IF
         RETURN
      END IF
*
      IF( N.EQ.2 ) THEN
         IF( .NOT.WANTZ ) THEN
            CALL SLAE2( D(1), E(1), D(2), R1, R2 )
         ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
            CALL SLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
         END IF
         IF( ALLEIG.OR.
     $      (VALEIG.AND.(R2.GT.WL).AND.
     $                  (R2.LE.WU)).OR.
     $      (INDEIG.AND.(IIL.EQ.1)) ) THEN
            M = M+1
            W( M ) = R2
            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
               Z( 1, M ) = -SN
               Z( 2, M ) = CS
*              Note: At most one of SN and CS can be zero.
               IF (SN.NE.ZERO) THEN
                  IF (CS.NE.ZERO) THEN
                     ISUPPZ(2*M-1) = 1
                     ISUPPZ(2*M-1) = 2
                  ELSE
                     ISUPPZ(2*M-1) = 1
                     ISUPPZ(2*M-1) = 1
                  END IF
               ELSE
                  ISUPPZ(2*M-1) = 2
                  ISUPPZ(2*M) = 2
               END IF
            ENDIF
         ENDIF
         IF( ALLEIG.OR.
     $      (VALEIG.AND.(R1.GT.WL).AND.
     $                  (R1.LE.WU)).OR.
     $      (INDEIG.AND.(IIU.EQ.2)) ) THEN
            M = M+1
            W( M ) = R1
            IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
               Z( 1, M ) = CS
               Z( 2, M ) = SN
*              Note: At most one of SN and CS can be zero.
               IF (SN.NE.ZERO) THEN
                  IF (CS.NE.ZERO) THEN
                     ISUPPZ(2*M-1) = 1
                     ISUPPZ(2*M-1) = 2
                  ELSE
                     ISUPPZ(2*M-1) = 1
                     ISUPPZ(2*M-1) = 1
                  END IF
               ELSE
                  ISUPPZ(2*M-1) = 2
                  ISUPPZ(2*M) = 2
               END IF
            ENDIF
         ENDIF
         RETURN
      END IF

*     Continue with general N

      INDGRS = 1
      INDERR = 2*N + 1
      INDGP = 3*N + 1
      INDD = 4*N + 1
      INDE2 = 5*N + 1
      INDWRK = 6*N + 1
*
      IINSPL = 1
      IINDBL = N + 1
      IINDW = 2*N + 1
      IINDWK = 3*N + 1
*
*     Scale matrix to allowable range, if necessary.
*     The allowable range is related to the PIVMIN parameter; see the
*     comments in SLARRD.  The preference for scaling small values
*     up is heuristic; we expect users' matrices not to be close to the
*     RMAX threshold.
*
      SCALE = ONE
      TNRM = SLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         SCALE = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         SCALE = RMAX / TNRM
      END IF
      IF( SCALE.NE.ONE ) THEN
         CALL SSCAL( N, SCALE, D, 1 )
         CALL SSCAL( N-1, SCALE, E, 1 )
         TNRM = TNRM*SCALE
         IF( VALEIG ) THEN
*           If eigenvalues in interval have to be found,
*           scale (WL, WU] accordingly
            WL = WL*SCALE
            WU = WU*SCALE
         ENDIF
      END IF
*
*     Compute the desired eigenvalues of the tridiagonal after splitting
*     into smaller subblocks if the corresponding off-diagonal elements
*     are small
*     THRESH is the splitting parameter for SLARRE
*     A negative THRESH forces the old splitting criterion based on the
*     size of the off-diagonal. A positive THRESH switches to splitting
*     which preserves relative accuracy.
*
      IF( TRYRAC ) THEN
*        Test whether the matrix warrants the more expensive relative approach.
         CALL SLARRR( N, D, E, IINFO )
      ELSE
*        The user does not care about relative accurately eigenvalues
         IINFO = -1
      ENDIF
*     Set the splitting criterion
      IF (IINFO.EQ.0) THEN
         THRESH = EPS
      ELSE
         THRESH = -EPS
*        relative accuracy is desired but T does not guarantee it
         TRYRAC = .FALSE.
      ENDIF
*
      IF( TRYRAC ) THEN
*        Copy original diagonal, needed to guarantee relative accuracy
         CALL SCOPY(N,D,1,WORK(INDD),1)
      ENDIF
*     Store the squares of the offdiagonal values of T
      DO 5 J = 1, N-1
         WORK( INDE2+J-1 ) = E(J)**2
 5    CONTINUE

*     Set the tolerance parameters for bisection
      IF( .NOT.WANTZ ) THEN
*        SLARRE computes the eigenvalues to full precision.
         RTOL1 = FOUR * EPS
         RTOL2 = FOUR * EPS
      ELSE
*        SLARRE computes the eigenvalues to less than full precision.
*        SLARRV will refine the eigenvalue approximations, and we can
*        need less accurate initial bisection in SLARRE.
*        Note: these settings do only affect the subset case and SLARRE
         RTOL1 = MAX( SQRT(EPS)*5.0E-2, FOUR * EPS )
         RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
      ENDIF
      CALL SLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
     $             WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
     $             IWORK( IINSPL ), M, W, WORK( INDERR ),
     $             WORK( INDGP ), IWORK( IINDBL ),
     $             IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
     $             WORK( INDWRK ), IWORK( IINDWK ), IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = 10 + ABS( IINFO )
         RETURN
      END IF
*     Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired
*     part of the spectrum. All desired eigenvalues are contained in
*     (WL,WU]

      IF( WANTZ ) THEN
*
*        Compute the desired eigenvectors corresponding to the computed
*        eigenvalues
*
         CALL SLARRV( N, WL, WU, D, E,
     $                PIVMIN, IWORK( IINSPL ), M,
     $                1, M, MINRGP, RTOL1, RTOL2,
     $                W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
     $                IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
     $                ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = 20 + ABS( IINFO )
            RETURN
         END IF
      ELSE
*        SLARRE computes eigenvalues of the (shifted) root representation
*        SLARRV returns the eigenvalues of the unshifted matrix.
*        However, if the eigenvectors are not desired by the user, we need
*        to apply the corresponding shifts from SLARRE to obtain the
*        eigenvalues of the original matrix.
         DO 20 J = 1, M
            ITMP = IWORK( IINDBL+J-1 )
            W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
 20      CONTINUE
      END IF
*

      IF ( TRYRAC ) THEN
*        Refine computed eigenvalues so that they are relatively accurate
*        with respect to the original matrix T.
         IBEGIN = 1
         WBEGIN = 1
         DO 39  JBLK = 1, IWORK( IINDBL+M-1 )
            IEND = IWORK( IINSPL+JBLK-1 )
            IN = IEND - IBEGIN + 1
            WEND = WBEGIN - 1
*           check if any eigenvalues have to be refined in this block
 36         CONTINUE
            IF( WEND.LT.M ) THEN
               IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
                  WEND = WEND + 1
                  GO TO 36
               END IF
            END IF
            IF( WEND.LT.WBEGIN ) THEN
               IBEGIN = IEND + 1
               GO TO 39
            END IF

            OFFSET = IWORK(IINDW+WBEGIN-1)-1
            IFIRST = IWORK(IINDW+WBEGIN-1)
            ILAST = IWORK(IINDW+WEND-1)
            RTOL2 = FOUR * EPS
            CALL SLARRJ( IN,
     $                   WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
     $                   IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
     $                   WORK( INDERR+WBEGIN-1 ),
     $                   WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
     $                   TNRM, IINFO )
            IBEGIN = IEND + 1
            WBEGIN = WEND + 1
 39      CONTINUE
      ENDIF
*
*     If matrix was scaled, then rescale eigenvalues appropriately.
*
      IF( SCALE.NE.ONE ) THEN
         CALL SSCAL( M, ONE / SCALE, W, 1 )
      END IF
*
*     If eigenvalues are not in increasing order, then sort them,
*     possibly along with eigenvectors.
*
      IF( NSPLIT.GT.1 ) THEN
         IF( .NOT. WANTZ ) THEN
            CALL SLASRT( 'I', M, W, IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = 3
               RETURN
            END IF
         ELSE
            DO 60 J = 1, M - 1
               I = 0
               TMP = W( J )
               DO 50 JJ = J + 1, M
                  IF( W( JJ ).LT.TMP ) THEN
                     I = JJ
                     TMP = W( JJ )
                  END IF
 50            CONTINUE
               IF( I.NE.0 ) THEN
                  W( I ) = W( J )
                  W( J ) = TMP
                  IF( WANTZ ) THEN
                     CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
                     ITMP = ISUPPZ( 2*I-1 )
                     ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
                     ISUPPZ( 2*J-1 ) = ITMP
                     ITMP = ISUPPZ( 2*I )
                     ISUPPZ( 2*I ) = ISUPPZ( 2*J )
                     ISUPPZ( 2*J ) = ITMP
                  END IF
               END IF
 60         CONTINUE
         END IF
      ENDIF
*
*
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
      RETURN
*
*     End of SSTEMR
*
      END


SUBROUTINE rhsLinearFreeSurface3D(t,Wavefield,g,rhsE,rhsP,Nx,Ny)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx,Ny
REAL(KIND=long) :: g,t
REAL(KIND=long), DIMENSION(Nx,Ny) :: rhsE, rhsP
TYPE(Wavefield_FS) :: Wavefield
rhsE = Wavefield%W  + Wavefield%NuD                  ! kinematic FS BC
rhsP = -g*Wavefield%E  + Wavefield%P0 + Wavefield%Pd ! dynamic FS BC!
END SUBROUTINE rhsLinearFreeSurface3D


!****************************************************************
		SUBROUTINE OUTFLOW_GENERATION (jyear,outflow)
!****************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER*4 i, jyear,month_dayGY(12),month_dayLY(12)
		INTEGER*4 mm
      REAL*8  outc0(12), outc1(12), outc2(12), outc3(12), outc4(12),outc5(12),outc6(12)
      DATA outc0 /0.48850890,	0.67038833,	-1.78254659, -9.91305770,		&
     	        18.68839430, 41.97161437, -79.78086257, -2.65473673,		&
                 -0.28068178, 0.07800260, 0.41632799, 0.03710574/
      DATA outc1 / -19.91314681, -16.44276584, 46.13779421, 				&
                  135.66231986, -151.69521495, -154.01720169,				&
     					670.02469551, 12.66268100, 2.41077130, 					&
     					1.74534042, -14.41101419, -2.03481617/
      DATA outc2 / 257.37617322, 189.19304570, -220.87224670, 				&
     	            -563.48475786, 537.38949119, 125.54713378,				&
     					-1939.35377097, 165.26401408, 119.40649977,				&
     					58.18407796, 239.32937995, 91.01077287/
		DATA outc3 /-820.74959840, -537.82390316, 447.03501042,				&
     	            1095.24074040, -944.19140687, 144.11043931, 				&
     					2788.57752873, -480.78457574, -296.03949344,				&
     					-87.20104981, -657.07671015, -297.65892923/
		DATA outc4 /1103.46338153,	673.24294825, -407.37844560,				&
     	           -1060.09754120, 868.63085552, -242.31669797,				&
     					-2126.93874766, 514.25019820, 302.39066969,				&
     					12.80370314, 714.98342347, 482.21275704/
		DATA outc5 /-655.31188802, -387.96818365, 162.21333510,				&
     	             495.67080236, -398.31578543, 105.99405037,				&
     					823.92342801, -243.19533558, -149.47773131,				&
     					42.27041859, -319.17519546, -367.62048719/
		DATA outc6 / 140.90158130, 83.63136061, -21.52157142, 				&
     	             -89.32021004, 71.55392858, -13.65427103,					&
     					-127.60858061, 42.74850838, 29.65395945, 					&
     				 -20.15674591, 41.87418111, 102.92076911/
      DATA month_dayGY /31, 59, 90, 120, 151, 181, 212, 243, 273, 304,334, 365/
      DATA month_dayLY /31, 60, 91, 121, 152, 182, 213, 244, 274, 305,335, 366/

		REAL*8 lake_rim, rim2WS, outflow
		PARAMETER (lake_rim = 1896.77)

      mm=1
      IF(mod(jyear,4).eq.0) THEN
			DO i= 1, 11
				IF(jday.gt.month_dayLY(mm)) THEN
					mm=mm+1
				ELSE
					GOTO 1
				ENDIF
			ENDDO
		ELSE
			DO i= 1, 11
				IF(jday.gt.month_dayGY(mm)) THEN
					mm=mm+1
				ELSE
					GOTO 1
				ENDIF
			ENDDO
		ENDIF
  1	CONTINUE
    	rim2WS=depth(ns)-OLEV(1)
		IF(rim2WS.LE.0.0)THEN
			outflow=0.0
		ELSE
			outflow=outc0(mm)+outc1(mm)*rim2WS+outc2(mm)*rim2WS**2+	&
     		        outc3(mm)*rim2WS**3+outc4(mm)*rim2WS**4+			&
     				  outc5(mm)*rim2WS**5+outc6(mm)*rim2WS**6
			IF(outflow.le.0.0) outflow =0.0
		ENDIF

!------Above outflow is m3/s-----------------
!------DLM needs 10^3 m3/d--------------
       outflow=outflow*86400.0/1000.0
!      print*, jday,outflow, rim2WS, depth(ns)

		RETURN
		END SUBROUTINE OUTFLOW_GENERATION


      SUBROUTINE MB03KC( K, KHESS, N, R, S, A, LDA, V, TAU )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a 2-by-2 general, formal matrix product A of length K,
C
C        A_K^s(K) * A_K-1^s(K-1) * ... * A_1^s(1),
C
C     to the periodic Hessenberg-triangular form using a K-periodic
C     sequence of elementary reflectors (Householder matrices). The
C     matrices A_k, k = 1, ..., K, are stored in the N-by-N-by-K array A
C     starting in the R-th row and column, and N can be 3 or 4.
C
C     Each elementary reflector H_k is represented as
C
C        H_k = I - tau_k * v_k * v_k',                               (1)
C
C     where I is the 2-by-2 identity, tau_k is a real scalar, and v_k is
C     a vector of length 2, k = 1,...,K, and it is constructed such that
C     the following holds for k = 1,...,K:
C
C            H_{k+1} * A_k * H_k = T_k, if s(k) = 1,
C                                                                    (2)
C            H_k * A_k * H_{k+1} = T_k, if s(k) = -1,
C
C     with H_{K+1} = H_1 and all T_k upper triangular except for
C     T_{khess} which is full. Clearly,
C
C        T_K^s(K) *...* T_1^s(1) = H_1 * A_K^s(K) *...* A_1^s(1) * H_1.
C
C     The reflectors are suitably applied to the whole, extended N-by-N
C     matrices Ae_k, not only to the submatrices A_k, k = 1, ..., K.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The number of matrices in the sequence A_k.  K >= 2.
C
C     KHESS   (input) INTEGER
C             The index for which the returned matrix A_khess should be
C             in the Hessenberg form on output.  1 <= KHESS <= K.
C
C     N       (input) INTEGER
C             The order of the extended matrices.  N = 3 or N = 4.
C
C     R       (input) INTEGER
C             The starting row and column index for the
C             2-by-2 submatrices.  R = 1, or R = N-1.
C
C     S       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures of the factors. Each entry in S must be either
C             1 or -1; the value S(k) = -1 corresponds to using the
C             inverse of the factor A_k.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXA(k) =
C             (k-1)*N*LDA+1 the N-by-N matrix Ae_k stored with leading
C             dimension LDA.
C             On exit, this array contains at position IXA(k) the
C             N-by-N matrix Te_k stored with leading dimension LDA.
C
C     LDA     INTEGER
C             Leading dimension of the matrices Ae_k and Te_k in the
C             one-dimensional array A.  LDA >= N.
C
C     V       (output) DOUBLE PRECISION array, dimension (2*K)
C             On exit, this array contains the K vectors v_k,
C             k = 1,...,K, defining the elementary reflectors H_k as
C             in (1). The k-th reflector is stored in V(2*k-1:2*k).
C
C     TAU     (output) DOUBLE PRECISION array, dimension (K)
C             On exit, this array contains the K values of tau_k,
C             k = 1,...,K, defining the elementary reflectors H_k
C             as in (1).
C
C     METHOD
C
C     A K-periodic sequence of elementary reflectors (Householder
C     matrices) is used. The computations start for k = khess with the
C     left reflector in (1), which is the identity matrix.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Mar. 2010, an essentially new version of the PEP routine
C     PEP_DGEHR2, by R. Granat, Umea University, Sweden, Apr. 2008.
C
C     REVISIONS
C
C     V. Sima, Apr. 2010, May 2010.
C
C     KEYWORDS
C
C     Orthogonal transformation, periodic QZ algorithm, QZ algorithm.
C
C     ******************************************************************
C
C  .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            K, KHESS, LDA, N, R
C     ..
C     .. Array Arguments ..
      INTEGER            S( * )
      DOUBLE PRECISION   A( * ), TAU( * ), V( * )
C  ..
C  .. Local Scalars ..
      INTEGER            I, I1, I2, IC, INC, IP1, IR, IX, NO
C  ..
C  .. Local Arrays ..
      DOUBLE PRECISION   TMP( 1 ), WORK( 2 )
C  ..
C  .. External Subroutines ..
      EXTERNAL           DLARFG, DLARFX
C  ..
C     .. Intrinsic Functions ..
      INTRINSIC          MOD
C  ..
C  .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
C     Compute the periodic Hessenberg form of A with the Hessenberg
C     matrix at position KHESS - start construction from I = KHESS,
C     i.e., to the left of (and including) the Hessenberg matrix in the
C     corresponding matrix product.
C
C     Since the problem is 2-by-2, the orthogonal matrix working on
C     A_{khess} from the left, if s(khess) = 1, or from the right,
C     if s(khess) = -1, hence H_{khess+1}, will be the identity.
C
      IR  = ( R - 1 )*LDA
      IC  = IR + R - 1
      NO  = N - R
      INC = N*LDA
      I1  = KHESS*INC + 1
      IP1 = MOD( KHESS, K ) + 1
C
      TAU( IP1   ) = ZERO
      V( 2*IP1-1 ) = ZERO
      V( 2*IP1   ) = ZERO
C
      DO 10 I = KHESS + 1, K
         IP1 = MOD( I, K )
         IX  = I1 + IC
         I2  = IP1*INC + 1
         IP1 = IP1 + 1
C
C        Compute and apply the reflector H_{i+1} working on A_i^s(i)
C        from the left.
C
         IF( S( I ).EQ.1 ) THEN
            WORK( 1 ) = ONE
            WORK( 2 ) = A( IX+1 )
            CALL DLARFG( 2, A( IX ), WORK( 2 ), 1, TAU( IP1 ) )
            V( 2*IP1-1 ) = ONE
            V( 2*IP1   ) = WORK( 2 )
            CALL DLARFX( 'Left', 2, NO, WORK, TAU( IP1 ), A( IX+LDA ),
     $                   LDA, TMP )
         ELSE
            WORK( 1 ) = A( IX+1 )
            WORK( 2 ) = ONE
            CALL DLARFG( 2, A( IX+LDA+1 ), WORK, 1, TAU( IP1 ) )
            V( 2*IP1-1 ) = WORK( 1 )
            V( 2*IP1   ) = ONE
            CALL DLARFX( 'Right', R, 2, WORK, TAU( IP1 ), A( I1+IR ),
     $                   LDA, TMP )
         END IF
         A( IX+1 ) = ZERO
C
C        Apply the reflector to A_{mod(i,K)+1}.
C
         IF( S( IP1 ).EQ.1 ) THEN
            CALL DLARFX( 'Right', R+1, 2, WORK, TAU( IP1 ), A( I2+IR ),
     $                   LDA, TMP )
         ELSE
            CALL DLARFX( 'Left', 2, NO+1, WORK, TAU( IP1 ), A( I2+IC ),
     $                   LDA, TMP )
         END IF
         I1 = I1 + INC
   10 CONTINUE
C
C     Continue to the right of the Hessenberg matrix.
C
      I1 = 1
C
      DO 20 I = 1, KHESS - 1
         IP1 = MOD( I, K )
         IX  = I1 + IC
         I2  = IP1*INC + 1
         IP1 = IP1 + 1
C
C        Compute and apply the reflector H_{i+1} working on A_i^s(i)
C        from the left.
C
         IF( S( I ).EQ.1 ) THEN
            WORK( 1 ) = ONE
            WORK( 2 ) = A( IX+1 )
            CALL DLARFG( 2, A( IX ), WORK( 2 ), 1, TAU( IP1 ) )
            V( 2*IP1-1 ) = ONE
            V( 2*IP1   ) = WORK( 2 )
            CALL DLARFX( 'Left', 2, NO, WORK, TAU( IP1 ), A( IX+LDA ),
     $                   LDA, TMP )
         ELSE
            WORK( 1 ) = A( IX+1 )
            WORK( 2 ) = ONE
            CALL DLARFG( 2, A( IX+LDA+1 ), WORK, 1, TAU( IP1 ) )
            V( 2*IP1-1 ) = WORK( 1 )
            V( 2*IP1   ) = ONE
            CALL DLARFX( 'Right', R, 2, WORK, TAU( IP1 ), A( I1+IR ),
     $                   LDA, TMP )
         END IF
         A( IX+1 ) = ZERO
C
C        Apply the reflector to A_{mod(i,K)+1}.
C
         IF( S( IP1 ).EQ.1 ) THEN
            CALL DLARFX( 'Right', R+1, 2, WORK, TAU( IP1 ), A( I2+IR ),
     $                   LDA, TMP )
         ELSE
            CALL DLARFX( 'Left', 2, NO+1, WORK, TAU( IP1 ), A( I2+IC ),
     $                   LDA, TMP )
         END IF
         I1 = I1 + INC
   20 CONTINUE
C
C     The periodic Hessenberg-triangular form has been computed.
C
      RETURN
C
C *** Last line of MB03KC ***
      END


module pmmf_hpaf_case2
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  hpaf_case2 mesh motion.
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: hpaf_case2_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type hpaf_case2_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(hpaf_case2_pmmf),  intent(inout)  :: self

        !
        ! Set function name
        !
        call self%set_name("hpaf_case2")

        !
        ! Set function options to default settings
        !
        !call self%add_option('option_name',option_val_rk)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(hpaf_case2_pmmf),     intent(inout)  :: self
        real(rk),                       intent(in)  :: time
        real(rk),                  intent(in)  :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                    :: val(3)

        real(rk)                                    :: b1, b2, b3, &
                                                        A2, A3, x0, y0, x_ale, y_ale, &
                                                        xc, yc, height, theta

        b1 = time**TWO*(time**TWO-4._rk*time+4._rk)
        b2 = time**TWO*(3._rk-time)/4._rk
        b3 = time**THREE*(-8._rk*time**THREE+51._rk*time**TWO-111._rk*time+84._rk)/16._rk

!        !Case 1
!        height = b2
!        theta = ZERO

        !Case 2
        if (time <= TWO) height = b2
        if (time >  TWO) height = ONE
        A2 = (60._rk*PI/180._rk)

        if (time <= TWO) theta = A2*b1
        if (time >  TWO) theta = ZERO

!
!        !Case 3
!        height = b3
!        A3 = (80._rk*PI/180._rk)
!        theta = A3*b1

        !Center of motion nodeinates
        xc = 1._rk/3._rk
        yc = 0._rk

        !Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        !Rotate about the center of motion
        x_ale =  cos(theta)*(x0-xc)+sin(theta)*(y0-yc) + xc
        y_ale = -sin(theta)*(x0-xc)+cos(theta)*(y0-yc) + yc

        !Translate vertically
        y_ale = y_ale + height

        val(1) = x_ale
        val(2) = y_ale
        val(3) = node(3)

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(hpaf_case2_pmmf),     intent(inout)  :: self
        real(rk),                       intent(in)  :: time
        real(rk),                  intent(in)  :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                   :: val(3)
        real(rk)                                    :: b1, b2, b3, db1dt, db2dt, db3dt, &
                                                        A2, A3, x0, y0, x_ale, y_ale, &
                                                        xc, yc, height, theta, dheightdt, dthetadt

        b1 = time**TWO*(time**TWO-4._rk*time+4._rk)
        b2 = time**TWO*(3._rk-time)/4._rk
        b3 = time**THREE*(-8._rk*time**THREE+51._rk*time**TWO-111._rk*time+84._rk)/16._rk

        db1dt = TWO*time*(time**TWO-4._rk*time+4._rk) + &
                time**TWO*(TWO*time-4._rk)
        db2dt = TWO*time*(3._rk-time)/4._rk + &
                time**TWO*(-1._rk)/4._rk
        db3dt = THREE*time**TWO*(-8._rk*time**THREE+51._rk*time**TWO-111._rk*time+84._rk)/16._rk + &
                time**THREE*(-24._rk*time**TWO+102._rk*time-111._rk)/16._rk

!        !Case 1
!        height = b2
!        theta = ZERO
!        dheightdt = db2dt
!        dthetadt = ZERO

        !Case 2
        height = b2
        A2 = (60._rk*PI/180._rk)
        theta = A2*b1
        dheightdt = db2dt
        dthetadt = A2*db1dt
!
!        !Case 3
!        height = b3
!        A3 = (80._rk*PI/180._rk)
!        theta = A3*b1
!        dheightdt = db3dt
!        dthetadt = A3*db1dt

        !Center of motion nodeinates
        xc = 1._rk/3._rk
        yc = 0._rk

        !Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        !Rotate about the center of motion
        x_ale = -sin(theta)*dthetadt*(x0-xc)+cos(theta)*dthetadt*(y0-yc)
        y_ale = -cos(theta)*dthetadt*(x0-xc)-sin(theta)*dthetadt*(y0-yc)

        !Translate vertically
        y_ale = y_ale + dheightdt

        if (time > TWO) x_ale = ZERO
        if (time > TWO) y_ale = ZERO

        val(1) = x_ale
        val(2) = y_ale
        val(3) = ZERO

    end function compute_vel
    !**********************************************************************************

end module pmmf_hpaf_case2


module systemparams
    implicit none
    save
    integer :: i,nx,snapshot
	integer :: counter = 0 , old_counter, temp_int
    real, parameter :: pi = 3.141592653
    real, parameter :: freeze = 273.0
    real, parameter :: sun_mass = 1.99d33
    real, parameter :: AU = 1.496e13
    real, parameter :: sun_luminosity = 3.826e33
    real, parameter :: q0 = sun_luminosity/(4.0*pi*AU*AU)
    real, parameter :: G = 6.673d-8
    real, parameter :: C_atm0 = 10.1d9
    real, parameter :: year = 3.1556926d7
    real, parameter :: sigma_SB = 5.6704d-5
    real, parameter :: D = 5.394d2
    real, parameter :: p0 = 1
    real :: a, e, angular_position, period, orb_period,orb_freq, spin_obliquity,azim_obliquity, C_ice
    real :: ocean_fraction, f_land, initial_temp, time, sim_time, dlat,dt,h_ang, phi_peri
	real :: habfraction = 0.0 , mean_hab = 0.0 , mean2_hab = 0.0
	real :: old_mean_hab , old_mean2_hab
	real :: T_mean_new , T_mean_old, D_co
    real :: r,H,Fj,Fj1,star_mass,star_lum,diff,freq,timeyr
    real :: hh = 0.0
	real :: hc = 0.0
    real :: meanT, phidot, r_p, habfrac, p,C_land ,C_ocean, boil
    real :: yr10 = 3.1556926d8
	real :: T_min = 220, T_max
	character(100)::parameter_file,parameter_path, result_path
    character(100)::run_status, fileno, temp_str , filename
    real, allocatable :: f_time(:)
    real, allocatable :: T(:), T_old(:), insol(:),cos_H(:),tt(:),tau_ir_1(:), tau_0(:)
    real, allocatable :: lat(:), x(:), albedo(:),tau_ir(:),hab(:),latdeg(:)
    real, allocatable :: infrared(:), Q(:),deltax(:), f_ice(:), C_tot(:)
end module systemparams


module variables
  real(kind=8) :: mbh=0.0     ! central black hole mass
  real(kind=8) :: radius  ! radius
  real(kind=8) :: m200=0.0  ! virial mass
  real(kind=8) :: mvir=0.0  ! virial mass
  real(kind=8) :: mhalo=0.0 ! halo mass
  real(kind=8) :: v200=0.0  ! virial velocity
  integer(kind=4) :: halotype ! Type of halo
  real(kind=8) :: rs      ! NFW scale radius
  real(kind=8) :: r200    ! virial radius
  real(kind=8) :: c200    ! NFW concentration
  real(kind=8) :: sigma0  ! central surface density
  real(kind=8) :: rdisc=0.0   ! disc scale length
  real(kind=8) :: bdisc=0.0   ! disc shape parameter (Miyamoto-Nagai disc)
  real(kind=8) :: mbulge=0.0  ! bulge mass
  real(kind=8) :: fbulge=0.0  ! bulge extent
  real(kind=8) :: rbulge=0.0  ! bulge extent
  real(kind=8) :: mstar=0.0   ! stellar mass
  real(kind=8) :: mdisc=0.0   ! disc mass
  real(kind=8) :: fdisc=0.0   ! stellar mass
  real(kind=8) :: beta0
  real(kind=8) :: r_a

  integer(kind=4) :: nrbin
  real(kind=8), allocatable :: rtab(:)
  real(kind=8), allocatable :: sigma_r(:)
  real(kind=8), allocatable :: sigma_p(:)
  real(kind=8), allocatable :: sigma_m(:)
end module variables


!--------------------------------------------------------------------------------------------------
! MODULE: matrix_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date August, 2018
!
!> @brief LAPACK interfaces and common matrix operations.
!--------------------------------------------------------------------------------------------------
module matrix_mod
    use global_defs, only : dp, errstop
    use linalg_wrapper_mod
    implicit none

    private
    public :: diagonal_mat
    public :: unit_mat
    public :: vec_outer
    public :: mat_norm
    public :: mat_sy_ev
    public :: mat_sy_exp
    public :: mat_ge_det
    public :: mat_ge_mmm

    interface vec_outer
        module procedure vec_outer_int
        module procedure vec_outer_dp
    end interface vec_outer

contains

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: diagonal_mat
    !> @brief Given a vector return diagonal matrix with values from vector on the diagonal.
    !----------------------------------------------------------------------------------------------
    function diagonal_mat(vec) result(mat)
        real(dp), intent(in) :: vec(:)
        real(dp) :: mat(size(vec), size(vec))
        integer :: i

        mat = num0
        do i = 1, size(vec)
            mat(i, i) = vec(i)
        end do
    end function diagonal_mat

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: unit_mat
    !> @brief Return a unit matrix of dimension n.
    !----------------------------------------------------------------------------------------------
    function unit_mat(n) result(mat)
        integer, intent(in) :: n
        real(dp) :: mat(n, n)
        integer :: i

        mat = num0
        do i = 1, n
            mat(i, i) = num1
        end do
    end function unit_mat

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: vec_outer_int
    !> @brief Give outer product of two int vectors.
    !----------------------------------------------------------------------------------------------
    function vec_outer_int(vec1, vec2) result(mat)
        integer :: vec1(:)
        integer :: vec2(:)
        integer :: mat(size(vec1), size(vec2))
        integer :: i

        do i = 1, size(vec2)
            mat(:, i) = vec2(i) * vec1
        end do
    end function vec_outer_int

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: vec_outer_dp
    !> @brief Give outer product of two dp vectors.
    !----------------------------------------------------------------------------------------------
    function vec_outer_dp(vec1, vec2) result(mat)
        real(dp) :: vec1(:)
        real(dp) :: vec2(:)
        real(dp) :: mat(size(vec1), size(vec2))

        mat = 0.0_dp
        call ger(mat, vec1, vec2)
    end function vec_outer_dp

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: mat_norm
    !> @brief Returns norm of matrix (Frobenius or spectral).
    !----------------------------------------------------------------------------------------------
    function mat_norm(mat, norm_type) result(norm)
        real(dp), intent(in) :: mat(:, :) !< Matrix.
        character(len=*), intent(in), optional :: norm_type !< Type of norm requested.
        real(dp) :: norm !< Norm of matrix.
        real(dp), allocatable :: s(:) !< Singular values.
        real(dp), allocatable :: a(:, :) !< Temporary matrix.
        character(len=:), allocatable :: opt

        opt = 'frobenius'
        if (present(norm_type)) opt = norm_type

        select case(opt)
        case('frobenius')
            norm = sqrt(sum(mat**2))
        case('spectral')
            allocate(s(min(size(mat, 1), size(mat, 2))))
            allocate(a, source=mat)
            call gesvd(a, s)
            norm = sqrt(s(1))
        end select
    end function mat_norm

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: mat_sy_ev
    !> @brief Eigensystem of a symmetric real matrix.
    !----------------------------------------------------------------------------------------------
    subroutine mat_sy_ev(a, evec, eval)
        real(dp), intent(in) :: a(:, :) !< Input matrix.
        real(dp), allocatable, intent(out) :: evec(:, :) !< Eigenvectors of the symmetric matrix.
        real(dp), allocatable, intent(out) :: eval(:) !< Eigenvalues of the symmetric matrix.
        integer :: n
        integer :: info

        n = size(a, 1)
        if (.not. allocated(evec)) allocate(evec, source=a)
        if (.not. allocated(eval)) allocate(eval(n))

        ! Calculate eigensystem.
        call syev(a=evec, w=eval, jobz='V', info=info)
        if (info /= 0) call errstop('mat_sy_ev', 'syev call failed.', info)
    end subroutine mat_sy_ev

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: mat_sy_exp
    !
    !> @brief Matrix exponential of a symmetric real matrix multiplied by a complex factor.
    !> @details
    !! The subroutine first calculates the eigenvectors/eigenvalues of the matrix. Then the matrix
    !! exponantial is calculated in the eigenvector basis and the matrix is converted back to the
    !! original basis.
    !----------------------------------------------------------------------------------------------
    function mat_sy_exp(a, mult) result (res)
        real(dp), intent(in) :: a(:, :) !< Input matrix.
        complex(dp), intent(in) :: mult !< Multiplier in exponent.
        complex(dp), allocatable :: res(:, :) !< Result matrix.
        real(dp), allocatable :: evec(:, :) !< Eigenvectors of the symmetric matrix.
        real(dp), allocatable :: eval(:) !< Eigenvalues of the symmetric matrix.
        complex(dp), dimension(:, :), allocatable :: tmp1, tmp2 !< Work matrices
        integer :: i, n
        integer :: info

        n = size(a, 1)
        allocate(evec, source=a)
        allocate(eval(n))
        allocate(tmp1(n, n))
        allocate(tmp2(n, n))
        if (.not. allocated(res)) allocate(res(n, n))

        ! Calculate eigensystem.
        call syev(a=evec, w=eval, jobz='V', info=info)
        if (info /= 0) call errstop('mat_sy_exp', 'syev call failed.', info)

        ! Matrix exponential in eigenvector basis.
        res = cmplx(0.0_dp, 0.0_dp, dp)
        do i = 1, n
            res(i, i) = exp(eval(i) * mult)
        end do

        ! Conversion to original basis.
        tmp1 = cmplx(evec, 0.0_dp, dp)
        call gemm(tmp1, res, tmp2)
        call gemm(tmp2, tmp1, res, transb='C')
    end function mat_sy_exp

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: mat_ge_det
    !> @brief Compute determinant of general matrix.
    !> @details
    !! Uses LU factorization to compute the determinant. The input matrix is not changed.
    !----------------------------------------------------------------------------------------------
    function mat_ge_det(a) result(adet)
        real(dp), intent(in) :: a(:, :) !< Matrix.
        real(dp) :: adet !< Determinant.
        real(dp), allocatable :: tmp(:, :) !< Work array.
        integer, allocatable :: ipiv(:)   ! pivot indices
        integer :: sgn !< Sign change based on pivots.
        integer :: info !< LAPACK exit status.
        integer :: i, n

        n = size(a, 1)
        allocate(tmp, source=a)
        allocate(ipiv(n))

        ! LU factorization using partial pivoting with row interchanges.
        call getrf(tmp, ipiv, info)
        if (info /= 0) then
            adet = 0.0_dp
            return
        end if

        sgn = 1
        adet = 1.0_dp
        do i = 1, n
            if (ipiv(i) /= i) sgn = -sgn
            adet = adet * tmp(i, i)
        end do
        adet = sgn * adet
    end function mat_ge_det

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: mat_ge_mmm
    !> @brief Multiply 3 matrices
    !----------------------------------------------------------------------------------------------
    subroutine mat_ge_mmm(a, b, c, d, transa, transc)
        real(dp) :: a(:, :) !< Input matrix 1.
        real(dp) :: b(:, :) !< Input matrix 2.
        real(dp) :: c(:, :) !< Input matrix 3.
        real(dp) :: d(:, :) !< Output matrix.
        character(len=1), intent(in), optional :: transa !< op(A)
        character(len=1), intent(in), optional :: transc !< op(C)

        real(dp), allocatable :: wrk(:, :)
        character(len=1) :: wrk_transa
        character(len=1) :: wrk_transc

        wrk_transa = 'N'
        if (present(transa)) wrk_transa = transa
        wrk_transc = 'N'
        if (present(transc)) wrk_transc = transc

        if (wrk_transa == 'N') then
            allocate(wrk(size(a, 1), size(b, 2)))
        else
            allocate(wrk(size(a, 2), size(b, 2)))
        end if

        call gemm(a, b, wrk, transa=wrk_transa)
        call gemm(wrk, c, d, transb=wrk_transc)
    end subroutine mat_ge_mmm

end module matrix_mod


! Copyright 2019 NREL

! Licensed under the Apache License, Version 2.0 (the "License"); you may not use
! this file except in compliance with the License. You may obtain a copy of the
! License at http://www.apache.org/licenses/LICENSE-2.0

! Unless required by applicable law or agreed to in writing, software distributed
! under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR
! CONDITIONS OF ANY KIND, either express or implied. See the License for the
! specific language governing permissions and limitations under the License.

MODULE Constants
    REAL(4), PARAMETER          :: RPS2RPM = 9.5492966                  ! Factor to convert radians per second to revolutions per minute.
    REAL(4), PARAMETER          :: R2D = 57.295780                      ! Factor to convert radians to degrees.
    REAL(4), PARAMETER          :: D2R = 0.0175                         ! Factor to convert degrees to radians.
    REAL(4), PARAMETER          :: PI = 3.14159265359                   ! Mathematical constant pi
    INTEGER(4), PARAMETER       :: NP_1 = 1                             ! First rotational harmonic
    INTEGER(4), PARAMETER       :: NP_2 = 2                             ! Second rotational harmonic
END MODULE Constants


function SHMagPowerL(c, a, r, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power for
!   degree l of the magnetic field evaluated at radius r,
!   given the Schmidt seminormalized spherical harmonic
!   coefficients c(i, l, m) of the magnetic potential evaluated
!   at radius a.
!
!   power(l) = (a/r)^(2l+4) (l+1) sum_{m=0}^l ( c1lm**2 + c2lm**2 )
!
!   Calling Parameters
!
!       c   Schmidt-seminormalized spherical harmonic coefficients of the
!           magnetic potential evaluated at radius a, dimensioned as
!           (2, lmax+1, lmax+1).
!       a   Reference radius of the magnetic potential spherical harmonic
!           coefficients.
!       r   Radius to evaluate the magnetic field.
!       l   Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHMagPowerL
    real(dp), intent(in) :: c(:,:,:)
    real(dp), intent(in) :: a, r
    integer, intent(in) :: l
    integer i, m, l1, m1

    l1 = l + 1

    if (size(c(:,1,1)) < 2 .or. size(c(1,:,1)) < l1 .or. &
        size(c(1,1,:)) < l1) then
        print*, "Error --- SHMagPowerL"
        print*, "C must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(c(:,1,1)), &
                                               size(c(1,:,1)), size(c(1,1,:))
        stop

    end if

    SHMagPowerL = 0.0_dp

    do m = 0, l
        m1 = m + 1
        do i = 1, 2
            SHMagPowerL = SHMagPowerL + c(i, l1, m1)**2
        end do
    end do

    SHMagPowerL = SHMagPowerL * dble(l+1) * (a / r)**(2*l+4)

end function SHMagPowerL

subroutine SHMagPowerSpectrum(c, a, r, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   of the magnetic field evaluated at radius r,
!   given the Schmidt seminormalized spherical harmonic
!   coefficients c(i, l, m) of the magnetic potential evaluated
!   at radius a.
!
!   power(l) = (a/r)^(2l+4) (l+1) sum_{m=0}^l ( c1lm**2 + c2lm**2 )
!
!   Calling Parameters
!
!       IN
!           c       Schmidt seminormalized spherical harmonic coefficients of
!                   the magnetic potential evaluated at radius a, dimensioned as
!                   (2, lmax+1, lmax+1).
!           a       Reference radius of the magnetic potential spherical
!                   harmonic coefficients.
!           r       Radius to evaluate the magnetic field.
!           lmax    Maximum spherical harmonic degree to compute power of.
!
!       OUT
!           spectra Array of length (lmax+1) containing the power spectra of c.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: c(:,:,:)
    real(dp), intent(in) :: a, r
    integer, intent(in) :: lmax
    real(dp), intent(out) ::spectra(:)
    integer, intent(out), optional :: exitstatus
    integer i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(c(:,1,1)) < 2 .or. size(c(1,:,1)) < lmax+1 &
        .or. size(c(1,1,:)) < lmax+1) then
        print*, "Error --- SHMagPowerSpectrum"
        print*, "C must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(c(:,1,1)), &
                                               size(c(1,:,1)), size(c(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(spectra) < lmax+1) then
        print*, "Error --- SHMagPowerSpectrum"
        print*, "SPECTRA must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input vector has dimension ", size(spectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    spectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        do m = 0, l
            m1 = m + 1

            do i = 1, 2
                spectra(l1) = spectra(l1) + c(i, l1, m1)**2
            end do
        end do

        spectra(l1) = spectra(l1) * dble(l+1) * (a / r)**(2*l+4)

    end do

end subroutine SHMagPowerSpectrum


*DECK QZHES
      SUBROUTINE QZHES (NM, N, A, B, MATZ, Z)
C***BEGIN PROLOGUE  QZHES
C***PURPOSE  The first step of the QZ algorithm for solving generalized
C            matrix eigenproblems.  Accepts a pair of real general
C            matrices and reduces one of them to upper Hessenberg
C            and the other to upper triangular form using orthogonal
C            transformations. Usually followed by QZIT, QZVAL, QZVEC.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B3
C***TYPE      SINGLE PRECISION (QZHES-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is the first step of the QZ algorithm
C     for solving generalized matrix eigenvalue problems,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART.
C
C     This subroutine accepts a pair of REAL GENERAL matrices and
C     reduces one of them to upper Hessenberg form and the other
C     to upper triangular form using orthogonal transformations.
C     It is usually followed by  QZIT,  QZVAL  and, possibly,  QZVEC.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real general matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a real general matrix.  B is a two-dimensional
C          REAL array, dimensioned B(NM,N).
C
C        MATZ should be set to .TRUE. if the right hand transformations
C          are to be accumulated for later use in computing
C          eigenvectors, and to .FALSE. otherwise.  MATZ is a LOGICAL
C          variable.
C
C     On Output
C
C        A has been reduced to upper Hessenberg form.  The elements
C          below the first subdiagonal have been set to zero.
C
C        B has been reduced to upper triangular form.  The elements
C          below the main diagonal have been set to zero.
C
C        Z contains the product of the right hand transformations if
C          MATZ has been set to .TRUE.  Otherwise, Z is not referenced.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  QZHES
C
      INTEGER I,J,K,L,N,LB,L1,NM,NK1,NM1,NM2
      REAL A(NM,*),B(NM,*),Z(NM,*)
      REAL R,S,T,U1,U2,V1,V2,RHO
      LOGICAL MATZ
C
C     .......... INITIALIZE Z ..........
C***FIRST EXECUTABLE STATEMENT  QZHES
      IF (.NOT. MATZ) GO TO 10
C
      DO 3 I = 1, N
C
         DO 2 J = 1, N
            Z(I,J) = 0.0E0
    2    CONTINUE
C
         Z(I,I) = 1.0E0
    3 CONTINUE
C     .......... REDUCE B TO UPPER TRIANGULAR FORM ..........
   10 IF (N .LE. 1) GO TO 170
      NM1 = N - 1
C
      DO 100 L = 1, NM1
         L1 = L + 1
         S = 0.0E0
C
         DO 20 I = L1, N
            S = S + ABS(B(I,L))
   20    CONTINUE
C
         IF (S .EQ. 0.0E0) GO TO 100
         S = S + ABS(B(L,L))
         R = 0.0E0
C
         DO 25 I = L, N
            B(I,L) = B(I,L) / S
            R = R + B(I,L)**2
   25    CONTINUE
C
         R = SIGN(SQRT(R),B(L,L))
         B(L,L) = B(L,L) + R
         RHO = R * B(L,L)
C
         DO 50 J = L1, N
            T = 0.0E0
C
            DO 30 I = L, N
               T = T + B(I,L) * B(I,J)
   30       CONTINUE
C
            T = -T / RHO
C
            DO 40 I = L, N
               B(I,J) = B(I,J) + T * B(I,L)
   40       CONTINUE
C
   50    CONTINUE
C
         DO 80 J = 1, N
            T = 0.0E0
C
            DO 60 I = L, N
               T = T + B(I,L) * A(I,J)
   60       CONTINUE
C
            T = -T / RHO
C
            DO 70 I = L, N
               A(I,J) = A(I,J) + T * B(I,L)
   70       CONTINUE
C
   80    CONTINUE
C
         B(L,L) = -S * R
C
         DO 90 I = L1, N
            B(I,L) = 0.0E0
   90    CONTINUE
C
  100 CONTINUE
C     .......... REDUCE A TO UPPER HESSENBERG FORM, WHILE
C                KEEPING B TRIANGULAR ..........
      IF (N .EQ. 2) GO TO 170
      NM2 = N - 2
C
      DO 160 K = 1, NM2
         NK1 = NM1 - K
C     .......... FOR L=N-1 STEP -1 UNTIL K+1 DO -- ..........
         DO 150 LB = 1, NK1
            L = N - LB
            L1 = L + 1
C     .......... ZERO A(L+1,K) ..........
            S = ABS(A(L,K)) + ABS(A(L1,K))
            IF (S .EQ. 0.0E0) GO TO 150
            U1 = A(L,K) / S
            U2 = A(L1,K) / S
            R = SIGN(SQRT(U1*U1+U2*U2),U1)
            V1 =  -(U1 + R) / R
            V2 = -U2 / R
            U2 = V2 / V1
C
            DO 110 J = K, N
               T = A(L,J) + U2 * A(L1,J)
               A(L,J) = A(L,J) + T * V1
               A(L1,J) = A(L1,J) + T * V2
  110       CONTINUE
C
            A(L1,K) = 0.0E0
C
            DO 120 J = L, N
               T = B(L,J) + U2 * B(L1,J)
               B(L,J) = B(L,J) + T * V1
               B(L1,J) = B(L1,J) + T * V2
  120       CONTINUE
C     .......... ZERO B(L+1,L) ..........
            S = ABS(B(L1,L1)) + ABS(B(L1,L))
            IF (S .EQ. 0.0E0) GO TO 150
            U1 = B(L1,L1) / S
            U2 = B(L1,L) / S
            R = SIGN(SQRT(U1*U1+U2*U2),U1)
            V1 =  -(U1 + R) / R
            V2 = -U2 / R
            U2 = V2 / V1
C
            DO 130 I = 1, L1
               T = B(I,L1) + U2 * B(I,L)
               B(I,L1) = B(I,L1) + T * V1
               B(I,L) = B(I,L) + T * V2
  130       CONTINUE
C
            B(L1,L) = 0.0E0
C
            DO 140 I = 1, N
               T = A(I,L1) + U2 * A(I,L)
               A(I,L1) = A(I,L1) + T * V1
               A(I,L) = A(I,L) + T * V2
  140       CONTINUE
C
            IF (.NOT. MATZ) GO TO 150
C
            DO 145 I = 1, N
               T = Z(I,L1) + U2 * Z(I,L)
               Z(I,L1) = Z(I,L1) + T * V1
               Z(I,L) = Z(I,L) + T * V2
  145       CONTINUE
C
  150    CONTINUE
C
  160 CONTINUE
C
  170 RETURN
      END


module scalar_analysis_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip, & ! integer precision
        even, odd

    use type_ScalarHarmonic, only: &
        ScalarHarmonic

    use type_SpherepackUtility, only: &
        SpherepackUtility, &
        get_lshaec, &
        get_lshagc, &
        get_lshaes, &
        get_lshags

    use gaussian_latitudes_and_weights_routines, only: &
        compute_gaussian_latitudes_and_weights

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    public :: shagc, shagci, initialize_shaec
    public :: shaes, shaesi, initialize_shaes
    public :: shaec, shaeci, initialize_shagc
    public :: shags, shagsi, initialize_shags
    public :: ScalarForwardTransform

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: HALF = 0.5_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: FOUR = 4.0_wp

    type, public :: ScalarForwardTransform
    contains
        ! Type-bound procedures
        procedure, nopass :: shaec
        procedure, nopass :: shaeci
        procedure, nopass :: shagc
        procedure, nopass :: shagci
        procedure, nopass :: shaes
        procedure, nopass :: shaesi
        procedure, nopass :: shags
        procedure, nopass :: shagsi
        procedure, nopass :: initialize_shaec
        procedure, nopass :: initialize_shaes
        procedure, nopass :: initialize_shagc
        procedure, nopass :: initialize_shags
    end type ScalarForwardTransform

    ! Declare interfaces for submodule implementation
    interface
        module subroutine shaec(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshaec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            integer(ip), intent(in)   :: isym
            integer(ip), intent(in)   :: nt
            real(wp),    intent(in)   :: g(idg, jdg, nt)
            integer(ip), intent(in)   :: idg
            integer(ip), intent(in)   :: jdg
            real(wp),    intent(out)  :: a(mdab, ndab, nt)
            real(wp),    intent(out)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)   :: mdab
            integer(ip), intent(in)   :: ndab
            real(wp),    intent(in)   :: wshaec(:)
            integer(ip), intent(out)  :: ierror
        end subroutine shaec

        module subroutine shaes(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshaes, ierror)

            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            integer(ip), intent(in)   :: isym
            integer(ip), intent(in)   :: nt
            real(wp),    intent(in)   :: g(idg, jdg, nt)
            integer(ip), intent(in)   :: idg
            integer(ip), intent(in)   :: jdg
            real(wp),    intent(out)  :: a(mdab, ndab, nt)
            real(wp),    intent(out)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)   :: mdab
            integer(ip), intent(in)   :: ndab
            real(wp),    intent(in)   :: wshaes(:)
            integer(ip), intent(out)  :: ierror
        end subroutine shaes

        module subroutine shagc(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshagc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            integer(ip), intent(in)   :: isym
            integer(ip), intent(in)   :: nt
            real(wp),    intent(in)   :: g(idg, jdg, nt)
            integer(ip), intent(in)   :: idg
            integer(ip), intent(in)   :: jdg
            real(wp),    intent(out)  :: a(mdab, ndab, nt)
            real(wp),    intent(out)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)   :: mdab
            integer(ip), intent(in)   :: ndab
            real(wp),    intent(in)   :: wshagc(:)
            integer(ip), intent(out)  :: ierror
        end subroutine shagc

        module subroutine shags(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wshags, ierror)

            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            integer(ip), intent(in)   :: isym
            integer(ip), intent(in)   :: nt
            real(wp),    intent(in)   :: g(idg, jdg, nt)
            integer(ip), intent(in)   :: idg
            integer(ip), intent(in)   :: jdg
            real(wp),    intent(out)  :: a(mdab, ndab, nt)
            real(wp),    intent(out)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)   :: mdab
            integer(ip), intent(in)   :: ndab
            real(wp),    intent(in)   :: wshags(:)
            integer(ip), intent(out)  :: ierror
        end subroutine shags

        module subroutine shaeci(nlat, nlon, wshaec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wshaec(:)
            integer(ip), intent(out) :: ierror
        end subroutine shaeci

        module subroutine shaesi(nlat, nlon, wshaes, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wshaes(:)
            integer(ip), intent(out) :: ierror
        end subroutine shaesi

        module subroutine shagci(nlat, nlon, wshagc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            real(wp),    intent(out) :: wshagc(:)
            integer(ip), intent(out) :: ierror
        end subroutine shagci

        module subroutine shagsi(nlat, nlon, wshags, ierror)

            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            real(wp),    intent(out)  :: wshags(:)
            integer(ip), intent(out)  :: ierror
        end subroutine shagsi
    end interface

    abstract interface
        subroutine analysis_sub(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wavetable, ierror)
            import :: ip, wp
            ! Dummy arguments
            integer(ip), intent(in)   :: nlat
            integer(ip), intent(in)   :: nlon
            integer(ip), intent(in)   :: isym
            integer(ip), intent(in)   :: nt
            real(wp),    intent(in)   :: g(idg, jdg, nt)
            integer(ip), intent(in)   :: idg
            integer(ip), intent(in)   :: jdg
            real(wp),    intent(out)  :: a(mdab, ndab, nt)
            real(wp),    intent(out)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)   :: mdab
            integer(ip), intent(in)   :: ndab
            real(wp),    intent(in)   :: wavetable(:)
            integer(ip), intent(out)  :: ierror
        end subroutine analysis_sub
    end interface

    ! Overload subroutine
    interface perform_scalar_analysis
        module procedure perform_scalar_analysis_2d
        module procedure perform_scalar_analysis_3d
    end interface

contains

    subroutine perform_scalar_analysis_2d(nlat, nlon, scalar_symmetries, scalar_function, &
        harmonic, wavetable, error_flag, analysis_routine)

        ! Dummy arguments
        integer(ip),         intent(in)    :: nlat
        integer(ip),         intent(in)    :: nlon
        integer(ip),         intent(in)    :: scalar_symmetries
        real(wp),            intent(in)    :: scalar_function(:,:)
        class(ScalarHarmonic), intent(inout) :: harmonic
        real(wp),            intent(in)    :: wavetable(:)
        integer(ip),         intent(out)   :: error_flag
        procedure(analysis_sub)            :: analysis_routine

        associate (&
            isym => scalar_symmetries, &
            g => scalar_function, &
            idg => size(scalar_function, dim=1), &
            jdg => size(scalar_function, dim=2), &
            nt => harmonic%NUMBER_OF_SYNTHESES, &
            a => harmonic%real_component, &
            b => harmonic%imaginary_component, &
            mdab => harmonic%ORDER_M, &
            ndab => harmonic%DEGREE_N, &
            ierror => error_flag &
            )

            call analysis_routine(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wavetable, ierror)
        end associate

    end subroutine perform_scalar_analysis_2d

    subroutine perform_scalar_analysis_3d(nlat, nlon, scalar_symmetries, scalar_function, &
        harmonic, wavetable, error_flag, analysis_routine)

        ! Dummy arguments
        integer(ip),         intent(in)    :: nlat
        integer(ip),         intent(in)    :: nlon
        integer(ip),         intent(in)    :: scalar_symmetries
        real(wp),            intent(in)    :: scalar_function(:,:,:)
        class(ScalarHarmonic), intent(inout) :: harmonic
        real(wp),            intent(in)    :: wavetable(:)
        integer(ip),         intent(out)   :: error_flag
        procedure(analysis_sub)            :: analysis_routine

        associate (&
            isym => scalar_symmetries, &
            g => scalar_function, &
            idg => size(scalar_function, dim=1), &
            jdg => size(scalar_function, dim=2), &
            nt => size(scalar_function, dim=3), &
            a => harmonic%real_component, &
            b => harmonic%imaginary_component, &
            mdab => harmonic%ORDER_M, &
            ndab => harmonic%DEGREE_N, &
            ierror => error_flag &
            )

            call analysis_routine(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, wavetable, ierror)
        end associate

    end subroutine perform_scalar_analysis_3d

    subroutine initialize_shaec(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lshaec, shaeci, error_flag)

    end subroutine initialize_shaec

    subroutine initialize_shaes(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lshaes, shaesi, error_flag)

    end subroutine initialize_shaes

    subroutine initialize_shagc(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lshagc, shagci, error_flag)

    end subroutine initialize_shagc

    subroutine initialize_shags(nlat, nlon, wavetable, error_flag)

        ! Dummy arguments
        integer(ip),           intent(in)  :: nlat
        integer(ip),           intent(in)  :: nlon
        real(wp), allocatable, intent(out) :: wavetable(:)
        integer(ip),           intent(out) :: error_flag

        ! Local variables
        type(SpherepackUtility) :: util

        ! Initialize wavetable
        call util%initialize_wavetable(nlat, nlon, wavetable, &
            get_lshags, shagsi, error_flag)

    end subroutine initialize_shags

end module scalar_analysis_routines


c       this file contains the following user-callable routines:
c
c
c       routine idd_sffti initializes routine idd_sfft.
c
c       routine idd_sfft rapidly computes a subset of the entries
c       of the DFT of a vector, composed with permutation matrices
c       both on input and on output.
c
c       routine idd_ldiv finds the greatest integer less than or equal
c       to a specified integer, that is divisible by another (larger)
c       specified integer.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idd_ldiv(l,n,m)
c
c       finds the greatest integer less than or equal to l
c       that divides n.
c
c       input:
c       l -- integer at least as great as m
c       n -- integer divisible by m
c
c       output:
c       m -- greatest integer less than or equal to l that divides n
c
        implicit none
        integer n,l,m
c
c
        m = l
c
 1000   continue
        if(m*(n/m) .eq. n) goto 2000
c
          m = m-1
          goto 1000
c
 2000   continue
c
c
        return
        end
c
c
c
c
        subroutine idd_sffti(l,ind,n,wsave)
c
c       initializes wsave for using routine idd_sfft.
c
c       input:
c       l -- number of pairs of entries in the output of idd_sfft
c            to compute
c       ind -- indices of the pairs of entries in the output
c              of idd_sfft to compute; the indices must be chosen
c              in the range from 1 to n/2
c       n -- length of the vector to be transformed
c
c       output:
c       wsave -- array needed by routine idd_sfft for processing
c                (the present routine does not use the last n elements
c                 of wsave, but routine idd_sfft does)
c
        implicit none
        integer l,ind(l),n
        complex*16 wsave(2*l+15+4*n)
c
c
        if(l .eq. 1) call idd_sffti1(ind,n,wsave)
        if(l .gt. 1) call idd_sffti2(l,ind,n,wsave)
c
c
        return
        end
c
c
c
c
        subroutine idd_sffti1(ind,n,wsave)
c
c       routine idd_sffti serves as a wrapper around
c       the present routine; please see routine idd_sffti
c       for documentation.
c
        implicit none
        integer ind,n,k
        real*8 r1,twopi,wsave(2*(2+15+4*n)),fact
c
        r1 = 1
        twopi = 2*4*atan(r1)
c
c
        fact = 1/sqrt(r1*n)
c
c
        do k = 1,n
          wsave(k) = cos(twopi*(k-1)*ind/(r1*n))*fact
        enddo ! k
c
        do k = 1,n
          wsave(n+k) = -sin(twopi*(k-1)*ind/(r1*n))*fact
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idd_sffti2(l,ind,n,wsave)
c
c       routine idd_sffti serves as a wrapper around
c       the present routine; please see routine idd_sffti
c       for documentation.
c
        implicit none
        integer l,ind(l),n,nblock,ii,m,idivm,imodm,i,j,k
        real*8 r1,twopi,fact
        complex*16 wsave(2*l+15+4*n),ci,twopii
c
        ci = (0,1)
        r1 = 1
        twopi = 2*4*atan(r1)
        twopii = twopi*ci
c
c
c       Determine the block lengths for the FFTs.
c
        call idd_ldiv(l,n,nblock)
        m = n/nblock
c
c
c       Initialize wsave for using routine dfftf.
c
        call dffti(nblock,wsave)
c
c
c       Calculate the coefficients in the linear combinations
c       needed for the direct portion of the calculation.
c
        fact = 1/sqrt(r1*n)
c
        ii = 2*l+15
c
        do j = 1,l
c
c
          i = ind(j)
c
c
          if(i .le. n/2-m/2) then
c
            idivm = (i-1)/m
            imodm = (i-1)-m*idivm
c
            do k = 1,m
              wsave(ii+m*(j-1)+k) = exp(-twopii*(k-1)*imodm/(r1*m))
     1         * exp(-twopii*(k-1)*(idivm+1)/(r1*n)) * fact
            enddo ! k
c
          endif ! i .le. n/2-m/2
c
c
          if(i .gt. n/2-m/2) then
c
            idivm = i/(m/2)
            imodm = i-(m/2)*idivm
c
            do k = 1,m
              wsave(ii+m*(j-1)+k) = exp(-twopii*(k-1)*imodm/(r1*m))
     1                            * fact
            enddo ! k
c
          endif ! i .gt. n/2-m/2
c
c
        enddo ! j
c
c
        return
        end
c
c
c
c
        subroutine idd_sfft(l,ind,n,wsave,v)
c
c       computes a subset of the entries of the DFT of v,
c       composed with permutation matrices both on input and on output,
c       via a two-stage procedure (debugging code routine dfftf2 above
c       is supposed to calculate the full vector from which idd_sfft
c       returns a subset of the entries, when dfftf2 has
c       the same parameter nblock as in the present routine).
c
c       input:
c       l -- number of pairs of entries in the output to compute
c       ind -- indices of the pairs of entries in the output
c              to compute; the indices must be chosen
c              in the range from 1 to n/2
c       n -- length of v; n must be a positive integer power of 2
c       v -- vector to be transformed
c       wsave -- processing array initialized by routine idd_sffti
c
c       output:
c       v -- pairs of entries indexed by ind are given
c            their appropriately transformed values
c
c       _N.B._: n must be a positive integer power of 2.
c
c       references:
c       Sorensen and Burrus, "Efficient computation of the DFT with
c            only a subset of input or output points,"
c            IEEE Transactions on Signal Processing, 41 (3): 1184-1200,
c            1993.
c       Woolfe, Liberty, Rokhlin, Tygert, "A fast randomized algorithm
c            for the approximation of matrices," Applied and
c            Computational Harmonic Analysis, 25 (3): 335-366, 2008;
c            Section 3.3.
c
        implicit none
        integer l,ind(l),n
        real*8 v(n)
        complex*16 wsave(2*l+15+4*n)
c
c
        if(l .eq. 1) call idd_sfft1(ind,n,v,wsave)
        if(l .gt. 1) call idd_sfft2(l,ind,n,v,wsave)
c
c
        return
        end
c
c
c
c
        subroutine idd_sfft1(ind,n,v,wsave)
c
c       routine idd_sfft serves as a wrapper around
c       the present routine; please see routine idd_sfft
c       for documentation.
c
        implicit none
        integer ind,n,k
        real*8 v(n),r1,twopi,sumr,sumi,fact,wsave(2*(2+15+4*n))
c
        r1 = 1
        twopi = 2*4*atan(r1)
c
c
        if(ind .lt. n/2) then
c
c
          sumr = 0
c
          do k = 1,n
            sumr = sumr+wsave(k)*v(k)
          enddo ! k
c
c
          sumi = 0
c
          do k = 1,n
            sumi = sumi+wsave(n+k)*v(k)
          enddo ! k
c
c
        endif ! ind .lt. n/2
c
c
        if(ind .eq. n/2) then
c
c
          fact = 1/sqrt(r1*n)
c
c
          sumr = 0
c
          do k = 1,n
            sumr = sumr+v(k)
          enddo ! k
c
          sumr = sumr*fact
c
c
          sumi = 0
c
          do k = 1,n/2
            sumi = sumi+v(2*k-1)
            sumi = sumi-v(2*k)
          enddo ! k
c
          sumi = sumi*fact
c
c
        endif ! ind .eq. n/2
c
c
        v(2*ind-1) = sumr
        v(2*ind) = sumi
c
c
        return
        end
c
c
c
c
        subroutine idd_sfft2(l,ind,n,v,wsave)
c
c       routine idd_sfft serves as a wrapper around
c       the present routine; please see routine idd_sfft
c       for documentation.
c
        implicit none
        integer n,m,l,k,j,ind(l),i,idivm,nblock,ii,iii,imodm
        real*8 r1,twopi,v(n),rsum,fact
        complex*16 wsave(2*l+15+4*n),ci,sum
c
        ci = (0,1)
        r1 = 1
        twopi = 2*4*atan(r1)
c
c
c       Determine the block lengths for the FFTs.
c
        call idd_ldiv(l,n,nblock)
c
c
        m = n/nblock
c
c
c       FFT each block of length nblock of v.
c
        do k = 1,m
          call dfftf(nblock,v(nblock*(k-1)+1),wsave)
        enddo ! k
c
c
c       Transpose v to obtain wsave(2*l+15+2*n+1 : 2*l+15+3*n).
c
        iii = 2*l+15+2*n
c
        do k = 1,m
          do j = 1,nblock/2-1
            wsave(iii+m*(j-1)+k) = v(nblock*(k-1)+2*j)
     1                           + ci*v(nblock*(k-1)+2*j+1)
          enddo ! j
        enddo ! k
c
c       Handle the purely real frequency components separately.
c
        do k = 1,m
          wsave(iii+m*(nblock/2-1)+k) = v(nblock*(k-1)+nblock)
          wsave(iii+m*(nblock/2)+k) = v(nblock*(k-1)+1)
        enddo ! k
c
c
c       Directly calculate the desired entries of v.
c
        ii = 2*l+15
c
        do j = 1,l
c
c
          i = ind(j)
c
c
          if(i .le. n/2-m/2) then
c
            idivm = (i-1)/m
            imodm = (i-1)-m*idivm
c
            sum = 0
c
            do k = 1,m
              sum = sum + wsave(iii+m*idivm+k) * wsave(ii+m*(j-1)+k)
            enddo ! k
c
            v(2*i-1) = sum
            v(2*i) = -ci*sum
c
          endif ! i .le. n/2-m/2
c
c
          if(i .gt. n/2-m/2) then
c
            if(i .lt. n/2) then
c
              idivm = i/(m/2)
              imodm = i-(m/2)*idivm
c
              sum = 0
c
              do k = 1,m
                sum = sum + wsave(iii+m*(nblock/2)+k)
     1              * wsave(ii+m*(j-1)+k)
              enddo ! k
c
              v(2*i-1) = sum
              v(2*i) = -ci*sum
c
            endif
c
            if(i .eq. n/2) then
c
              fact = 1/sqrt(r1*n)
c
c
              rsum = 0
c
              do k = 1,m
                rsum = rsum + wsave(iii+m*(nblock/2)+k)
              enddo ! k
c
              v(n-1) = rsum*fact
c
c
              rsum = 0
c
              do k = 1,m/2
                rsum = rsum + wsave(iii+m*(nblock/2)+2*k-1)
                rsum = rsum - wsave(iii+m*(nblock/2)+2*k)
              enddo ! k
c
              v(n) = rsum*fact
c
            endif
c
          endif ! i .gt. n/2-m/2
c
c
        enddo ! j
c
c
        return
        end