*DECK DLSEI
      SUBROUTINE DLSEI (W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME,
     +   RNORML, MODE, WS, IP)
C***BEGIN PROLOGUE  DLSEI
C***PURPOSE  Solve a linearly constrained least squares problem with
C            equality and inequality constraints, and optionally compute
C            a covariance matrix.
C***LIBRARY   SLATEC
C***CATEGORY  K1A2A, D9
C***TYPE      DOUBLE PRECISION (LSEI-S, DLSEI-D)
C***KEYWORDS  CONSTRAINED LEAST SQUARES, CURVE FITTING, DATA FITTING,
C             EQUALITY CONSTRAINTS, INEQUALITY CONSTRAINTS,
C             QUADRATIC PROGRAMMING
C***AUTHOR  Hanson, R. J., (SNLA)
C           Haskell, K. H., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     This subprogram solves a linearly constrained least squares
C     problem with both equality and inequality constraints, and, if the
C     user requests, obtains a covariance matrix of the solution
C     parameters.
C
C     Suppose there are given matrices E, A and G of respective
C     dimensions ME by N, MA by N and MG by N, and vectors F, B and H of
C     respective lengths ME, MA and MG.  This subroutine solves the
C     linearly constrained least squares problem
C
C                   EX = F, (E ME by N) (equations to be exactly
C                                       satisfied)
C                   AX = B, (A MA by N) (equations to be
C                                       approximately satisfied,
C                                       least squares sense)
C                   GX .GE. H,(G MG by N) (inequality constraints)
C
C     The inequalities GX .GE. H mean that every component of the
C     product GX must be .GE. the corresponding component of H.
C
C     In case the equality constraints cannot be satisfied, a
C     generalized inverse solution residual vector length is obtained
C     for F-EX.  This is the minimal length possible for F-EX.
C
C     Any values ME .GE. 0, MA .GE. 0, or MG .GE. 0 are permitted.  The
C     rank of the matrix E is estimated during the computation.  We call
C     this value KRANKE.  It is an output parameter in IP(1) defined
C     below.  Using a generalized inverse solution of EX=F, a reduced
C     least squares problem with inequality constraints is obtained.
C     The tolerances used in these tests for determining the rank
C     of E and the rank of the reduced least squares problem are
C     given in Sandia Tech. Rept. SAND-78-1290.  They can be
C     modified by the user if new values are provided in
C     the option list of the array PRGOPT(*).
C
C     The user must dimension all arrays appearing in the call list..
C     W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2)
C     where K=MAX(MA+MG,N).  This allows for a solution of a range of
C     problems in the given working space.  The dimension of WS(*)
C     given is a necessary overestimate.  Once a particular problem
C     has been run, the output parameter IP(3) gives the actual
C     dimension required for that problem.
C
C     The parameters for DLSEI( ) are
C
C     Input.. All TYPE REAL variables are DOUBLE PRECISION
C
C     W(*,*),MDW,   The array W(*,*) is doubly subscripted with
C     ME,MA,MG,N    first dimensioning parameter equal to MDW.
C                   For this discussion let us call M = ME+MA+MG.  Then
C                   MDW must satisfy MDW .GE. M.  The condition
C                   MDW .LT. M is an error.
C
C                   The array W(*,*) contains the matrices and vectors
C
C                                  (E  F)
C                                  (A  B)
C                                  (G  H)
C
C                   in rows and columns 1,...,M and 1,...,N+1
C                   respectively.
C
C                   The integers ME, MA, and MG are the
C                   respective matrix row dimensions
C                   of E, A and G.  Each matrix has N columns.
C
C     PRGOPT(*)    This real-valued array is the option vector.
C                  If the user is satisfied with the nominal
C                  subprogram features set
C
C                  PRGOPT(1)=1 (or PRGOPT(1)=1.0)
C
C                  Otherwise PRGOPT(*) is a linked list consisting of
C                  groups of data of the following form
C
C                  LINK
C                  KEY
C                  DATA SET
C
C                  The parameters LINK and KEY are each one word.
C                  The DATA SET can be comprised of several words.
C                  The number of items depends on the value of KEY.
C                  The value of LINK points to the first
C                  entry of the next group of data within
C                  PRGOPT(*).  The exception is when there are
C                  no more options to change.  In that
C                  case, LINK=1 and the values KEY and DATA SET
C                  are not referenced.  The general layout of
C                  PRGOPT(*) is as follows.
C
C               ...PRGOPT(1) = LINK1 (link to first entry of next group)
C               .  PRGOPT(2) = KEY1 (key to the option change)
C               .  PRGOPT(3) = data value (data value for this change)
C               .       .
C               .       .
C               .       .
C               ...PRGOPT(LINK1)   = LINK2 (link to the first entry of
C               .                       next group)
C               .  PRGOPT(LINK1+1) = KEY2 (key to the option change)
C               .  PRGOPT(LINK1+2) = data value
C               ...     .
C               .       .
C               .       .
C               ...PRGOPT(LINK) = 1 (no more options to change)
C
C                  Values of LINK that are nonpositive are errors.
C                  A value of LINK .GT. NLINK=100000 is also an error.
C                  This helps prevent using invalid but positive
C                  values of LINK that will probably extend
C                  beyond the program limits of PRGOPT(*).
C                  Unrecognized values of KEY are ignored.  The
C                  order of the options is arbitrary and any number
C                  of options can be changed with the following
C                  restriction.  To prevent cycling in the
C                  processing of the option array, a count of the
C                  number of options changed is maintained.
C                  Whenever this count exceeds NOPT=1000, an error
C                  message is printed and the subprogram returns.
C
C                  Options..
C
C                  KEY=1
C                         Compute in W(*,*) the N by N
C                  covariance matrix of the solution variables
C                  as an output parameter.  Nominally the
C                  covariance matrix will not be computed.
C                  (This requires no user input.)
C                  The data set for this option is a single value.
C                  It must be nonzero when the covariance matrix
C                  is desired.  If it is zero, the covariance
C                  matrix is not computed.  When the covariance matrix
C                  is computed, the first dimensioning parameter
C                  of the array W(*,*) must satisfy MDW .GE. MAX(M,N).
C
C                  KEY=10
C                         Suppress scaling of the inverse of the
C                  normal matrix by the scale factor RNORM**2/
C                  MAX(1, no. of degrees of freedom).  This option
C                  only applies when the option for computing the
C                  covariance matrix (KEY=1) is used.  With KEY=1 and
C                  KEY=10 used as options the unscaled inverse of the
C                  normal matrix is returned in W(*,*).
C                  The data set for this option is a single value.
C                  When it is nonzero no scaling is done.  When it is
C                  zero scaling is done.  The nominal case is to do
C                  scaling so if option (KEY=1) is used alone, the
C                  matrix will be scaled on output.
C
C                  KEY=2
C                         Scale the nonzero columns of the
C                         entire data matrix.
C                  (E)
C                  (A)
C                  (G)
C
C                  to have length one.  The data set for this
C                  option is a single value.  It must be
C                  nonzero if unit length column scaling
C                  is desired.
C
C                  KEY=3
C                         Scale columns of the entire data matrix
C                  (E)
C                  (A)
C                  (G)
C
C                  with a user-provided diagonal matrix.
C                  The data set for this option consists
C                  of the N diagonal scaling factors, one for
C                  each matrix column.
C
C                  KEY=4
C                         Change the rank determination tolerance for
C                  the equality constraint equations from
C                  the nominal value of SQRT(DRELPR).  This quantity can
C                  be no smaller than DRELPR, the arithmetic-
C                  storage precision.  The quantity DRELPR is the
C                  largest positive number such that T=1.+DRELPR
C                  satisfies T .EQ. 1.  The quantity used
C                  here is internally restricted to be at
C                  least DRELPR.  The data set for this option
C                  is the new tolerance.
C
C                  KEY=5
C                         Change the rank determination tolerance for
C                  the reduced least squares equations from
C                  the nominal value of SQRT(DRELPR).  This quantity can
C                  be no smaller than DRELPR, the arithmetic-
C                  storage precision.  The quantity used
C                  here is internally restricted to be at
C                  least DRELPR.  The data set for this option
C                  is the new tolerance.
C
C                  For example, suppose we want to change
C                  the tolerance for the reduced least squares
C                  problem, compute the covariance matrix of
C                  the solution parameters, and provide
C                  column scaling for the data matrix.  For
C                  these options the dimension of PRGOPT(*)
C                  must be at least N+9.  The Fortran statements
C                  defining these options would be as follows:
C
C                  PRGOPT(1)=4 (link to entry 4 in PRGOPT(*))
C                  PRGOPT(2)=1 (covariance matrix key)
C                  PRGOPT(3)=1 (covariance matrix wanted)
C
C                  PRGOPT(4)=7 (link to entry 7 in PRGOPT(*))
C                  PRGOPT(5)=5 (least squares equas.  tolerance key)
C                  PRGOPT(6)=... (new value of the tolerance)
C
C                  PRGOPT(7)=N+9 (link to entry N+9 in PRGOPT(*))
C                  PRGOPT(8)=3 (user-provided column scaling key)
C
C                  CALL DCOPY (N, D, 1, PRGOPT(9), 1)  (Copy the N
C                    scaling factors from the user array D(*)
C                    to PRGOPT(9)-PRGOPT(N+8))
C
C                  PRGOPT(N+9)=1 (no more options to change)
C
C                  The contents of PRGOPT(*) are not modified
C                  by the subprogram.
C                  The options for WNNLS( ) can also be included
C                  in this array.  The values of KEY recognized
C                  by WNNLS( ) are 6, 7 and 8.  Their functions
C                  are documented in the usage instructions for
C                  subroutine WNNLS( ).  Normally these options
C                  do not need to be modified when using DLSEI( ).
C
C     IP(1),       The amounts of working storage actually
C     IP(2)        allocated for the working arrays WS(*) and
C                  IP(*), respectively.  These quantities are
C                  compared with the actual amounts of storage
C                  needed by DLSEI( ).  Insufficient storage
C                  allocated for either WS(*) or IP(*) is an
C                  error.  This feature was included in DLSEI( )
C                  because miscalculating the storage formulas
C                  for WS(*) and IP(*) might very well lead to
C                  subtle and hard-to-find execution errors.
C
C                  The length of WS(*) must be at least
C
C                  LW = 2*(ME+N)+K+(MG+2)*(N+7)
C
C                  where K = max(MA+MG,N)
C                  This test will not be made if IP(1).LE.0.
C
C                  The length of IP(*) must be at least
C
C                  LIP = MG+2*N+2
C                  This test will not be made if IP(2).LE.0.
C
C     Output.. All TYPE REAL variables are DOUBLE PRECISION
C
C     X(*),RNORME,  The array X(*) contains the solution parameters
C     RNORML        if the integer output flag MODE = 0 or 1.
C                   The definition of MODE is given directly below.
C                   When MODE = 0 or 1, RNORME and RNORML
C                   respectively contain the residual vector
C                   Euclidean lengths of F - EX and B - AX.  When
C                   MODE=1 the equality constraint equations EX=F
C                   are contradictory, so RNORME .NE. 0.  The residual
C                   vector F-EX has minimal Euclidean length.  For
C                   MODE .GE. 2, none of these parameters is defined.
C
C     MODE          Integer flag that indicates the subprogram
C                   status after completion.  If MODE .GE. 2, no
C                   solution has been computed.
C
C                   MODE =
C
C                   0  Both equality and inequality constraints
C                      are compatible and have been satisfied.
C
C                   1  Equality constraints are contradictory.
C                      A generalized inverse solution of EX=F was used
C                      to minimize the residual vector length F-EX.
C                      In this sense, the solution is still meaningful.
C
C                   2  Inequality constraints are contradictory.
C
C                   3  Both equality and inequality constraints
C                      are contradictory.
C
C                   The following interpretation of
C                   MODE=1,2 or 3 must be made.  The
C                   sets consisting of all solutions
C                   of the equality constraints EX=F
C                   and all vectors satisfying GX .GE. H
C                   have no points in common.  (In
C                   particular this does not say that
C                   each individual set has no points
C                   at all, although this could be the
C                   case.)
C
C                   4  Usage error occurred.  The value
C                      of MDW is .LT. ME+MA+MG, MDW is
C                      .LT. N and a covariance matrix is
C                      requested, or the option vector
C                      PRGOPT(*) is not properly defined,
C                      or the lengths of the working arrays
C                      WS(*) and IP(*), when specified in
C                      IP(1) and IP(2) respectively, are not
C                      long enough.
C
C     W(*,*)        The array W(*,*) contains the N by N symmetric
C                   covariance matrix of the solution parameters,
C                   provided this was requested on input with
C                   the option vector PRGOPT(*) and the output
C                   flag is returned with MODE = 0 or 1.
C
C     IP(*)         The integer working array has three entries
C                   that provide rank and working array length
C                   information after completion.
C
C                      IP(1) = rank of equality constraint
C                              matrix.  Define this quantity
C                              as KRANKE.
C
C                      IP(2) = rank of reduced least squares
C                              problem.
C
C                      IP(3) = the amount of storage in the
C                              working array WS(*) that was
C                              actually used by the subprogram.
C                              The formula given above for the length
C                              of WS(*) is a necessary overestimate.
C                              If exactly the same problem matrices
C                              are used in subsequent executions,
C                              the declared dimension of WS(*) can
C                              be reduced to this output value.
C     User Designated
C     Working Arrays..
C
C     WS(*),IP(*)              These are respectively type real
C                              and type integer working arrays.
C                              Their required minimal lengths are
C                              given above.
C
C***REFERENCES  K. H. Haskell and R. J. Hanson, An algorithm for
C                 linear least squares problems with equality and
C                 nonnegativity constraints, Report SAND77-0552, Sandia
C                 Laboratories, June 1978.
C               K. H. Haskell and R. J. Hanson, Selected algorithms for
C                 the linearly constrained least squares problem - a
C                 users guide, Report SAND78-1290, Sandia Laboratories,
C                 August 1979.
C               K. H. Haskell and R. J. Hanson, An algorithm for
C                 linear least squares problems with equality and
C                 nonnegativity constraints, Mathematical Programming
C                 21 (1981), pp. 98-118.
C               R. J. Hanson and K. H. Haskell, Two algorithms for the
C                 linearly constrained least squares problem, ACM
C                 Transactions on Mathematical Software, September 1982.
C***ROUTINES CALLED  D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI,
C                    DNRM2, DSCAL, DSWAP, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890618  Completely restructured and extensively revised (WRB & RWC)
C   890831  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   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   900604  DP version created from SP version.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DLSEI
      INTEGER IP(3), MA, MDW, ME, MG, MODE, N
      DOUBLE PRECISION PRGOPT(*), RNORME, RNORML, W(MDW,*), WS(*), X(*)
C
      EXTERNAL D1MACH, DASUM, DAXPY, DCOPY, DDOT, DH12, DLSI, DNRM2,
     *   DSCAL, DSWAP, XERMSG
      DOUBLE PRECISION D1MACH, DASUM, DDOT, DNRM2
C
      DOUBLE PRECISION DRELPR, ENORM, FNORM, GAM, RB, RN, RNMAX, SIZE,
     *   SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME
      INTEGER I, IMAX, J, JP1, K, KEY, KRANKE, LAST, LCHK, LINK, M,
     *   MAPKE1, MDEQC, MEND, MEP1, N1, N2, NEXT, NLINK, NOPT, NP1,
     *   NTIMES
      LOGICAL COV, FIRST
      CHARACTER*8 XERN1, XERN2, XERN3, XERN4
      SAVE FIRST, DRELPR
C
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DLSEI
C
C     Set the nominal tolerance used in the code for the equality
C     constraint equations.
C
      IF (FIRST) DRELPR = D1MACH(4)
      FIRST = .FALSE.
      TAU = SQRT(DRELPR)
C
C     Check that enough storage was allocated in WS(*) and IP(*).
C
      MODE = 4
      IF (MIN(N,ME,MA,MG) .LT. 0) THEN
         WRITE (XERN1, '(I8)') N
         WRITE (XERN2, '(I8)') ME
         WRITE (XERN3, '(I8)') MA
         WRITE (XERN4, '(I8)') MG
         CALL XERMSG ('SLATEC', 'LSEI', 'ALL OF THE VARIABLES N, ME,' //
     *      ' MA, MG MUST BE .GE. 0$$ENTERED ROUTINE WITH' //
     *      '$$N  = ' // XERN1 //
     *      '$$ME = ' // XERN2 //
     *      '$$MA = ' // XERN3 //
     *      '$$MG = ' // XERN4, 2, 1)
         RETURN
      ENDIF
C
      IF (IP(1).GT.0) THEN
         LCHK = 2*(ME+N) + MAX(MA+MG,N) + (MG+2)*(N+7)
         IF (IP(1).LT.LCHK) THEN
            WRITE (XERN1, '(I8)') LCHK
            CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' //
     *         'ALLOCATED FOR WS(*), NEED LW = ' // XERN1, 2, 1)
            RETURN
         ENDIF
      ENDIF
C
      IF (IP(2).GT.0) THEN
         LCHK = MG + 2*N + 2
         IF (IP(2).LT.LCHK) THEN
            WRITE (XERN1, '(I8)') LCHK
            CALL XERMSG ('SLATEC', 'DLSEI', 'INSUFFICIENT STORAGE ' //
     *         'ALLOCATED FOR IP(*), NEED LIP = ' // XERN1, 2, 1)
            RETURN
         ENDIF
      ENDIF
C
C     Compute number of possible right multiplying Householder
C     transformations.
C
      M = ME + MA + MG
      IF (N.LE.0 .OR. M.LE.0) THEN
         MODE = 0
         RNORME = 0
         RNORML = 0
         RETURN
      ENDIF
C
      IF (MDW.LT.M) THEN
         CALL XERMSG ('SLATEC', 'DLSEI', 'MDW.LT.ME+MA+MG IS AN ERROR',
     +      2, 1)
         RETURN
      ENDIF
C
      NP1 = N + 1
      KRANKE = MIN(ME,N)
      N1 = 2*KRANKE + 1
      N2 = N1 + N
C
C     Set nominal values.
C
C     The nominal column scaling used in the code is
C     the identity scaling.
C
      CALL DCOPY (N, 1.D0, 0, WS(N1), 1)
C
C     No covariance matrix is nominally computed.
C
      COV = .FALSE.
C
C     Process option vector.
C     Define bound for number of options to change.
C
      NOPT = 1000
      NTIMES = 0
C
C     Define bound for positive values of LINK.
C
      NLINK = 100000
      LAST = 1
      LINK = PRGOPT(1)
      IF (LINK.EQ.0 .OR. LINK.GT.NLINK) THEN
         CALL XERMSG ('SLATEC', 'DLSEI',
     +      'THE OPTION VECTOR IS UNDEFINED', 2, 1)
         RETURN
      ENDIF
C
  100 IF (LINK.GT.1) THEN
         NTIMES = NTIMES + 1
         IF (NTIMES.GT.NOPT) THEN
            CALL XERMSG ('SLATEC', 'DLSEI',
     +         'THE LINKS IN THE OPTION VECTOR ARE CYCLING.', 2, 1)
            RETURN
         ENDIF
C
         KEY = PRGOPT(LAST+1)
         IF (KEY.EQ.1) THEN
            COV = PRGOPT(LAST+2) .NE. 0.D0
         ELSEIF (KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.0.D0) THEN
            DO 110 J = 1,N
               T = DNRM2(M,W(1,J),1)
               IF (T.NE.0.D0) T = 1.D0/T
               WS(J+N1-1) = T
  110       CONTINUE
         ELSEIF (KEY.EQ.3) THEN
            CALL DCOPY (N, PRGOPT(LAST+2), 1, WS(N1), 1)
         ELSEIF (KEY.EQ.4) THEN
            TAU = MAX(DRELPR,PRGOPT(LAST+2))
         ENDIF
C
         NEXT = PRGOPT(LINK)
         IF (NEXT.LE.0 .OR. NEXT.GT.NLINK) THEN
         CALL XERMSG ('SLATEC', 'DLSEI',
     +      'THE OPTION VECTOR IS UNDEFINED', 2, 1)
            RETURN
         ENDIF
C
         LAST = LINK
         LINK = NEXT
         GO TO 100
      ENDIF
C
      DO 120 J = 1,N
         CALL DSCAL (M, WS(N1+J-1), W(1,J), 1)
  120 CONTINUE
C
      IF (COV .AND. MDW.LT.N) THEN
         CALL XERMSG ('SLATEC', 'DLSEI',
     +      'MDW .LT. N WHEN COV MATRIX NEEDED, IS AN ERROR', 2, 1)
         RETURN
      ENDIF
C
C     Problem definition and option vector OK.
C
      MODE = 0
C
C     Compute norm of equality constraint matrix and right side.
C
      ENORM = 0.D0
      DO 130 J = 1,N
         ENORM = MAX(ENORM,DASUM(ME,W(1,J),1))
  130 CONTINUE
C
      FNORM = DASUM(ME,W(1,NP1),1)
      SNMAX = 0.D0
      RNMAX = 0.D0
      DO 150 I = 1,KRANKE
C
C        Compute maximum ratio of vector lengths. Partition is at
C        column I.
C
         DO 140 K = I,ME
            SN = DDOT(N-I+1,W(K,I),MDW,W(K,I),MDW)
            RN = DDOT(I-1,W(K,1),MDW,W(K,1),MDW)
            IF (RN.EQ.0.D0 .AND. SN.GT.SNMAX) THEN
               SNMAX = SN
               IMAX = K
            ELSEIF (K.EQ.I .OR. SN*RNMAX.GT.RN*SNMAX) THEN
               SNMAX = SN
               RNMAX = RN
               IMAX = K
            ENDIF
  140    CONTINUE
C
C        Interchange rows if necessary.
C
         IF (I.NE.IMAX) CALL DSWAP (NP1, W(I,1), MDW, W(IMAX,1), MDW)
         IF (SNMAX.GT.RNMAX*TAU**2) THEN
C
C        Eliminate elements I+1,...,N in row I.
C
            CALL DH12 (1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW,
     +                1, M-I)
         ELSE
            KRANKE = I - 1
            GO TO 160
         ENDIF
  150 CONTINUE
C
C     Save diagonal terms of lower trapezoidal matrix.
C
  160 CALL DCOPY (KRANKE, W, MDW+1, WS(KRANKE+1), 1)
C
C     Use Householder transformation from left to achieve
C     KRANKE by KRANKE upper triangular form.
C
      IF (KRANKE.LT.ME) THEN
         DO 170 K = KRANKE,1,-1
C
C           Apply transformation to matrix cols. 1,...,K-1.
C
            CALL DH12 (1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW,
     *         K-1)
C
C           Apply to rt side vector.
C
            CALL DH12 (2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1,
     +         1, 1)
  170    CONTINUE
      ENDIF
C
C     Solve for variables 1,...,KRANKE in new coordinates.
C
      CALL DCOPY (KRANKE, W(1, NP1), 1, X, 1)
      DO 180 I = 1,KRANKE
         X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I)
  180 CONTINUE
C
C     Compute residuals for reduced problem.
C
      MEP1 = ME + 1
      RNORML = 0.D0
      DO 190 I = MEP1,M
         W(I,NP1) = W(I,NP1) - DDOT(KRANKE,W(I,1),MDW,X,1)
         SN = DDOT(KRANKE,W(I,1),MDW,W(I,1),MDW)
         RN = DDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW)
         IF (RN.LE.SN*TAU**2 .AND. KRANKE.LT.N)
     *      CALL DCOPY (N-KRANKE, 0.D0, 0, W(I,KRANKE+1), MDW)
  190 CONTINUE
C
C     Compute equality constraint equations residual length.
C
      RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1)
C
C     Move reduced problem data upward if KRANKE.LT.ME.
C
      IF (KRANKE.LT.ME) THEN
         DO 200 J = 1,NP1
            CALL DCOPY (M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1)
  200    CONTINUE
      ENDIF
C
C     Compute solution of reduced problem.
C
      CALL DLSI(W(KRANKE+1, KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT,
     +         X(KRANKE+1), RNORML, MODE, WS(N2), IP(2))
C
C     Test for consistency of equality constraints.
C
      IF (ME.GT.0) THEN
         MDEQC = 0
         XNRME = DASUM(KRANKE,W(1,NP1),1)
         IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1
         MODE = MODE + MDEQC
C
C        Check if solution to equality constraints satisfies inequality
C        constraints when there are no degrees of freedom left.
C
         IF (KRANKE.EQ.N .AND. MG.GT.0) THEN
            XNORM = DASUM(N,X,1)
            MAPKE1 = MA + KRANKE + 1
            MEND = MA + KRANKE + MG
            DO 210 I = MAPKE1,MEND
               SIZE = DASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1))
               IF (W(I,NP1).GT.TAU*SIZE) THEN
                  MODE = MODE + 2
                  GO TO 290
               ENDIF
  210       CONTINUE
         ENDIF
      ENDIF
C
C     Replace diagonal terms of lower trapezoidal matrix.
C
      IF (KRANKE.GT.0) THEN
         CALL DCOPY (KRANKE, WS(KRANKE+1), 1, W, MDW+1)
C
C        Reapply transformation to put solution in original coordinates.
C
         DO 220 I = KRANKE,1,-1
            CALL DH12 (2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1)
  220    CONTINUE
C
C        Compute covariance matrix of equality constrained problem.
C
         IF (COV) THEN
            DO 270 J = MIN(KRANKE,N-1),1,-1
               RB = WS(J)*W(J,J)
               IF (RB.NE.0.D0) RB = 1.D0/RB
               JP1 = J + 1
               DO 230 I = JP1,N
                  W(I,J) = RB*DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW)
  230          CONTINUE
C
               GAM = 0.5D0*RB*DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW)
               CALL DAXPY (N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1)
               DO 250 I = JP1,N
                  DO 240 K = I,N
                     W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K)
                     W(K,I) = W(I,K)
  240             CONTINUE
  250          CONTINUE
               UJ = WS(J)
               VJ = GAM*UJ
               W(J,J) = UJ*VJ + UJ*VJ
               DO 260 I = JP1,N
                  W(J,I) = UJ*W(I,J) + VJ*W(J,I)
  260          CONTINUE
               CALL DCOPY (N-J, W(J, JP1), MDW, W(JP1,J), 1)
  270       CONTINUE
         ENDIF
      ENDIF
C
C     Apply the scaling to the covariance matrix.
C
      IF (COV) THEN
         DO 280 I = 1,N
            CALL DSCAL (N, WS(I+N1-1), W(I,1), MDW)
            CALL DSCAL (N, WS(I+N1-1), W(1,I), 1)
  280    CONTINUE
      ENDIF
C
C     Rescale solution vector.
C
  290 IF (MODE.LE.1) THEN
         DO 300 J = 1,N
            X(J) = X(J)*WS(N1+J-1)
  300    CONTINUE
      ENDIF
C
      IP(1) = KRANKE
      IP(3) = IP(3) + 2*KRANKE + N
      RETURN
      END


	SUBROUTINE GSMPRJ  (  proj,  angl1,  angl2,  angl3,
     +			     dlatll, dlonll, dlatur, dlonur, iret )
C************************************************************************
C* GSMPRJ								*
C*									*
C* This subroutine provides a general way to specify the map projection	*
C* and bounds to be used when plotting in map coordinates.  The		*
C* subroutine now uses a character projection name rather than map 	*
C* class and projection numbers.  The valid projection names are:	*
C*									*
C*            CLASS      PROJ        PROJECTION				*
C*									*
C*      Cylindrical       CED        Cylindrical equidistant		*
C*                        MER        Mercator				*
C*                        MCD        Modified cylind. equidistant	*
C*									*
C*        Azimuthal       AED        Azimuthal equidistant		*
C*                        STR        Stereographic			*
C*                        ORT        Orthographic			*
C*                        LEA        Lambert equal area			*
C*                        GNO        Gnomonic				*
C*									*
C*          Conical       LCC        North Lambert conic conformal	*
C*                        SCC        South Lambert conic conformal	*
C*									*
C* Oblique Mercator       TVM        Transverse Mercator		*
C*                        UTM        Universal Transverse Mercator	*
C*									*
C* For the UTM projection, the tangential longitude is adjusted to	*
C* a standard longitude by rounding down to ..., -9, -3, 3, 9, ...	*
C*									*
C* The angles are defined for the various map classes.			*
C*									*
C*      Cylindrical       angle1 -- latitude of origin on projection	*
C*				    cylinder (0 = Equator)		*
C*                        angle2 -- longitude of origin on projection	*
C*				    cylinder (0 = Greenwich meridian)	*
C*			  angle3 -- angle to rotate projection about a 	*
C*				    line from the Earth's center thru	*
C*				    the origin point.			*
C*									*
C*        Azimuthal       angle1 -- latitude of projection's point of	*
C*				    tangency (pole latitude)		*
C*                        angle2 -- longitude of projection's point of	*
C*				    tangency (the central longitude)	*
C*                        angle3 -- angle to rotate projection about a  *
C*				    line from the Earth's center thru	*
C*				    the point of tangency		*
C*									*
C*         Conical        angle1 -- standard latitude 1			*
C*                        angle2 -- polon (the central longitude)	*
C*                        angle3 -- standard latitude 2			*
C*									*
C*         Oblique        angle1 -- tangential longitude		*
C*                        angle2 -- not used				*
C*                        angle3 -- not used				*
C*									*
C* Azimuthal and conic projections which include the pole, can be 	*
C* defined by specifying the lower left and upper right corners.  If	*
C* DLATLL and DLATUR are equal and DLONLL and DLONUR are also equal,	*
C* a map area will be defined which includes the area from the pole 	*
C* to the given latitude in each direction with DLONLL as the central	*
C* longitude.								*
C*									*
C* GSMPRJ  ( PROJ, ANGL1, ANGL2, ANGL3, DLATLL, DLONLL, 		*
C*           DLATUR, DLONUR, IRET )					*
C*									*
C* Input parameters:							*
C*	PROJ		CHAR*		Map projection name		*
C*	ANGL1		REAL		Reference angle 1		*
C*	ANGL2		REAL		Reference angle 2		*
C*	ANGL3		REAL		Reference angle 3		*
C*	DLATLL		REAL		Lower left latitude		*
C*	DLONLL		REAL		Lower left longitude		*
C*	DLATUR		REAL		Upper right latitude		*
C*	DLONUR		REAL		Upper right longitude		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 3/82						*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 6/88	Changed projection to character		*
C* K. Brill/NMC		07/91	Documentation changed			*
C* S. Jacobs/NMC	 1/95	Added multi-window common block		*
C* K. Brill/EMC		 6/98	Documentation				*
C************************************************************************
	INCLUDE 	'ERROR.PRM'
	INCLUDE		'XYDEF.CMN'
	INCLUDE		'DEVWIN.CMN'
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	proj
C*
	CHARACTER	cprj*4
C------------------------------------------------------------------------
C*	Check that map mode has been set.
C
	IF  ( igmode .ne. 1 )  THEN
	    iret = NIMODE
	  ELSE
C
C*	    Save input values.
C
	    CALL ST_LCUC  ( proj, cprj, ier )
	    prjnam = cprj
	    IF  ( cprj .eq. 'CED' )  THEN
		mclass = 1
		mproj  = 1
	      ELSE IF  ( cprj .eq. 'MER' )  THEN
		mclass = 1
		mproj  = 2
	      ELSE IF  ( cprj .eq. 'MCD' )  THEN
		mclass = 1
		mproj  = 3
	      ELSE IF  ( cprj .eq. 'AED' )  THEN
		mclass = 2
		mproj  = 1
	      ELSE IF  ( cprj .eq. 'STR' )  THEN
		mclass = 2
		mproj  = 2
	      ELSE IF  ( cprj .eq. 'ORT' )  THEN
		mclass = 2
		mproj  = 3
	      ELSE IF  ( cprj .eq. 'LEA' )  THEN
		mclass = 2
		mproj  = 4
	      ELSE IF  ( cprj .eq. 'GNO' )  THEN
		mclass = 2
		mproj  = 5
	      ELSE IF  ( cprj .eq. 'LCC' )  THEN
		mclass = 3
		mproj  = 1
	      ELSE IF  ( cprj .eq. 'SCC' )  THEN
		mclass = 3
		mproj  = 2
	      ELSE IF  ( cprj .eq. 'TVM' )  THEN
		mclass = 4
		mproj  = 1
	      ELSE IF  ( cprj .eq. 'UTM' )  THEN
		mclass = 4
		mproj  = 2
	    END IF
	    msppj  = 0
	    mtype  = 2
	    angle1 = angl1
	    angle2 = angl2
	    angle3 = angl3
	    anglr1 = angle1 * DTR
	    anglr2 = angle2 * DTR
	    anglr3 = angle3 * DTR
C
C*	    Save bounds.
C
	    clats = dlatll
	    clonw = dlonll
	    clatn = dlatur
	    clone = dlonur
C
C*	    Set up map projection and fit on device.
C
	    CALL UPDMAP ( iret )
	    IF  ( iret .eq. NORMAL ) CALL UPDPXY
	END IF
C
C*	Check for valid map projection set.
C
	IF  ( iret .ne. NORMAL )  THEN
	    mset  = .false.
	    mtype = 0
	ELSE
C
C*	    Save common variables for window.
C
	    nmode  (ncurwn) = igmode
	    wcproj (ncurwn) = cprj
	    uangle (ncurwn,1) = angl1
	    uangle (ncurwn,2) = angl2
	    uangle (ncurwn,3) = angl3
	    ulatll (ncurwn) = dlatll
	    ulonll (ncurwn) = dlonll
	    ulatur (ncurwn) = dlatur
	    ulonur (ncurwn) = dlonur
	END IF
C*
	RETURN
	END


      program DRSPOI
c>> 2001-05-25 DRSCDPOI Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRSCDPOI Krogh  Changed Fortran 90 code.
c>> 1994-10-19 DRSCDPOI Krogh  Changes to use M77CON
c>> 1994-07-06 DRSCDPOI WVS set up for chgtyp
c
c     Evaluate the Probability Function Q(n,lamda) of the Poisson
c     distribution by using SCDPOI.
c
c--S replaces "?": DR?POI, DR?CDPOI, ?cdpoi, ?gamik
      real             LAMDAS(4), P, Q(4)
      integer J, N, IERR
      data LAMDAS /0.5e0, 1.0e0, 1.5e0, 2.0e0/
c
10    format ('     Poisson Probability Function Q(lamda | n)'/
     1        '  N    LAMDA =',4f14.7/)
30    format (i3,15x,1p,4g14.7)
      call sgamik (0.0e0, 0.0e0, 0.0e0, 0)
      print 10, lamdas
      do 50 n = 1, 10
         do 40  j = 1, 4
            call scdpoi (n, lamdas(j), p, q(j), ierr)
40       continue
         print 30, n, q
50    continue
      stop
      end


program probability
use wood
use wood_pot, only : search_forest_pot => search_forest
use func
use dir
implicit none

integer, allocatable :: G(:,:), forest(:,:), tree(:,:), forest_pot(:,:), G_t(:,:), V(:,:)
integer :: root, k, i, j
logical :: check_potential
character(3) :: wood_answer, mst_answer

! Инициализация папок
call dir_init

! Считываем граф и корень из файла (0 -- нулевое ребро, -1 -- отсутствие ребра)
call get_graph(G, root)

check_potential = .true.
G_t = transpose(G)

do i = 1, size(G,1)
  do j = 1, size(G,1)
    if (G(i,j) /= G_t(i,j) .and. check_potential) then
      check_potential = .false.
    endif
  enddo
enddo

! Ask the number of connected components
write(*,*) '-- k = ?'
read(*,*) k
if (check_potential) then
  write(*,*) '-- Built for potential graph!'
  allocate(V(size(G,1),size(G,1)))

  do i = 1, size(G,1)
    if (G(i,i) > 0) then
      V(i,:) = G(i,:) - G(i,i)
    else
      V(i,:) = G(i,:)
    endif
    V(i,i) = -1
  enddo

  call search_forest_pot(G, k, forest_pot)

  call print_graph('origin_wood_pot.eps', V, forest_pot, .true.)
  call print_graph('wood_pot.eps', forest_pot, forest_pot, .false.)
  call print_nondirected_graph('nondirected_graph.eps', G)

else

  write(*,*) '-- Built for non-potential graph!'
  write(*,*) '-- Should I build MST?'
  read(*,*) mst_answer
  if (mst_answer(:1) == "y") then
    if (check(G, root)) then
      write(*,*) '-- MST succesfully was built!'
      call chinese(G, root, tree)
      call print_graph('G.eps', G, tree, .false.)
      call print_graph('origin_tree.eps', G, tree, .true.)

      ! open(20, file = trim(dir_name) // 'tree.txt', status = 'NEW')
      ! do i = 1, size(G,1)
      ! 	write(20,*) tree(i,:)
      ! enddo
      ! close(20)

    else
      write(*,*) '-- Несвязный с таким корнем!'
    endif
  endif

  write(*,*) '-- Should I build forest?'
  read(*,*) wood_answer

  if (wood_answer(:1) == "y") then
    call search_forest(G, k, forest)

    call print_graph('forest.eps', forest, forest, .false.)
    call print_graph('origin_wood.eps', G, forest, .true.)
  endif
endif

end program probability


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
program main
  !! author: Damian Rouson and Xiaofeng Xu
  !! date: 2/24/2020
  !!
  !! Test implicit time advancement of the unsteady, 1D spherical heat equation
  use spherical_1D_solver_module, only : spherical_1D_solver
  use kind_parameters, only : r8k
  implicit none

  type(spherical_1D_solver) conducting_sphere

  call conducting_sphere%set_v( nr = 101, constants = [0._r8k, 1073.15_r8k] )
  call conducting_sphere%set_expected_solution_size()
  call conducting_sphere%set_material_properties_size()
  call conducting_sphere%time_advance_heat_equation( duration = 100._r8k )

end program


!*==dbdsdc.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \brief \b DBDSDC
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DBDSDC + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
!                          WORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          COMPQ, UPLO
!       INTEGER            INFO, LDU, LDVT, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IQ( * ), IWORK( * )
!       DOUBLE PRECISION   D( * ), E( * ), Q( * ), U( LDU, * ),
!      $                   VT( LDVT, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DBDSDC computes the singular value decomposition (SVD) of a real
!> N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,
!> using a divide and conquer method, where S is a diagonal matrix
!> with non-negative diagonal elements (the singular values of B), and
!> U and VT are orthogonal matrices of left and right singular vectors,
!> respectively. DBDSDC can be used to compute all singular values,
!> and optionally, singular vectors or singular vectors in compact form.
!>
!> This code makes very mild assumptions about floating point
!> arithmetic. It will work on machines with a guard digit in
!> add/subtract, or on those binary machines without guard digits
!> which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
!> It could conceivably fail on hexadecimal or decimal machines
!> without guard digits, but we know of none.  See DLASD3 for details.
!>
!> The code currently calls DLASDQ if singular values only are desired.
!> However, it can be slightly modified to compute singular values
!> using the divide and conquer method.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  B is upper bidiagonal.
!>          = 'L':  B is lower bidiagonal.
!> \endverbatim
!>
!> \param[in] COMPQ
!> \verbatim
!>          COMPQ is CHARACTER*1
!>          Specifies whether singular vectors are to be computed
!>          as follows:
!>          = 'N':  Compute singular values only;
!>          = 'P':  Compute singular values and compute singular
!>                  vectors in compact form;
!>          = 'I':  Compute singular values and singular vectors.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix B.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>          On entry, the n diagonal elements of the bidiagonal matrix B.
!>          On exit, if INFO=0, the singular values of B.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          On entry, the elements of E contain the offdiagonal
!>          elements of the bidiagonal matrix whose SVD is desired.
!>          On exit, E has been destroyed.
!> \endverbatim
!>
!> \param[out] U
!> \verbatim
!>          U is DOUBLE PRECISION array, dimension (LDU,N)
!>          If  COMPQ = 'I', then:
!>             On exit, if INFO = 0, U contains the left singular vectors
!>             of the bidiagonal matrix.
!>          For other values of COMPQ, U is not referenced.
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>          The leading dimension of the array U.  LDU >= 1.
!>          If singular vectors are desired, then LDU >= max( 1, N ).
!> \endverbatim
!>
!> \param[out] VT
!> \verbatim
!>          VT is DOUBLE PRECISION array, dimension (LDVT,N)
!>          If  COMPQ = 'I', then:
!>             On exit, if INFO = 0, VT**T contains the right singular
!>             vectors of the bidiagonal matrix.
!>          For other values of COMPQ, VT is not referenced.
!> \endverbatim
!>
!> \param[in] LDVT
!> \verbatim
!>          LDVT is INTEGER
!>          The leading dimension of the array VT.  LDVT >= 1.
!>          If singular vectors are desired, then LDVT >= max( 1, N ).
!> \endverbatim
!>
!> \param[out] Q
!> \verbatim
!>          Q is DOUBLE PRECISION array, dimension (LDQ)
!>          If  COMPQ = 'P', then:
!>             On exit, if INFO = 0, Q and IQ contain the left
!>             and right singular vectors in a compact form,
!>             requiring O(N log N) space instead of 2*N**2.
!>             In particular, Q contains all the DOUBLE PRECISION data in
!>             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
!>             words of memory, where SMLSIZ is returned by ILAENV and
!>             is equal to the maximum size of the subproblems at the
!>             bottom of the computation tree (usually about 25).
!>          For other values of COMPQ, Q is not referenced.
!> \endverbatim
!>
!> \param[out] IQ
!> \verbatim
!>          IQ is INTEGER array, dimension (LDIQ)
!>          If  COMPQ = 'P', then:
!>             On exit, if INFO = 0, Q and IQ contain the left
!>             and right singular vectors in a compact form,
!>             requiring O(N log N) space instead of 2*N**2.
!>             In particular, IQ contains all INTEGER data in
!>             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
!>             words of memory, where SMLSIZ is returned by ILAENV and
!>             is equal to the maximum size of the subproblems at the
!>             bottom of the computation tree (usually about 25).
!>          For other values of COMPQ, IQ is not referenced.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          If COMPQ = 'N' then LWORK >= (4 * N).
!>          If COMPQ = 'P' then LWORK >= (6 * N).
!>          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (8*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit.
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  The algorithm failed to compute a singular value.
!>                The update process of divide and conquer failed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup auxOTHERcomputational
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Huan Ren, Computer Science Division, University of
!>     California at Berkeley, USA
!>
!  =====================================================================
      SUBROUTINE DBDSDC(Uplo,Compq,N,D,E,U,Ldu,Vt,Ldvt,Q,Iq,Work,Iwork, &
     &                  Info)
      IMPLICIT NONE
!*--DBDSDC210
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Compq , Uplo
      INTEGER Info , Ldu , Ldvt , N
!     ..
!     .. Array Arguments ..
      INTEGER Iq(*) , Iwork(*)
      DOUBLE PRECISION D(*) , E(*) , Q(*) , U(Ldu,*) , Vt(Ldvt,*) ,     &
     &                 Work(*)
!     ..
!
!  =====================================================================
!  Changed dimension statement in comment describing E from (N) to
!  (N-1).  Sven, 17 Feb 05.
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE , TWO
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0,TWO=2.0D+0)
!     ..
!     .. Local Scalars ..
      INTEGER difl , difr , givcol , givnum , givptr , i , ic , icompq ,&
     &        ierr , ii , is , iu , iuplo , ivt , j , k , kk , mlvl ,   &
     &        nm1 , nsize , perm , poles , qstart , smlsiz , smlszp ,   &
     &        sqre , start , wstart , z
      DOUBLE PRECISION cs , eps , orgnrm , p , r , sn
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , DLANST
      EXTERNAL LSAME , ILAENV , DLAMCH , DLANST
!     ..
!     .. External Subroutines ..
      EXTERNAL DCOPY , DLARTG , DLASCL , DLASD0 , DLASDA , DLASDQ ,     &
     &         DLASET , DLASR , DSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , INT , LOG , SIGN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
!
      iuplo = 0
      IF ( LSAME(Uplo,'U') ) iuplo = 1
      IF ( LSAME(Uplo,'L') ) iuplo = 2
      IF ( LSAME(Compq,'N') ) THEN
         icompq = 0
      ELSEIF ( LSAME(Compq,'P') ) THEN
         icompq = 1
      ELSEIF ( LSAME(Compq,'I') ) THEN
         icompq = 2
      ELSE
         icompq = -1
      ENDIF
      IF ( iuplo==0 ) THEN
         Info = -1
      ELSEIF ( icompq<0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( (Ldu<1) .OR. ((icompq==2) .AND. (Ldu<N)) ) THEN
         Info = -7
      ELSEIF ( (Ldvt<1) .OR. ((icompq==2) .AND. (Ldvt<N)) ) THEN
         Info = -9
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DBDSDC',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
      smlsiz = ILAENV(9,'DBDSDC',' ',0,0,0,0)
      IF ( N==1 ) THEN
         IF ( icompq==1 ) THEN
            Q(1) = SIGN(ONE,D(1))
            Q(1+smlsiz*N) = ONE
         ELSEIF ( icompq==2 ) THEN
            U(1,1) = SIGN(ONE,D(1))
            Vt(1,1) = ONE
         ENDIF
         D(1) = ABS(D(1))
         RETURN
      ENDIF
      nm1 = N - 1
!
!     If matrix lower bidiagonal, rotate to be upper bidiagonal
!     by applying Givens rotations on the left
!
      wstart = 1
      qstart = 3
      IF ( icompq==1 ) THEN
         CALL DCOPY(N,D,1,Q(1),1)
         CALL DCOPY(N-1,E,1,Q(N+1),1)
      ENDIF
      IF ( iuplo==2 ) THEN
         qstart = 5
         IF ( icompq==2 ) wstart = 2*N - 1
         DO i = 1 , N - 1
            CALL DLARTG(D(i),E(i),cs,sn,r)
            D(i) = r
            E(i) = sn*D(i+1)
            D(i+1) = cs*D(i+1)
            IF ( icompq==1 ) THEN
               Q(i+2*N) = cs
               Q(i+3*N) = sn
            ELSEIF ( icompq==2 ) THEN
               Work(i) = cs
               Work(nm1+i) = -sn
            ENDIF
         ENDDO
      ENDIF
!
!     If ICOMPQ = 0, use DLASDQ to compute the singular values.
!
      IF ( icompq==0 ) THEN
!        Ignore WSTART, instead using WORK( 1 ), since the two vectors
!        for CS and -SN above are added only if ICOMPQ == 2,
!        and adding them exceeds documented WORK size of 4*n.
         CALL DLASDQ('U',0,N,0,0,0,D,E,Vt,Ldvt,U,Ldu,U,Ldu,Work(1),Info)
         GOTO 100
      ENDIF
!
!     If N is smaller than the minimum divide size SMLSIZ, then solve
!     the problem with another solver.
!
      IF ( N<=smlsiz ) THEN
         IF ( icompq==2 ) THEN
            CALL DLASET('A',N,N,ZERO,ONE,U,Ldu)
            CALL DLASET('A',N,N,ZERO,ONE,Vt,Ldvt)
            CALL DLASDQ('U',0,N,N,N,0,D,E,Vt,Ldvt,U,Ldu,U,Ldu,          &
     &                  Work(wstart),Info)
         ELSEIF ( icompq==1 ) THEN
            iu = 1
            ivt = iu + N
            CALL DLASET('A',N,N,ZERO,ONE,Q(iu+(qstart-1)*N),N)
            CALL DLASET('A',N,N,ZERO,ONE,Q(ivt+(qstart-1)*N),N)
            CALL DLASDQ('U',0,N,N,N,0,D,E,Q(ivt+(qstart-1)*N),N,        &
     &                  Q(iu+(qstart-1)*N),N,Q(iu+(qstart-1)*N),N,      &
     &                  Work(wstart),Info)
         ENDIF
         GOTO 100
      ENDIF
!
      IF ( icompq==2 ) THEN
         CALL DLASET('A',N,N,ZERO,ONE,U,Ldu)
         CALL DLASET('A',N,N,ZERO,ONE,Vt,Ldvt)
      ENDIF
!
!     Scale.
!
      orgnrm = DLANST('M',N,D,E)
      IF ( orgnrm==ZERO ) RETURN
      CALL DLASCL('G',0,0,orgnrm,ONE,N,1,D,N,ierr)
      CALL DLASCL('G',0,0,orgnrm,ONE,nm1,1,E,nm1,ierr)
!
      eps = (0.9D+0)*DLAMCH('Epsilon')
!
      mlvl = INT(LOG(DBLE(N)/DBLE(smlsiz+1))/LOG(TWO)) + 1
      smlszp = smlsiz + 1
!
      IF ( icompq==1 ) THEN
         iu = 1
         ivt = 1 + smlsiz
         difl = ivt + smlszp
         difr = difl + mlvl
         z = difr + mlvl*2
         ic = z + mlvl
         is = ic + 1
         poles = is + 1
         givnum = poles + 2*mlvl
!
         k = 1
         givptr = 2
         perm = 3
         givcol = perm + mlvl
      ENDIF
!
      DO i = 1 , N
         IF ( ABS(D(i))<eps ) D(i) = SIGN(eps,D(i))
      ENDDO
!
      start = 1
      sqre = 0
!
      DO i = 1 , nm1
         IF ( (ABS(E(i))<eps) .OR. (i==nm1) ) THEN
!
!           Subproblem found. First determine its size and then
!           apply divide and conquer on it.
!
            IF ( i<nm1 ) THEN
!
!              A subproblem with E(I) small for I < NM1.
!
               nsize = i - start + 1
            ELSEIF ( ABS(E(i))>=eps ) THEN
!
!              A subproblem with E(NM1) not too small but I = NM1.
!
               nsize = N - start + 1
            ELSE
!
!              A subproblem with E(NM1) small. This implies an
!              1-by-1 subproblem at D(N). Solve this 1-by-1 problem
!              first.
!
               nsize = i - start + 1
               IF ( icompq==2 ) THEN
                  U(N,N) = SIGN(ONE,D(N))
                  Vt(N,N) = ONE
               ELSEIF ( icompq==1 ) THEN
                  Q(N+(qstart-1)*N) = SIGN(ONE,D(N))
                  Q(N+(smlsiz+qstart-1)*N) = ONE
               ENDIF
               D(N) = ABS(D(N))
            ENDIF
            IF ( icompq==2 ) THEN
               CALL DLASD0(nsize,sqre,D(start),E(start),U(start,start), &
     &                     Ldu,Vt(start,start),Ldvt,smlsiz,Iwork,       &
     &                     Work(wstart),Info)
            ELSE
               CALL DLASDA(icompq,smlsiz,nsize,sqre,D(start),E(start),  &
     &                     Q(start+(iu+qstart-2)*N),N,                  &
     &                     Q(start+(ivt+qstart-2)*N),Iq(start+k*N),     &
     &                     Q(start+(difl+qstart-2)*N),                  &
     &                     Q(start+(difr+qstart-2)*N),                  &
     &                     Q(start+(z+qstart-2)*N),                     &
     &                     Q(start+(poles+qstart-2)*N),                 &
     &                     Iq(start+givptr*N),Iq(start+givcol*N),N,     &
     &                     Iq(start+perm*N),Q(start+(givnum+qstart-2)*N)&
     &                     ,Q(start+(ic+qstart-2)*N),                   &
     &                     Q(start+(is+qstart-2)*N),Work(wstart),Iwork, &
     &                     Info)
            ENDIF
            IF ( Info/=0 ) RETURN
            start = i + 1
         ENDIF
      ENDDO
!
!     Unscale
!
      CALL DLASCL('G',0,0,ONE,orgnrm,N,1,D,N,ierr)
!
!     Use Selection Sort to minimize swaps of singular vectors
!
 100  DO ii = 2 , N
         i = ii - 1
         kk = i
         p = D(i)
         DO j = ii , N
            IF ( D(j)>p ) THEN
               kk = j
               p = D(j)
            ENDIF
         ENDDO
         IF ( kk/=i ) THEN
            D(kk) = D(i)
            D(i) = p
            IF ( icompq==1 ) THEN
               Iq(i) = kk
            ELSEIF ( icompq==2 ) THEN
               CALL DSWAP(N,U(1,i),1,U(1,kk),1)
               CALL DSWAP(N,Vt(i,1),Ldvt,Vt(kk,1),Ldvt)
            ENDIF
         ELSEIF ( icompq==1 ) THEN
            Iq(i) = i
         ENDIF
      ENDDO
!
!     If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
!
      IF ( icompq==1 ) THEN
         IF ( iuplo==1 ) THEN
            Iq(N) = 1
         ELSE
            Iq(N) = 0
         ENDIF
      ENDIF
!
!     If B is lower bidiagonal, update U by those Givens rotations
!     which rotated B to be upper bidiagonal
!
      IF ( (iuplo==2) .AND. (icompq==2) )                               &
     &     CALL DLASR('L','V','B',N,N,Work(1),Work(N),U,Ldu)
!
!
!     End of DBDSDC
!
      END SUBROUTINE DBDSDC


      SUBROUTINE PCHIM(N, X, F, D, INCFD, IERR)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER :: N, INCFD, IERR
      REAL(rprec), DIMENSION(N) :: X
      REAL(rprec), DIMENSION(INCFD,N) :: F, D
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, NLESS1
      REAL(rprec) :: R1, DEL1, DEL2, D_max, D_min
      REAL(rprec) :: DRAT1, DRAT2, DSAVE, H1, H2
      REAL(rprec) :: HSUM, HSUMT3, THREE, W1, W2, ZERO
!-----------------------------------------------
!   E x t e r n a l   F u n c t i o n s
!-----------------------------------------------
      REAL(rprec) , EXTERNAL :: PCHST
!-----------------------------------------------
!***BEGIN PROLOGUE  PCHIM
!***DATE WRITTEN   811103   (YYMMDD)
!***REVISION DATE  870707   (YYMMDD)
!***CATEGORY NO.  E1B
!***KEYWORDS  LIBRARY=SLATEC(PCHIP),
!             TYPE=SINGLE PRECISION(PCHIM-S DPCHIM-D),
!             CUBIC HERMITE INTERPOLATION,MONOTONE INTERPOLATION,
!             PIECEWISE CUBIC INTERPOLATION
!***AUTHOR  FRITSCH, F. N., (LLNL)
!             MATHEMATICS AND STATISTICS DIVISION
!             LAWRENCE LIVERMORE NATIONAL LABORATORY
!             P.O. BOX 808  (L-316)
!             LIVERMORE, CA  94550
!             FTS 532-4275, (415) 422-4275
!***PURPOSE  Set derivatives needed to determine a monotone piecewise
!            cubic Hermite interpolant to given data.  Boundary values
!            are provided which are compatible with monotonicity.  The
!            interpolant will have an extremum at each point where mono-
!            tonicity switches direction.  (See PCHIC IF user control is
!            desired over boundary or switch conditions.)
!***DESCRIPTION
!
!          PCHIM:  Piecewise Cubic Hermite Interpolation to
!                  Monotone data.
!
!     Sets derivatives needed to determine a monotone piecewise cubi!
!     Hermite interpolant to the data given in X and F.
!
!     Default boundary conditions are provided which are compatible
!     with monotonicity.  (See PCHIC IF user control of boundary con-
!     ditions is desired.)
!
!     If the data are ONLY piecewise monotonic, the interpolant will
!     have an extremum at each point where monotonicity switches direc-
!     tion.  (See PCHIC IF user control is desired in such cases.)
!
!     To facilitate two-dimensional applications, includes an increment
!     between successive values of the F- and D-arrays.
!
!     The resulting piecewise cubic Hermite FUNCTION may be evaluated
!     by PCHFE or PCHFD.
!
! ----------------------------------------------------------------------
!
!  Calling sequence:
!
!        PARAMETER  (INCFD = ...)
!        INTEGER  N, IERR
!        REAL  X(N), F(INCFD,N), D(INCFD,N)
!
!        CALL  PCHIM (N, X, F, D, INCFD, IERR)
!
!   Parameters:
!
!     N -- (input) number of data points.  (Error RETURN IF N.LT.2 .)
!           If N=2, simply does linear interpolation.
!
!     X -- (input) REAL array of independent variable values.  The
!           elements of X must be strictly increasing:
!                X(I-1) .LT. X(I),  I = 2(1)N.
!           (Error RETURN IF not.)
!
!     F -- (input) REAL array of dependent variable values to be inter-
!           polated.  F(1+(I-1)*INCFD) is value corresponding to X(I).
!           PCHIM is designed for monotonic data, but it will work for
!           ANY F-array.  It will force extrema at points WHERE mono-
!           tonicity switches direction.  If some other treatment of
!           switch points is desired, PCHIC should be used instead.
!                                     -----
!     D -- (output) REAL array of derivative values at the data points.
!           If the data are monotonic, these values will determine a
!           a monotone cubic Hermite FUNCTION.
!           The value corresponding to X(I) is stored in
!                D(1+(I-1)*INCFD),  I=1(1)N.
!           No other entries in D are changed.
!
!     INCFD -- (input) increment between successive values in F and D.
!           This argument is provided primarily for 2-D applications.
!           (Error RETURN IF  INCFD.LT.1 .)
!
!     IERR -- (output) error flag.
!           Normal RETURN:
!              IERR = 0  (no errors).
!           Warning error:
!              IERR.GT.0  means that IERR switches in the direction
!                 of monotonicity were detected.
!           "Recoverable" errors:
!              IERR = -1  IF N.LT.2 .
!              IERR = -2  IF INCFD.LT.1 .
!              IERR = -3  IF the X-array is not strictly increasing.
!             (The D-array has not been changed in ANY of these cases.)
!               NOTE:  The above errors are checked in the order listed,
!                   and following arguments have **NOT** been validated.
!
!***REFERENCES  1. F.N.FRITSCH AND R.E.CARLSON, 'MONOTONE PIECEWISE CUBIC INTERPOLATION,'
!                 SIAM J.NUMER.ANAL. 17, 2 (APRIL 1980), 238-246.
!              2. F.N.FRITSCH AND J.BUTLAND, 'A METHOD FOR CONSTRUCTING LOCAL MONOTONE PIECEWISE CUBIC INTERPOLANTS,'
!                 LLNL PREPRINT UCRL-87559 (APRIL 1982).
!***ROUTINES CALLED  PCHST
!***END PROLOGUE  PCHIM
!
! ----------------------------------------------------------------------
!
!  Change record:
!     82-02-01   1. Introduced  PCHST  to reduce possible over/under-
!                   flow problems.
!                2. Rearranged derivative formula for same reason.
!     82-06-02   1. Modified END conditions to be continuous functions
!                   of data when monotonicity switches in next interval.
!                2. Modified formulas so END conditions are less prone
!                   of over/underflow problems.
!     82-08-03   Minor cosmetic changes for release 1.
!
! ----------------------------------------------------------------------
!
!  Programming notes:
!
!     1. The FUNCTION  PCHST(ARG1,ARG2)  is assumed to return zero if
!        either argument is zero, +1 if they are of the same sign, and
!        -1 IF they are of opposite sign.
!     2. To produce a Double precision version, simply:
!        a. Change PCHIM to DPCHIM wherever it occurs,
!        b. Change PCHST to DPCHST wherever it occurs,
!        c. Change all references to the fortran intrinsics to their
!           Double precision equivalents,
!        d. Change the Real declarations to Double precision, and
!        e. Change the constants ZERO and THREE to Double precision.
!
!  DECLARE ARGUMENTS.
!
!
!  DECLARE LOCAL VARIABLES.
!
      DATA ZERO/0/
      DATA THREE/3/
!
!  VALIDITY-CHECK ARGUMENTS.
!
!***FIRST EXECUTABLE STATEMENT  PCHIM
      IF (N >= 2) THEN
         IF (INCFD < 1) GO TO 5002
         DO I = 2, N
            IF (X(I) <= X(I-1)) GO TO 5003
         END DO
!
!  FUNCTION DEFINITION IS OK, GO ON.
!
         IERR = 0
         NLESS1 = N - 1
         H1 = X(2) - X(1)
         DEL1 = (F(1,2)-F(1,1))/H1
         DSAVE = DEL1
!
!  SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION.
!
         IF (NLESS1 <= 1) THEN
            D(1,1) = DEL1
            D(1,N) = DEL1
         ELSE
!
!  NORMAL CASE  (N .GE. 3).
!
            H2 = X(3) - X(2)
            DEL2 = (F(1,3)-F(1,2))/H2
!
!  SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
!  SHAPE-PRESERVING.
!
            HSUM = H1 + H2
            W1 = (H1 + HSUM)/HSUM
            W2 = -H1/HSUM
            D(1,1) = W1*DEL1 + W2*DEL2
            IF (PCHST(D(1,1),DEL1) <= ZERO) THEN
               D(1,1) = ZERO
            ELSE IF (PCHST(DEL1,DEL2) < ZERO) THEN
!        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
               D_max = THREE*DEL1
               IF (ABS(D(1,1)) > ABS(D_max)) D(1,1) = D_max
            ENDIF
!
!  LOOP THROUGH INTERIOR POINTS.
!
            DO I = 2, NLESS1
               IF (I /= 2) THEN
!
                  H1 = H2
                  H2 = X(I+1) - X(I)
                  HSUM = H1 + H2
                  DEL1 = DEL2
                  DEL2 = (F(1,I+1)-F(1,I))/H2
               ENDIF
!
!        SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC.
!
               D(1,I) = ZERO
               R1 = PCHST(DEL1,DEL2)
               IF (R1 >= ZERO) THEN
                  IF (R1 > ZERO) GO TO 45
                  IF (DEL2 == ZERO) CYCLE
                  IF (PCHST(DSAVE,DEL2) < ZERO) IERR = IERR + 1
                  DSAVE = DEL2
                  CYCLE
!
               ENDIF
               IERR = IERR + 1
               DSAVE = DEL2
               CYCLE
!
!        USE BRODLIE MODIFICATION OF BUTLAND FORMULA.
!
   45          CONTINUE
               HSUMT3 = HSUM + HSUM + HSUM
               W1 = (HSUM + H1)/HSUMT3
               W2 = (HSUM + H2)/HSUMT3
               D_max = MAX(ABS(DEL1),ABS(DEL2))
               D_min = MIN(ABS(DEL1),ABS(DEL2))
               DRAT1 = DEL1/D_max
               DRAT2 = DEL2/D_max
               D(1,I) = D_min/(W1*DRAT1 + W2*DRAT2)
!
            END DO
!
!  SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
!     SHAPE-PRESERVING.
!
            W1 = -H2/HSUM
            W2 = (H2 + HSUM)/HSUM
            D(1,N) = W1*DEL1 + W2*DEL2
            IF (PCHST(D(1,N),DEL2) <= ZERO) THEN
               D(1,N) = ZERO
            ELSE IF (PCHST(DEL1,DEL2) < ZERO) THEN
!        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
               D_max = THREE*DEL2
               IF (ABS(D(1,N)) > ABS(D_max)) D(1,N) = D_max
            ENDIF
!
!  NORMAL RETURN.
!
         ENDIF
         RETURN
!
!  ERROR RETURNS.
!
      ENDIF
!     N.LT.2 RETURN.
      IERR = -1
      STOP 'PCHIM -- NUMBER OF DATA POINTS LESS THAN TWO'
      RETURN
!
 5002 CONTINUE
!     INCFD.LT.1 RETURN.
      IERR = -2
      STOP 'PCHIM -- INCREMENT LESS THAN ONE'
      RETURN
!
 5003 CONTINUE
!     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      STOP 'PCHIM -- X-ARRAY NOT STRICTLY INCREASING'
      RETURN
!------------- LAST LINE OF PCHIM FOLLOWS ------------------------------
      END SUBROUTINE PCHIM


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PEAK and MEAN stretch options
C
      SUBROUTINE HPEAK(IMODE,HIST,NPTS,lut,prt,nchar)
      IMPLICIT NONE
      INTEGER*4 IMODE,NPTS,NCHAR
      INTEGER*4 HIST(-32768:32767)
      INTEGER*2 LUT(-32768:32767)
      CHARACTER*80 PRT

      COMMON/C3/INMIN,INMAX,DNMIN,DNMAX
      INTEGER*4 INMIN,INMAX,DNMIN,DNMAX

      INTEGER*4 ICOUNT,IDEF,IMEAN,IDN
      INTEGER*4 I1,I2,NPKFQ,NPKDN,NRANGE,DNMIDDLE
      INTEGER*4 NMIN,NMAX,NLEV
      REAL*4 A,B,XFACTR,AMEAN,RTRUNC
      CHARACTER*14 PRT3
  275 FORMAT (A14,I7,' to',I7,' and',I7,' to',I7)

      NLEV = INMAX - INMIN + 1
      IF (IMODE.EQ.16) THEN
         CALL XVMESSAGE('*** PEAK OPTION ***',' ')
         NPKFQ=0
         NPKDN=0
         I1 = INMIN + 1
         I2 = INMAX - 1
         DO IDN=I1,I2			!Find IDN with max frequency
            IF (NPKFQ.LT.HIST(IDN)) THEN
               NPKFQ = HIST(IDN)
               NPKDN = IDN
            END IF
         END DO
         PRT3 = 'Peak Stretch:'
      ENDIF

      IF (IMODE.EQ.17) THEN
         CALL XVMESSAGE('*** MEAN OPTION ***',' ')
         AMEAN=0.0
         DO IDN=INMIN,INMAX		!Compute mean DN
            AMEAN = AMEAN + IDN*HIST(IDN)
         ENDDO
         AMEAN = AMEAN/FLOAT(NPTS)
         IMEAN = NINT(AMEAN)
         NPKFQ = HIST(IMEAN)
         NPKDN = IMEAN
         PRT3 = 'Mean Stretch:'
      ENDIF

      CALL XVPARM('RANGE',nrange,icount,idef,1)
      IF (ICOUNT.EQ.1) THEN
         NMIN = NPKDN - NRANGE
         NMAX = NPKDN + NRANGE
      ELSE
         CALL ASTRETCH_LIMITS(HIST,NPTS,nmin,nmax)
      ENDIF

      DNMIDDLE = 0.5*(DNMIN+DNMAX)
      CALL XVPARM('FACTOR',xfactr,icount,idef,1)

C........Compute lower part of stretch table
      A = FLOAT(DNMIDDLE-DNMIN)/FLOAT(NPKDN-NMIN)
      IF (ICOUNT.EQ.1) A=XFACTR
      B = -A*NMIN + DNMIN
      DO IDN=INMIN,NPKDN
         LUT(IDN) = RTRUNC(A*IDN+B)
      ENDDO

C........Compute upper part of stretch table
      A = FLOAT(DNMAX-DNMIDDLE)/FLOAT(NMAX-NPKDN)
      IF (ICOUNT.EQ.1) A=XFACTR
      B = -A*NPKDN + DNMIDDLE
      DO IDN=NPKDN,INMAX
         LUT(IDN) = RTRUNC(A*IDN+B)
      ENDDO

      WRITE (PRT,275) PRT3,NMIN,DNMIN,NMAX,DNMAX
      NCHAR=52
      CALL XVMESSAGE(PRT,' ')
      RETURN
      END


program test_poisson_fft
use types, only: dp
use constants, only: pi, i_
use ofdft_fft, only: reciprocal_space_vectors, real2fourier, integralG, &
        radial_potential_fourier, poisson_kernel
use utils, only: assert, linspace
use ewald_sums, only: ewald_box
implicit none
! Exact value for a point charge
real(dp), parameter :: E_ewald_exact = -6.3839193288315013_dp
! Converged value for a Gaussian charge with alpha=5 (should be close, but not
! exactly equal to E_ewald_exact)
real(dp), parameter :: E_gauss5_conv = -6.2425476594199409_dp

! Two charges:
real(dp), parameter :: E_ewald_exact2  = -9.1591267925365365_dp

call test1()
!call test2()
call test3()
call test4()
call test5()
call test6()
call test7()
call test8()

contains

subroutine test1()
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), ne(:, :, :)
complex(dp), allocatable :: neG(:, :, :), VeeG(:, :, :)
real(dp) :: L, Eee, alpha, Z, X(3, 1)
integer :: Ng

L = 2
Ng = 32

allocate(ne(Ng, Ng, Ng), neG(Ng, Ng, Ng), VeeG(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng))
call reciprocal_space_vectors([L, L, L], G, G2)

alpha = 5
X(:, 1) = L/2
Z = 3
call gaussian_charges([Z], X, L, alpha, ne)
call real2fourier(ne, neG)
call poisson_kernel(size(neG), neG, G2, VeeG)

Eee = integralG(L, VeeG*conjg(neG)) / 2
Eee = Eee - Z**2 * alpha / sqrt(2*pi) ! subtract self-energy

print *, "Ng = ", Ng
print *, "Eee       =", Eee
print *, "Eee_exact =", E_gauss5_conv
print *, "error     =", abs(Eee - E_gauss5_conv)

call assert(abs(Eee - E_gauss5_conv) < 2e-12_dp)
end subroutine

subroutine test2()
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), ne(:, :, :)
complex(dp), allocatable :: neG(:, :, :), VeeG(:, :, :)
real(dp) :: L, Eee, x(3), alpha, r, charge_pos(3), Z
integer :: Ng, i, j, k, ialpha

L = 2

print *, "Ng, alpha, Eee"
do Ng = 32, 256, 16
    allocate(ne(Ng, Ng, Ng), neG(Ng, Ng, Ng), VeeG(Ng, Ng, Ng))
    allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng))
    call reciprocal_space_vectors([L, L, L], G, G2)

    do ialpha = 1, 200, 10
        alpha = 5 + ialpha
        do i = 1, size(ne, 1)
            do j = 1, size(ne, 2)
                do k = 1, size(ne, 3)
                    x = ([i, j, k]-1) * L / shape(ne) ! x is in [0, L)^3
                    charge_pos = L/2  ! The charge position is in the middle
                    Z = 1 ! Charge
                    r = sqrt(sum((x-charge_pos)**2))
                    ne(i, j, k) = Z*alpha**3/pi**(3._dp/2)*exp(-alpha**2*r**2)
                end do
            end do
        end do
        call real2fourier(ne, neG)
        call poisson_kernel(size(neG), neG, G2, VeeG)

        Eee = integralG(L, VeeG*conjg(neG)) / 2

        print *, Ng, alpha, Eee
    end do
    deallocate(ne, neG, VeeG, G, G2)
end do
end subroutine

subroutine test3()
integer :: N
real(dp) :: L, E_ewald, stress(6)
real(dp), allocatable :: X(:, :), fewald(:, :), q(:)
L = 2
N = 1
allocate(X(3, N), fewald(3, N), q(N))
X(:, 1) = [L/2, L/2, L/2]
q = 3
call ewald_box(L, X, q, E_ewald, fewald, stress)
print *, "Ewald       =", E_ewald
print *, "Ewald_exact =", E_ewald_exact
print *, "error       =", abs(E_ewald - E_ewald_exact)

call assert(abs(E_ewald - E_ewald_exact) < 1e-12_dp)
end subroutine

subroutine test4()
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), ne(:, :, :)
complex(dp), allocatable :: neG(:, :, :), VeeG(:, :, :)
real(dp) :: L, Eee, X(3, 2), alpha, Z
integer :: Ng

L = 2
Ng = 32

allocate(ne(Ng, Ng, Ng), neG(Ng, Ng, Ng), VeeG(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng))
call reciprocal_space_vectors([L, L, L], G, G2)

alpha = 5
X(:, 1) = [L/4, L/4, L/4]
X(:, 2) = 3*[L/4, L/4, L/4]
Z = 3
call gaussian_charges([Z, -Z], X, L, alpha, ne)
call real2fourier(ne, neG)
call poisson_kernel(size(neG), neG, G2, VeeG)

Eee = integralG(L, VeeG*conjg(neG)) / 2
Eee = Eee - 2 * Z**2 * alpha / sqrt(2*pi) ! subtract self-energy (2 charges)

print *, "Ng = ", Ng
print *, "Eee       =", Eee
print *, "Eee_exact =", E_ewald_exact2
print *, "error     =", abs(Eee - E_ewald_exact2)

call assert(abs(Eee - E_ewald_exact2) < 1e-12_dp)
end subroutine

subroutine test5()
integer :: N
real(dp) :: L, E_ewald, stress(6)
real(dp), allocatable :: X(:, :), fewald(:, :), q(:)
L = 2
N = 2
allocate(X(3, N), fewald(3, N), q(N))
X(:, 1) = [L/4, L/4, L/4]
X(:, 2) = 3*[L/4, L/4, L/4]
q = [3, -3]
call ewald_box(L, X, q, E_ewald, fewald, stress)
print *, "Ewald       =", E_ewald
print *, "Ewald_exact =", E_ewald_exact2
print *, "error       =", abs(E_ewald - E_ewald_exact2)

call assert(abs(E_ewald - E_ewald_exact2) < 1e-12_dp)
end subroutine

subroutine gaussian_charges(q, r, L, alpha, ne)
real(dp), intent(in) :: q(:), r(:, :), L, alpha
real(dp), intent(out) :: ne(:, :, :)
integer :: i, j, k, a, b, c, n
real(dp) :: x(3), r2
ne = 0
do i = 1, size(ne, 1)
do j = 1, size(ne, 2)
do k = 1, size(ne, 3)
    x = ([i, j, k]-1) * L / shape(ne) ! x is in [0, L)^3
    do n = 1, size(r, 2)
        do a = -1, 1
        do b = -1, 1
        do c = -1, 1
            r2 = sum((x-r(:, n)+[a, b, c]*L)**2)
            ne(i, j, k) = ne(i, j, k) + &
                q(n)*alpha**3/pi**(3._dp/2)*exp(-alpha**2*r2)
        end do
        end do
        end do
    end do
end do
end do
end do
end subroutine

subroutine test6()
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), ne(:, :, :)
complex(dp), allocatable :: neG(:, :, :), VeeG(:, :, :)
integer, parameter :: natom = 8
real(dp) :: L, Eee, X(3, natom), xred(3, natom), alpha, q(natom), E_madelung
integer :: Ng, i

L = 2
Ng = 32

allocate(ne(Ng, Ng, Ng), neG(Ng, Ng, Ng), VeeG(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng))
call reciprocal_space_vectors([L, L, L], G, G2)

alpha = 5
! Cl^-
xred(:, 1) = [0._dp, 0._dp, 0._dp]
xred(:, 2) = [1._dp/2, 1._dp/2, 0._dp]
xred(:, 3) = [1._dp/2, 0._dp, 1._dp/2]
xred(:, 4) = [0._dp, 1._dp/2, 1._dp/2]
! Na^+
xred(:, 5) = [1._dp/2, 1._dp/2, 1._dp/2]
xred(:, 6) = [1._dp/2, 0._dp, 0._dp]
xred(:, 7) = [0._dp, 1._dp/2, 0._dp]
xred(:, 8) = [0._dp, 0._dp, 1._dp/2]
q = [-1, -1, -1, -1, 1, 1, 1, 1]*1._dp
X = xred*L
call gaussian_charges(q, X, L, alpha, ne)
call real2fourier(ne, neG)
call poisson_kernel(size(neG), neG, G2, VeeG)

Eee = integralG(L, VeeG*conjg(neG)) / 2
do i = 1, natom
    Eee = Eee - q(i)**2 * alpha / sqrt(2*pi) ! subtract self-energy
end do

alpha = 1.74756459463318219064_dp ! Madelung constant for NaCl
E_madelung = -2*alpha/L

Eee = Eee / 4

print *, "Ng = ", Ng
print *, "Eee       =", Eee
print *, "Eee_exact =", E_madelung
print *, "error     =", abs(Eee - E_madelung)

call assert(abs(Eee - E_madelung) < 5e-6_dp)
end subroutine

subroutine test7()
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), ne(:, :, :), fac(:, :, :),&
    R(:)
real(dp), allocatable :: ne0(:, :, :), Vee0G(:, :, :)
real(dp) :: V0
complex(dp), allocatable :: neG(:, :, :), VeeG(:, :, :), ne0G(:, :, :)
integer, parameter :: natom = 8
real(dp) :: L, Eee, X(3, natom), xred(3, natom), alpha, q(natom), E_madelung
real(dp) :: stress(6), forces(3, natom), forces_ewald(3, natom), rel
integer :: Ng, i

L = 2
Ng = 64

allocate(ne(Ng, Ng, Ng), neG(Ng, Ng, Ng), VeeG(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng), fac(Ng, Ng, Ng))
allocate(ne0(Ng, Ng, Ng), ne0G(Ng, Ng, Ng), Vee0G(Ng, Ng, Ng))
call reciprocal_space_vectors([L, L, L], G, G2)

alpha = 14
! Cl^-
xred(:, 1) = [0._dp, 0._dp, 0._dp]
xred(:, 2) = [1._dp/2, 1._dp/2, 0._dp]
xred(:, 3) = [1._dp/2, 0._dp, 1._dp/2]
xred(:, 4) = [0._dp, 1._dp/2, 1._dp/2]
! Na^+
xred(:, 5) = [1._dp/2, 1._dp/2, 1._dp/2]
xred(:, 6) = [1._dp/2, 0._dp, 0._dp]
xred(:, 7) = [0._dp, 1._dp/2, 0._dp]
xred(:, 8) = [0._dp, 0._dp, 1._dp/2]

! We shift the y-position here, this makes the dipole moment non-zero
xred(2, 2) = 1._dp/4

q = [-1, -1, -1, -1, 1, 1, 1, 1]*1._dp
X = xred*L
call gaussian_charges(q, X, L, alpha, ne)
call real2fourier(ne, neG)
call poisson_kernel(size(neG), neG, G2, VeeG)

Eee = integralG(L, VeeG*conjg(neG)) / 2
do i = 1, natom
    Eee = Eee - q(i)**2 * alpha / sqrt(2*pi) ! subtract self-energy
end do

alpha = 1.8285774522233_dp ! Madelung constant
E_madelung = -2*alpha/L

Eee = Eee / 4

print *, "Ng = ", Ng
print *, "Eee       =", Eee
print *, "Eee_exact =", E_madelung
print *, "error     =", abs(Eee - E_madelung)

call assert(abs(Eee - E_madelung) < 2e-11_dp)

call ewald_box(L, X, q, Eee, forces_ewald, stress)
call assert(abs(Eee / 4 - E_madelung) < 1e-13)
print *, "Ewald Forces:"
do i = 1, natom
    print *, i, forces_ewald(:, i)
end do
print *, "FFT Forces:"
allocate(R(10000))
R = linspace(1._dp/10000, 0.1_dp, 10000)
call radial_potential_fourier(R, erf(alpha*R)/R, L, 1._dp, Vee0G, V0)
do i = 1, natom
    ! Important: in the shift theorem, we need to use plus sign in exp(+iG*X),
    ! because our FFT uses minus sign in the forward real -> fourier transform.
    fac = q(i)*L**3*Vee0G*aimag(neG*exp(i_ * &
        (G(:,:,:,1)*X(1,i) + G(:,:,:,2)*X(2,i) + G(:,:,:,3)*X(3,i))))
    forces(1, i) = sum(G(:,:,:,1)*fac)
    forces(2, i) = sum(G(:,:,:,2)*fac)
    forces(3, i) = sum(G(:,:,:,3)*fac)
end do
do i = 1, natom
    print *, i, forces(:, i)
end do
print *, "Errors:"
do i = 1, natom
    rel = sqrt(sum((forces(:, i)-forces_ewald(:, i))**2) / &
            sum(forces_ewald(:, i)**2))
    print *, i, rel
    if (i == 2 .or. i == 6) then
        call assert(rel < 5e-6_dp)
    else
        call assert(rel < 1e-12_dp)
    end if
end do
end subroutine

subroutine test8()
real(dp), allocatable :: G(:, :, :, :), G2(:, :, :), ne(:, :, :), fac(:, :, :),&
    R(:)
real(dp), allocatable :: ne0(:, :, :), Vee0G(:, :, :)
real(dp) :: V0
complex(dp), allocatable :: neG(:, :, :), VeeG(:, :, :), ne0G(:, :, :)
integer, parameter :: natom = 8
real(dp) :: L, Eee, X(3, natom), xred(3, natom), alpha, q(natom), E_madelung
real(dp) :: stress(6), forces(3, natom), forces_ewald(3, natom), rel
integer :: Ng, i

L = 2
Ng = 64

allocate(ne(Ng, Ng, Ng), neG(Ng, Ng, Ng), VeeG(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng), fac(Ng, Ng, Ng))
allocate(ne0(Ng, Ng, Ng), ne0G(Ng, Ng, Ng), Vee0G(Ng, Ng, Ng))
call reciprocal_space_vectors([L, L, L], G, G2)

alpha = 14
! Cl^-
xred(:, 1) = [0._dp, 0._dp, 0._dp]
xred(:, 2) = [1._dp/2, 1._dp/2, 0._dp]
xred(:, 3) = [1._dp/2, 0._dp, 1._dp/2]
xred(:, 4) = [0._dp, 1._dp/2, 1._dp/2]
! Na^+
xred(:, 5) = [1._dp/2, 1._dp/2, 1._dp/2]
xred(:, 6) = [1._dp/2, 0._dp, 0._dp]
xred(:, 7) = [0._dp, 1._dp/2, 0._dp]
xred(:, 8) = [0._dp, 0._dp, 1._dp/2]

! We shift the y-position here, this makes the dipole moment non-zero

xred(:, 1) = xred(:, 1) + 0.1_dp
xred(:, 2) = [0.20_dp, 0.25_dp, 0.15_dp]
xred(:, 3) = xred(:, 3) - 0.1_dp
xred(:, 4) = xred(:, 4) + 0.05_dp
xred(:, 5) = xred(:, 5) - 0.05_dp
xred(:, 6) = xred(:, 6) + 0.15_dp
xred(:, 7) = xred(:, 7) - 0.15_dp
xred(:, 8) = xred(:, 8) + 0.20_dp

q = [-1, -1, -1, -1, 1, 1, 1, 1]*1._dp
X = xred*L
call gaussian_charges(q, X, L, alpha, ne)
call real2fourier(ne, neG)
call poisson_kernel(size(neG), neG, G2, VeeG)

Eee = integralG(L, VeeG*conjg(neG)) / 2
do i = 1, natom
    Eee = Eee - q(i)**2 * alpha / sqrt(2*pi) ! subtract self-energy
end do

alpha = 1.0760854113057650_dp ! Madelung constant
E_madelung = -2*alpha/L

Eee = Eee / 4

print *, "Ng = ", Ng
print *, "Eee       =", Eee
print *, "Eee_exact =", E_madelung
print *, "error     =", abs(Eee - E_madelung)

call assert(abs(Eee - E_madelung) < 2e-7_dp)

call ewald_box(L, X, q, Eee, forces_ewald, stress)
call assert(abs(Eee / 4 - E_madelung) < 1e-13)
print *, "Ewald Forces:"
do i = 1, natom
    print *, i, forces_ewald(:, i)
end do
print *, "FFT Forces:"
allocate(R(10000))
R = linspace(1._dp/10000, 0.1_dp, 10000)
call radial_potential_fourier(R, erf(alpha*R)/R, L, 1._dp, Vee0G, V0)
do i = 1, natom
    ! Important: in the shift theorem, we need to use plus sign in exp(+iG*X),
    ! because our FFT uses minus sign in the forward real -> fourier transform.
    fac = q(i)*L**3*Vee0G*aimag(neG*exp(i_ * &
        (G(:,:,:,1)*X(1,i) + G(:,:,:,2)*X(2,i) + G(:,:,:,3)*X(3,i))))
    forces(1, i) = sum(G(:,:,:,1)*fac)
    forces(2, i) = sum(G(:,:,:,2)*fac)
    forces(3, i) = sum(G(:,:,:,3)*fac)
end do
do i = 1, natom
    print *, i, forces(:, i)
end do
print *, "Errors:"
do i = 1, natom
    rel = sqrt(sum((forces(:, i)-forces_ewald(:, i))**2) / &
            sum(forces_ewald(:, i)**2))
    print *, i, rel
    call assert(rel < 3e-5_dp)
end do
end subroutine

end program


      PROGRAM CSEX06
C
C  Do a 3D approximation and plot an isosurface.
C
C
C  The dimensionality of the problem.
C
      PARAMETER (NDIM=3)
C
C  The number of input data points.
C
      PARAMETER (NDATA=1000)
C
C  The number of output data points in the X coordinate direction.
C
      PARAMETER (NX=21)
C
C  The number of output data points in the Y coordinate direction.
C
      PARAMETER (NY=31)
C
C  The number of output data points in the Z coordinate direction.
C
      PARAMETER (NZ=41)
C
C  Specifty the number of knots in the X direction.
C
      PARAMETER (N1=4)
C
C  Specifty the number of knots in the Y direction.
C
      PARAMETER (N2=4)
C
C  Specifty the number of knots in the Z direction.
C
      PARAMETER (N3=4)
C
C  The size of the workspace.
C
      PARAMETER (NCF=N1*N2*N3, NWRK=NCF*(NCF+3))
C
C  Dimension the arrays.
C
      DIMENSION XDATA(NDIM,NDATA),YDATA(NDATA),KNOTS(NDIM),WORK(NWRK)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Define arrays for use in plotting the isosurface.
C
      REAL XO(NX),  YO(NY),  ZO(NZ),  OUTPUT(NX,NY,NZ)
      DATA XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX / -2., -2., -2., 2.,  2., 2./
C
C  Define the input data on random coordinates bounded by the
C  above values.
C
      DO 10 I=1,NDATA
        XDATA(1,I) = XMIN+(XMAX-XMIN)*DSRND1()
        XDATA(2,I) = YMIN+(YMAX-YMIN)*DSRND1()
        XDATA(3,I) = ZMIN+(ZMAX-ZMIN)*DSRND1()
        YDATA(I)  =  0.75*XDATA(1,I)**2 - 1.6*XDATA(2,I)**2
     +                    + 2.0*XDATA(3,I)**2.
   10 CONTINUE
C
C  Create the output grid.
C
      DO 102 I=1,NX
        XO(I) = XMIN+(REAL(I-1)/REAL(NX-1))*(XMAX-XMIN)
  102 CONTINUE
      DO 103 J =1,NY
        YO(J)= YMIN+(REAL(J-1)/REAL(NY-1))*(YMAX-YMIN)
  103 CONTINUE
      DO 104 K=1,NZ
        ZO(K) = ZMIN+(REAL(K-1)/REAL(NZ-1))*(ZMAX-ZMIN)
  104 CONTINUE
C
C  Specify the numbers of nodes in each coordinate.
C
      KNOTS(1) = N1
      KNOTS(2) = N2
      KNOTS(3) = N3
C
C  Calculate the approximating function.
C
      CALL CSA3S (NDATA,XDATA,YDATA,KNOTS,NX,NY,NZ,
     +            XO,YO,ZO,OUTPUT,NWRK,WORK,IER)
C
C  Plot an isosurface.
C
C Open GKS and define the foreground and background color.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
      CALL TDEZ3D(NX, NY, NZ, XO, YO, ZO, OUTPUT, .7,
     +            2.3, -13., 75., 6)
      CALL FRAME()
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      REAL FUNCTION DSRND1()
C
C  Portable random number generator.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
      DATA JSEED,IFRST/123456789,0/
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      DSRND1 = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END


SUBROUTINE beemat(bee,deriv)
!
! This subroutine forms the bee matrix in 2-d (ih=3 or 4) or 3-d (ih=6).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::deriv(:,:)
 REAL(iwp),INTENT(OUT)::bee(:,:)
 INTEGER::k,l,m,n,ih,nod
 REAL::x,y,z
 bee=0.0_iwp
 ih=UBOUND(bee,1)
 nod=UBOUND(deriv,2)
 SELECT CASE (ih)
 CASE(3,4)
   DO m=1,nod
     k=2*m
     l=k-1
     x=deriv(1,m)
     y=deriv(2,m)
     bee(1,l)=x
     bee(3,k)=x
     bee(2,k)=y
     bee(3,l)=y
   END DO
 CASE(6)
   DO m=1,nod
     n=3*m
     k=n-1
     l=k-1
     x=deriv(1,m)
     y=deriv(2,m)
     z=deriv(3,m)
     bee(1,l)=x
     bee(4,k)=x
     bee(6,n)=x
     bee(2,k)=y
     bee(4,l)=y
     bee(5,n)=y
     bee(3,n)=z
     bee(5,k)=z
     bee(6,l)=z
   END DO
 CASE DEFAULT
   WRITE(*,*)'wrong dimension for nst in bee matrix'
 END SELECT
RETURN
END SUBROUTINE beemat


      subroutine dbesjg (x1, alpha, n, y, nz,w,ierr)
c     Author Serge Steer, Copyright INRIA, 2005
c     extends dbesj for the case where alpha is negative
c     if alpha is negative and non integer and x1 is negative:error
      double precision x1,alpha,y(n),w(n)
      integer n,nz,ierr
c
      double precision a,b,pi,inf,x,a1
      integer ier1,ier2
      double precision dlamch
      data pi /3.14159265358979324D0/

      inf=dlamch('o')*2.0d0
      x=x1
      ierr=0
      ier2=0
      if (x.ne.x.or.alpha.ne.alpha) then
c     .  NaN case
         call dset(n,inf-inf,y,1)
         ierr=4
      elseif (alpha .ge. 0.0d0) then
c     .  alpha <0 and x>=0 or x<0
         call dbesj(abs(x),alpha,n,y,nz,ierr)
         if (ierr.eq.2) call dset(n,inf,y,1)
         if(x.lt.0.0d0) then
            i0=mod(int(alpha)+1,2)
            call dscal((n-i0+1)/2,-1.0d0,y(1+i0),2)
         endif
      else if (alpha .eq. dint(alpha)) then
c     .  alpha <0 and integer,   CHECKED
c     .  transform to positive value of alpha
         if(alpha-1+n.ge.0) then
c     .     0 is between alpha and alpha+n
            a1=0.0d0
            nn=min(n,int(-alpha))
         else
            a1=-(alpha-1+n)
            nn=n
         endif
         call dbesj(abs(x),a1,n,w,nz,ierr)
         if (ierr.eq.2) then
            call dset(n,inf,y,1)
         else
           if(n.gt.nn) then
c     .        0 is between alpha and alpha+n
               call dcopy(n-nn,w,1,y(nn+1),1)
               call dcopy(nn,w(2),-1,y,1)
            else
c     .        alpha and alpha+n are negative
               call dcopy(nn,w,-1,y,1)
            endif
         endif
c     .  apply parity
         i0=mod(int(abs(alpha))+1,2)
         if(x.gt.0.0d0) then
            call dscal((nn-i0+1)/2,-1.0d0,y(1+i0),2)
         else
            call dscal((n-nn)/2,-1.0d0,y(nn+2),2)
         endif
      else if (x .eq. 0.0d0) then
c     .  alpha <0 and x==0 CHECKED
         if(alpha-1.0d0+n.ge.0.0d0) then
c     .     0 is between alpha and alpha+n
            nn=int(-alpha)+1
         else
            nn=n
         endif
         ierr=2
         call dset(nn,-inf,y,1)
         if (n.gt.nn) call dset(n-nn,0.0d0,y(nn+1),1)
      else
c     .  first alpha is negative non integer, x should be positive (with
C     .  x negative the result is complex. CHECKED
c     .  transform to positive value of alpha
         if(alpha-1.0d0+n.ge.0.0d0) then
c     .     0 is between alpha and alpha+n
            nn=int(-alpha)+1
         else
            nn=n
         endif
c     .  compute for negative value of alpha+k, transform problem for
c     .  a1:a1+(nn-1) with a1 positive  a1+k =abs(alpha+nn-k)
         a1=-(alpha-1.0d0+nn)
         call dbesj(x,a1,nn,y,nz1,ierr)
         call dbesy(x,a1,nn,w,ier)
         ierr=max(ierr,ier)
         if (ierr.eq.0) then
            a=cos(a1*pi)
            b=-sin(a1*pi)
c     .     to avoid numerical errors if a is near 0 (or b near 0)
c     .     and y is big (or w is big)
            if(abs(abs(a)-1.0d0).lt.eps)  b=0.0d0
            if(abs(abs(b)-1.0d0).lt.eps)  a=0.0d0
            call dscal(nn,b,w,1)
            call daxpy(nn,a,y,1,w,1)
         elseif (ierr.eq.2) then
            call dset(nn,inf,w,1)
         elseif (ierr.eq.4) then
            call dset(nn,inf-inf,w,1)
         endif
c     .  change sign to take into account that cos((a1+k)*pi) and
C     .  sin((a1+k)*pi) changes sign with k
        if (nn.ge.2) call dscal(nn/2,-1.0d0,w(2),2)

c     .  store the result in the correct order
         call dcopy(nn,w,-1,y,1)

c     .  compute for positive value of alpha+k is any (note that x>0)
         if (n.gt.nn) then
c     .     this code is taken from the alpha>0 case above
            call dbesj(abs(x),1.0d0-a1,n-nn,y(nn+1),nz1,ier)
            if (ier.eq.2) call dset(n-nn,inf,y(nn+1),1)
            ierr=max(ierr,ier)
         endif
      endif
      end

      subroutine dbesjv (x,nx,alpha,na,kode,y,w,ierr)
c     Author Serge Steer, Copyright INRIA, 2005
c     compute besselj function for x and alpha given by vectors
c     w : working array of size 2*na (used only if nz>0 and alpha contains negative
C         values
      double precision x(nx),alpha(na),y(*),w(*)
      integer kode,nx,na,ier
      double precision e,dlamch,w1,eps
      eps=dlamch('p')
      ierr=0
      if (na.lt.0) then
c     .  element wise case x and alpha are supposed to have the same size
         do i=1,nx
            call  dbesjg (x(i), alpha(i),1,y(i), nz, w1,ier)
            ierr=max(ierr,ier)
         enddo
      elseif (na.eq.1) then
c     .  element wise case x and alpha are supposed to have the same size
         do i=1,nx
            call  dbesjg (x(i), alpha(1),1,y(i), nz, w1,ier)
            ierr=max(ierr,ier)
         enddo
      else
c     .  compute besselj(x(i),y(j)), i=1,nx,j=1,na
         j0=1
 05      n=0
 10      n=n+1
         j=j0+n
         if (j.le.na.and.abs((1+alpha(j-1))-alpha(j)).le.eps) then
            goto 10
         endif
         do i=1,nx
            call dbesjg(x(i),alpha(j0),n, w, nz, w(na+1),ier)
            ierr=max(ierr,ier)
            call dcopy(n,w,1,y(i+(j0-1)*nx),nx)
         enddo
         j0=j
         if (j0.le.na) goto 05
      endif
      end


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

!================================================
hattauij(1:nsd,1:nsd,1:nn)=0.0
do ie_local=1,ne_local     ! loop over elements
    ie=ien_local(ie_local)
    do inl=1,nen
        x(1:nsd,inl) = xloc(1:nsd,ien(inl,ie))
        d(1:ndf,inl) = dloc(1:ndf,ien(inl,ie))
    enddo

    do iq=1,nquad  ! loop over the quadrature points in each element
        if (nsd==2) then
            if (nen.eq.3) then !calculate shape function at quad point
                include "sh2d3n.h"
            elseif (nen.eq.4) then
                include "sh2d4n.h"
            endif
        elseif (nsd==3) then
            if (nen.eq.4) then !calculate shape function at quad point
                include "sh3d4n.h"
            elseif (nen.eq.8) then
                include "sh3d8n.h"
            endif
        endif
        eft0 = abs(det) * wq(iq) ! calculate the weight at each quad pt

        dr(1:nsd,1:ndf)=0.0    ! dd/dxi
        mu=0.0

        do inl=1,nen
            mu = mu+sh(0,inl)*fvis(ien(inl,ie))
            do isd=1,nsd
                do jsd=1,nsd
                    dr(isd,jsd) = dr(isd,jsd)+sh(isd,inl)*d(jsd,inl)
                enddo
            enddo
        enddo

        do isd = 1,nsd
            do jsd = 1,nsd
                tau(isd,jsd) = mu*(dr(isd,jsd) + dr(jsd,isd))
            enddo
            if (nsd==2) then
                tau(isd,isd)=tau(isd,isd)-2.0*mu*(dr(1,1)+dr(2,2))/3.0
            elseif (nsd==3) then
                tau(isd,isd)=tau(isd,isd)-2.0*mu*(dr(1,1)+dr(2,2)+dr(3,3))/3.0
            endif
        enddo

        do inl=1,nen ! loop over number of nodes in an element
            node = ien(inl,ie)
            do isd=1,nsd
                do jsd=1,nsd
                    hattauij(isd,jsd,node)=hattauij(isd,jsd,node)+&
                                           eft0*sh(0,inl)*tau(isd,jsd)
                enddo
            enddo
        enddo

    enddo ! end of qudrature pts loop
enddo ! end of element loop
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! ||||||||||||||||||||||||||||||||||||||||||||||||
! evaluating \R{\tau_{ij}}

! evaluating \hat{\tau_{ij}} = \R{\tau_{ij}} / M_A
! ||||||||||||||||||||||||||||||||||||||||||||||||
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
flagdivision(1:nn)=0
do ie_local=1,ne_local
    ie=ien_local(ie_local)
    do inl=1,nen
        node=ien(inl,ie)
        if (flagdivision(node)==0) then
            hattauij(1:nsd,1:nsd,node)=hattauij(1:nsd,1:nsd,node)/mpqlumpmass(node)
            flagdivision(node)=1
        endif
    enddo
enddo


      FUNCTION gamdev(ia,idum)
      INTEGER ia,idum
      REAL gamdev
CU    USES ran1
      INTEGER j
      REAL am,e,s,v1,v2,x,y,ran1
      if(ia.lt.1)pause 'bad argument in gamdev'
      if(ia.lt.6)then
        x=1.
        do 11 j=1,ia
          x=x*ran1(idum)
11      continue
        x=-log(x)
      else
1         v1=ran1(idum)
          v2=2.*ran1(idum)-1.
        if(v1**2+v2**2.gt.1.)goto 1
          y=v2/v1
          am=ia-1
          s=sqrt(2.*am+1.)
          x=s*y+am
        if(x.le.0.)goto 1
          e=(1.+y**2)*exp(am*log(x/am)-s*y)
        if(ran1(idum).gt.e)goto 1
      endif
      gamdev=x
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/gamdev.for


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of SCALE()
module m
  logical, parameter :: test_1 = scale(1.0, 1) == 2.0
  logical, parameter :: test_2 = scale(0.0, 1) == 0.0
  logical, parameter :: test_3 = sign(1.0, scale(-0.0, 1)) == -1.0
  logical, parameter :: test_4 = sign(1.0, scale(0.0, 0)) == 1.0
  logical, parameter :: test_5 = scale(1.0, -1) == 0.5
  logical, parameter :: test_6 = scale(2.0, -1) == 1.0
end module


! Copyright (c) 2016 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level of this distribution.

module gaussian
  ! 1D Gaussian module

  use progvars

  implicit none

  public :: gaussian_init
  public :: gaussian_cleanup
  public :: gaussian_pxpy
  public :: gaussian_xyt

  private

  ! Useful constants
  real(fp) :: p0_x_m, p0_x_2m
  real(fp) :: p0_y_m, p0_y_2m
  real(fp) :: sig_x2, sig_y2
  real(fp) :: sig_px, sig_px2
  real(fp) :: sig_py, sig_py2
  real(fp) :: norm_px, norm_py
  complex(fp) :: j_hb, jhb_m

contains
  subroutine gaussian_init()
    ! Precalculate useful constants
    p0_x_m = p0_x / m
    p0_x_2m = p0_x_m / 2.0_fp

    p0_y_m = p0_y / m
    p0_y_2m = p0_y_m / 2.0_fp

    sig_x2 = sig_x ** 2
    sig_y2 = sig_y ** 2

    j_hb = j / hbar
    jhb_m = j * hbar / m

    sig_px = hbar / sig_x
    sig_px2 = sig_px**2

    sig_py = hbar / sig_y
    sig_py2 = sig_py**2

    norm_px = sqrt(1.0_fp / (sig_px * sqrt_pi))
    norm_py = sqrt(1.0_fp / (sig_py * sqrt_pi))

  end subroutine gaussian_init

  subroutine gaussian_cleanup()
  end subroutine gaussian_cleanup

  real(fp) function gaussian_pxpy(px, py) result(val)
    ! Taken from Sakurai, p. 58
    real(fp), intent(in) :: px, py
    real(fp) :: exp_px, exp_py

    exp_px = - 0.5_fp * ( (px - p0_x) / sig_px )**2
    exp_py = - 0.5_fp * ( (py - p0_y) / sig_py )**2

    val = norm_px * norm_py * exp(exp_px + exp_py)
  end function gaussian_pxpy

  complex(fp) function gaussian_xyt(x, y, t) result(val)
    real(fp), intent(in) :: x, y
    real(fp), intent(in) :: t

    complex(fp) :: norm_x, norm_y
    complex(fp) :: exp_x1, exp_x2, exp_y1, exp_y2

    norm_x = 1.0_fp / sqrt( sqrt_pi * (sig_x + jhb_m / sig_x * t) )
    norm_y = 1.0_fp / sqrt( sqrt_pi * (sig_y + jhb_m / sig_y * t) )

    exp_x1 = - ( (x - x0) - p0_x_m * t )**2 / &
         ( 2.0_fp * sig_x2 * (1 + jhb_m / sig_x2 * t) )
    exp_y1 = - ( (y - y0) - p0_y_m * t )**2 / &
         ( 2.0_fp * sig_y2 * (1 + jhb_m / sig_y2 * t) )

    exp_x2 = j_hb * p0_x * ( (x - x0) - p0_x_2m * t )
    exp_y2 = j_hb * p0_y * ( (y - y0) - p0_y_2m * t )

    val = norm_x * norm_y * exp(exp_x1 + exp_x2 + exp_y1 + exp_y2)

  end function gaussian_xyt

end module gaussian


! -*- coding: utf-8 -*-
program main
  use lp_lap
  use mod_force_raise
  implicit none

  real(8) :: rad
  real(8),allocatable :: x(:, :)
  real(8),allocatable :: xn(:, :)
  integer,allocatable :: edge(:, :)
  real(8),allocatable :: hs(:)
  real(8),allocatable :: lp1(:, :)
  real(8),allocatable :: lp2(:, :)
  real(8),allocatable :: u(:)
  real(8),allocatable :: kai(:)
  integer,allocatable :: ipiv(:)
  integer :: n
  integer :: info
  real(8),parameter :: pi = 3.1415926535897932384626433832795028841971d0
  integer :: exterior

  real(8) :: xm(2)
  real(8) :: th
  integer :: i
  integer :: j
  integer :: i0
  integer :: i1
  integer :: j0
  integer :: j1

  write(6,*) '# n, rad'
  open(1000, file='input', status='old')
  read(1000,*) n, rad
  close(1000)

  allocate(x(2, n))
  allocate(xn(2, n))
  allocate(edge(2, n))
  allocate(hs(n))
  allocate(lp1(n, n))
  allocate(lp2(n, n))
  allocate(u(n))
  allocate(kai(n))
  allocate(ipiv(n))

  do i = 1, n
     th = 2d0*pi*(dble(i)+0.5d0)/dble(n)

     x(1, i) = rad*cos(th)
     x(2, i) = rad*sin(th)
     edge(1, i) = i
     edge(2, i) = mod(i, n) + 1
  end do

  do i = 1, n
     i0 = edge(1, i)
     i1 = edge(2, i)
     xm(:) = 0.5d0*(x(:,i0) + x(:,i1))
     if((i0 .ge. 1 .and. i0 .lt. n+1) .and. (i1 .ge. 1 .and. i1 .lt. n+1)) then
        xn(1, i) = x(2, i1) - x(2, i0)
        xn(2, i) = x(1, i0) - x(1, i1)

        hs(i) = sqrt(xn(1, i)**2 + xn(2, i)**2)

        xn(1, i) = xn(1, i)/hs(i)
        xn(2, i) = xn(2, i)/hs(i)
     else
        call force_raise()
     end if

     !x**3*y - x*y**3
     u(i) = xm(1)**3*xm(2) - xm(1)*xm(2)**3

     !(3x**2*y - y**3)nx + (x**3 - 3xy**2)ny
     kai(i) = (3*xm(1)**2*xm(2) - xm(2)**3)*xn(1, i) + (xm(1)**3 - 3*xm(1)*xm(2)**2)*xn(2, i)
  end do

  exterior = 0

  do j = 1, n
     j0 = edge(1, j)
     j1 = edge(2, j)
     do i = 1, n
        i0 = edge(1, i)
        i1 = edge(2, i)
        xm(:) = 0.5d0*(x(:,i0) + x(:,i1))
        lp1(i, j) = dble(slp_laplace(xm, x(:,j0), x(:,j1), hs(j), xn(:,j)))
        lp2(i, j) = dble(dlp_laplace(xm, x(:,j0), x(:,j1), hs(j), xn(:,j), exterior))
     end do
  end do

  u = matmul(lp2, u)

  call DGESV(N, 1, lp1, n, ipiv, u, n, info)
  if(info.ne.0) then
     write(6,*) 'dgesv, info=', info
     call force_raise()
  endif
  deallocate(lp1)
  deallocate(ipiv)

  write(*,*) 'number of dof', n
  write(*,*) 'rad', rad
  write(*,*) 'relative error', sqrt(dot_product(u - kai, u - kai)/dot_product(kai, kai))

  deallocate(lp2)
  deallocate(u)
  deallocate(kai)
  deallocate(x)
  deallocate(xn)
  deallocate(edge)
  deallocate(hs)

end program main