C     ALGORITHM 587, COLLECTED ALGORITHMS FROM ACM.
C     ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL. 8, NO. 3,
C     SEP., 1982, P.323.
      SUBROUTINE LSEI(W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, LSEI  10
     * MODE, WS, IP)
C
C     DIMENSION W(MDW,N+1),PRGOPT(*),X(N),
C     WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2)
C     ABOVE, K=MAX(MA+MG,N).
C
C     DABSTRACT
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 PRODUCT
C     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
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 EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     (START EDITING AT LINE WITH C++ IN COLS. 1-3.)
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/DASUM/DASUM/,/DDOT/DDOT/,
C     /DNRM2/DNRM2/,/ DSQRT/ DSQRT/,/ DABS/ DABS/,/DMAX1/DMAX1/,
C     /DCOPY/DCOPY/,/DSCAL/DSCAL/,/DAXPY/DAXPY/,/DSWAP/DSWAP/,/D0/D0/,
C     /, DUMMY/,SNGL(DUMMY)/,/DRELPR/DRELPR/
C
C     WRITTEN BY R. J. HANSON AND K. H. HASKELL.  FOR FURTHER MATH.
C     AND ALGORITHMIC DETAILS SEE SANDIA LABORATORIES TECH. REPTS.
C     SAND 77-0552, (1978), SAND 78-1290, (1979), AND
C     MATH. PROGRAMMING, VOL. 21, (1981), P.98-118.
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 LSEI( ) ARE
C
C     INPUT..
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 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.MAX0(M,N).
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 DSQRT(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 DSQRT(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 LSEI( ).
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 LSEI( ).  INSUFFICIENT STORAGE
C                  ALLOCATED FOR EITHER WS(*) OR IP(*) IS AN
C                  ERROR.  THIS FEATURE WAS INCLUDED IN LSEI( )
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
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..
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 ARE
C                   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 ON 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, 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     USER DESIGNATED
C     WORKING ARRAYS..
C
C     WS(*),IP(*)              THESE ARE RESP. TYPE FLOATING POINT
C                              AND TYPE INTEGER WORKING ARRAYS.
C                              THEIR REQUIRED MINIMAL LENGTHS ARE
C                              GIVEN ABOVE.
C
C
C     SUBROUTINES CALLED
C
C     LSI           PART OF THIS PACKAGE.  SOLVES A
C                   CONSTRAINED LEAST SQUARES PROBLEM WITH
C                   INEQUALITY CONSTRAINTS.
C
C++
C     DDOT,DSCAL,   SUBROUTINES FROM THE BLAS PACKAGE.
C     DAXPY,DASUM,  SEE TRANS. MATH. SOFT., VOL. 5, NO. 3, P. 308.
C     DCOPY,DNRM2,
C     DSWAP
C
C     H12           SUBROUTINE TO CONSTRUCT AND APPLY A
C                   HOUSEHOLDER TRANSFORMATION.
C
C     XERROR        FROM SLATEC ERROR PROCESSING PACKAGE.
C                   THIS IS DOCUMENTED IN SANDIA TECH. REPT.,
C                   SAND78-1189.
C
C     SUBROUTINE LSEI(W,MDW,ME,MA,MG,N,PRGOPT,X,RNORME,RNORML,MODE,WS,
C    1 IP)
C
C     REVISED OCT. 1, 1981.
C
      DOUBLE PRECISION W(MDW,1), PRGOPT(1), X(1), WS(1), RNORME, RNORML
      INTEGER IP(3)
      DOUBLE PRECISION DUMMY, ENORM, DRELPR, FNORM, GAM, HALF, ONE, RB,
     *RN, RNMAX, SIZE, SN, SNMAX, T, TAU, UJ, UP, VJ, XNORM, XNRME, ZERO
      DOUBLE PRECISION DASUM, DDOT, DNRM2, DSQRT, DABS, DMAX1
      LOGICAL COV
      DATA ZERO /0.D0/, DRELPR /0.D0/, HALF /0.5E0/, ONE /1.D0/
C
C     CHECK THAT ENOUGH STORAGE WAS ALLOCATED IN WS(*) AND IP(*).
      IF (.NOT.(IP(1).GT.0)) GO TO 20
      LCHK = 2*(ME+N) + MAX0(MA+MG,N) + (MG+2)*(N+7)
      IF (.NOT.(IP(1).LT.LCHK)) GO TO 10
      MODE = 4
      NERR = 2
      IOPT = 1
      CALL XERRWV(67HLSEI( ), INSUFFICIENT STORAGE ALLOCATED FOR WS(*),
     *NEED LW=I1 BELOW, 67, NERR, IOPT, 1, LCHK, 0,
     * 0, DUMMY, DUMMY)
      RETURN
   10 CONTINUE
   20 IF (.NOT.(IP(2).GT.0)) GO TO 40
      LCHK = MG + 2*N + 2
      IF (.NOT.(IP(2).LT.LCHK)) GO TO 30
      MODE = 4
      NERR = 2
      IOPT = 1
      CALL XERRWV(68HLSEI( ), INSUFFICIENT STORAGE ALLOCATED FOR IP(*),
     *NEED LIP=I1 BELOW, 68, NERR, IOPT, 1, LCHK, 0,
     * 0, DUMMY, DUMMY)
      RETURN
   30 CONTINUE
C
C     COMPUTE MACHINE PRECISION=DRELPR ONLY WHEN NECESSARY.
   40 IF (.NOT.(DRELPR.EQ.ZERO)) GO TO 70
      DRELPR = ONE
   50 IF (ONE+DRELPR.EQ.ONE) GO TO 60
      DRELPR = DRELPR*HALF
      GO TO 50
   60 DRELPR = DRELPR + DRELPR
C
C     COMPUTE NUMBER OF POSSIBLE RIGHT MULTIPLYING HOUSEHOLDER
C     TRANSFORMATIONS.
   70 M = ME + MA + MG
      MODE = 0
      IF (N.LE.0 .OR. M.LE.0) RETURN
      IF (.NOT.(MDW.LT.M)) GO TO 80
      NERR = 1
      IOPT = 1
      CALL XERROR(36HLSEI( ), MDW.LT.ME+MA+MG IS AN ERROR, 36, NERR,
     * IOPT)
      MODE = 4
      RETURN
   80 NP1 = N + 1
      KRANKE = MIN0(ME,N)
      N1 = 2*KRANKE + 1
      N2 = N1 + N
C
C     PROCESS-OPTION-VECTOR
      ASSIGN 90 TO IGO990
      GO TO 480
   90 IF (.NOT.(COV .AND. MDW.LT.N)) GO TO 100
      NERR = 2
      IOPT = 1
      CALL XERROR(
     * 54HLSEI( ), MDW.LT.N, WHEN COV MATRIX NEEDED, IS AN ERROR, 54,
     * NERR, IOPT)
      MODE = 4
      RETURN
  100 L = KRANKE
C
C     COMPUTE NORM OF EQUALITY CONSTRAINT MATRIX AND RT SIDE.
      ENORM = ZERO
      DO 110 J=1,N
        ENORM = DMAX1(ENORM,DASUM(ME,W(1,J),1))
  110 CONTINUE
      FNORM = DASUM(ME,W(1,NP1),1)
      IF (.NOT.(L.GT.0)) GO TO 190
      SNMAX = ZERO
      RNMAX = ZERO
      DO 180 I=1,L
C
C     COMPUTE MAXIMUM RATIO OF VECTOR LENGTHS. PARTITION
C     IS AT COL. I.
        DO 150 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 (.NOT.(RN.EQ.ZERO .AND. SN.GT.SNMAX)) GO TO 120
          SNMAX = SN
          IMAX = K
          GO TO 140
  120     IF (.NOT.(K.EQ.I .OR. (SN*RNMAX.GT.RN*SNMAX))) GO TO 130
          SNMAX = SN
          RNMAX = RN
          IMAX = K
  130     CONTINUE
  140     CONTINUE
  150   CONTINUE
C
C     INTERCHANGE ROWS IF NECESSARY.
        IF (I.NE.IMAX) CALL DSWAP(NP1, W(I,1), MDW, W(IMAX,1), MDW)
        IF (.NOT.(SNMAX.GT.TAU**2*RNMAX)) GO TO 160
C
C     ELIMINATE ELEMS I+1,...,N IN ROW I.
        CALL H12(1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, 1,
     *   M-I)
        GO TO 170
  160   KRANKE = I - 1
        GO TO 200
  170   CONTINUE
  180 CONTINUE
  190 CONTINUE
  200 CONTINUE
C
C     SAVE DIAG. TERMS OF LOWER TRAP. MATRIX.
      CALL DCOPY(KRANKE, W, MDW+1, WS(KRANKE+1), 1)
C
C     USE HOUSEHOLDER TRANS FROM LEFT TO ACHIEVE KRANKE BY KRANKE UPPER
C     TRIANGULAR FORM.
      IF (.NOT.(KRANKE.GT.0 .AND. KRANKE.LT.ME)) GO TO 220
      DO 210 KK=1,KRANKE
        K = KRANKE + 1 - KK
C
C     APPLY TRANFORMATION TO MATRIX COLS. 1,...,K-1.
        CALL H12(1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1)
C
C     APPLY TO RT SIDE VECTOR.
        CALL H12(2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1, 1)
  210 CONTINUE
  220 IF (.NOT.(KRANKE.GT.0)) GO TO 240
C
C     SOLVE FOR VARIABLES 1,...,KRANKE IN NEW COORDINATES.
      CALL DCOPY(KRANKE, W(1,NP1), 1, X, 1)
      DO 230 I=1,KRANKE
        X(I) = (X(I)-DDOT(I-1,W(I,1),MDW,X,1))/W(I,I)
  230 CONTINUE
C
C     COMPUTE RESIDUALS FOR REDUCED PROBLEM.
  240 MEP1 = ME + 1
      RNORML = ZERO
      IF (.NOT.(ME.LT.M)) GO TO 270
      DO 260 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 (.NOT.(RN.LE.TAU**2*SN .AND. KRANKE.LT.N)) GO TO 250
        W(I,KRANKE+1) = ZERO
        CALL DCOPY(N-KRANKE, W(I,KRANKE+1), 0, W(I,KRANKE+1), MDW)
  250   CONTINUE
  260 CONTINUE
C
C     COMPUTE EQUAL. CONSTRAINT EQUAS. RESIDUAL LENGTH.
  270 RNORME = DNRM2(ME-KRANKE,W(KRANKE+1,NP1),1)
C
C     MOVE REDUCED PROBLEM DATA UPWARD IF KRANKE.LT.ME.
      IF (.NOT.(KRANKE.LT.ME)) GO TO 290
      DO 280 J=1,NP1
        CALL DCOPY(M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1)
  280 CONTINUE
C
C     COMPUTE SOLN OF REDUCED PROBLEM.
  290 CALL LSI(W(KRANKE+1,KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT,
     * X(KRANKE+1), RNORML, MODE, WS(N2), IP(2))
      IF (.NOT.(ME.GT.0)) GO TO 330
C
C     TEST FOR CONSISTENCY OF EQUALITY CONSTRAINTS.
      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 SOLN TO EQUAL. CONSTRAINTS SATISFIES INEQUAL.
C     CONSTRAINTS WHEN THERE ARE NO DEGREES OF FREEDOM LEFT.
      IF (.NOT.(KRANKE.EQ.N .AND. MG.GT.0)) GO TO 320
      XNORM = DASUM(N,X,1)
      MAPKE1 = MA + KRANKE + 1
      MEND = MA + KRANKE + MG
      DO 310 I=MAPKE1,MEND
        SIZE = DASUM(N,W(I,1),MDW)*XNORM + DABS(W(I,NP1))
        IF (.NOT.(W(I,NP1).GT.TAU*SIZE)) GO TO 300
        MODE = MODE + 2
        GO TO 450
  300   CONTINUE
  310 CONTINUE
  320 CONTINUE
  330 IF (.NOT.(KRANKE.GT.0)) GO TO 420
C
C     REPLACE DIAG. TERMS OF LOWER TRAP. MATRIX.
      CALL DCOPY(KRANKE, WS(KRANKE+1), 1, W, MDW+1)
C
C     REAPPLY TRANS TO PUT SOLN IN ORIGINAL COORDINATES.
      DO 340 II=1,KRANKE
        I = KRANKE + 1 - II
        CALL H12(2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1)
  340 CONTINUE
C
C     COMPUTE COV MATRIX OF EQUAL. CONSTRAINED PROBLEM.
      IF (.NOT.(COV)) GO TO 410
      DO 400 JJ=1,KRANKE
        J = KRANKE + 1 - JJ
        IF (.NOT.(J.LT.N)) GO TO 390
        RB = WS(J)*W(J,J)
        IF (RB.NE.ZERO) RB = ONE/RB
        JP1 = J + 1
        DO 350 I=JP1,N
          W(I,J) = DDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW)*RB
  350   CONTINUE
        GAM = DDOT(N-J,W(JP1,J),1,W(J,JP1),MDW)*RB
        GAM = HALF*GAM
        CALL DAXPY(N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1)
        DO 370 I=JP1,N
          DO 360 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)
  360     CONTINUE
  370   CONTINUE
        UJ = WS(J)
        VJ = GAM*UJ
        W(J,J) = UJ*VJ + UJ*VJ
        DO 380 I=JP1,N
          W(J,I) = UJ*W(I,J) + VJ*W(J,I)
  380   CONTINUE
        CALL DCOPY(N-J, W(J,JP1), MDW, W(JP1,J), 1)
  390   CONTINUE
  400 CONTINUE
  410 CONTINUE
C
C     APPLY THE SCALING TO THE COVARIANCE MATRIX.
  420 IF (.NOT.(COV)) GO TO 440
      DO 430 I=1,N
        L = N1 + I
        CALL DSCAL(N, WS(L-1), W(I,1), MDW)
        CALL DSCAL(N, WS(L-1), W(1,I), 1)
  430 CONTINUE
  440 CONTINUE
  450 CONTINUE
C
C     RESCALE SOLN. VECTOR.
      IF (.NOT.(MODE.LE.1)) GO TO 470
      DO 460 J=1,N
        L = N1 + J
        X(J) = X(J)*WS(L-1)
  460 CONTINUE
  470 IP(1) = KRANKE
      IP(3) = IP(3) + 2*KRANKE + N
      RETURN
  480 CONTINUE
C     TO PROCESS-OPTION-VECTOR
C
C     THE NOMINAL TOLERANCE USED IN THE CODE
C     FOR THE EQUALITY CONSTRAINT EQUATIONS.
      TAU = DSQRT(DRELPR)
C
C     THE NOMINAL COLUMN SCALING USED IN THE CODE IS
C     THE IDENTITY SCALING.
      WS(N1) = ONE
      CALL DCOPY(N, WS(N1), 0, WS(N1), 1)
C
C     NO COVARIANCE MATRIX IS NOMINALLY COMPUTED.
      COV = .FALSE.
C
C     DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE.
      NOPT = 1000
      NTIMES = 0
C
C     DEFINE BOUND FOR POSITIVE VALUES OF LINK.
      NLINK = 100000
      LAST = 1
      LINK = PRGOPT(1)
      IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 490
      NERR = 3
      IOPT = 1
      CALL XERROR(38HLSEI( ) THE OPTION VECTOR IS UNDEFINED, 38, NERR,
     * IOPT)
      MODE = 4
      RETURN
  490 IF (.NOT.(LINK.GT.1)) GO TO 540
      NTIMES = NTIMES + 1
      IF (.NOT.(NTIMES.GT.NOPT)) GO TO 500
      NERR = 3
      IOPT = 1
      CALL XERROR(
     * 52HLSEI( ). THE LINKS IN THE OPTION VECTOR ARE CYCLING., 52,
     * NERR, IOPT)
      MODE = 4
      RETURN
  500 KEY = PRGOPT(LAST+1)
      IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 520
      DO 510 J=1,N
        T = DNRM2(M,W(1,J),1)
        IF (T.NE.ZERO) T = ONE/T
        L = N1 + J
        WS(L-1) = T
  510 CONTINUE
  520 IF (KEY.EQ.3) CALL DCOPY(N, PRGOPT(LAST+2), 1, WS(N1), 1)
      IF (KEY.EQ.4) TAU = DMAX1(DRELPR,PRGOPT(LAST+2))
      NEXT = PRGOPT(LINK)
      IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 530
      NERR = 3
      IOPT = 1
      CALL XERROR(38HLSEI( ) THE OPTION VECTOR IS UNDEFINED, 38, NERR,
     * IOPT)
      MODE = 4
      RETURN
  530 LAST = LINK
      LINK = NEXT
      GO TO 490
  540 DO 550 J=1,N
        L = N1 + J
        CALL DSCAL(M, WS(L-1), W(1,J), 1)
  550 CONTINUE
      GO TO 560
  560 GO TO IGO990, (90)
      END


! This checks that the shape of the SHAPE intrinsic is known.
PROGRAM shape_reshape
   INTEGER, ALLOCATABLE :: I(:,:)
   ALLOCATE(I(2,2))
   I = RESHAPE((/1,2,3,4/),SHAPE=SHAPE(I))
   DEALLOCATE(I)
END PROGRAM


module quad_simpson_mod
    use :: quad_mod
    implicit none

    private
    type, public, extends(quad_t) :: quad_simpson_t
    contains
        procedure :: compute => compute_simpson
    end type

    interface quad_simpson_t
        module procedure :: create_quad
    end interface

contains

    function create_quad() result(quad)
        implicit none
        type(quad_simpson_t) :: quad
    end function create_quad

    function compute_simpson(this, func, a, b) result(res)
        implicit none
        class(quad_simpson_t), intent(in) :: this
        procedure(func_t) :: func
        real, value :: a, b
        real :: res
        integer, parameter :: n = 10
        integer :: i
        real :: delta_x

        delta_x = (b - a)/n
        res = func(a) + func(b)
        do i = 1, n - 1, 2
            res = res + 4.0*func(a + i*delta_x)
        end do
        do i = 2, n - 1, 2
            res = res + 2.0*func(a + i*delta_x)
        end do
        res = res*delta_x/3.0
    end function compute_simpson

end module quad_simpson_mod


C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.
C
C    $Id: example.f,v 1.1 2002/05/02 18:52:15 andreasw Exp $
C
C =============================================================================
C
C     This is an example for the usage of IPOPT.
C     It implements problem 71 from the Hock-Schittkowsky test suite:
C
C     min   x1*x4*(x1 + x2 + x3)  +  x3
C     s.t.  x1*x2*x3*x4  -  x5             -  25  =  0
C           x1**2 + x2**2 + x3**2 + x4**2  -  40  =  0
C           1 <=  x1,x2,x3,x4  <= 5
C           0 <=  x5
C
C     Starting point:
C        x = (1, 5, 5, 1, -24)
C
C     Optimal solution:
C        x = (1.00000000, 4.74299963, 3.82114998, 1.37940829, 0)
C
C =============================================================================
C
C
C =============================================================================
C
C                            Main driver program
C
C =============================================================================
C
      program example
C
      implicit none
C
C     Define work space:
C
      integer     LRW,         LIW
      parameter  (LRW = 10000, LIW = 10000)
      integer          IW(LIW)
      double precision RW(LRW)
C
C     Size of the problem (no. of variables and equality constraints)
C
      integer     N,     M
      parameter  (N = 5, M = 2)
      double precision LAM(M)
C
C     Vector of variables
C
      double precision X(N)
C
C     Number of lower and upper bounds
C
      integer     NLB,     NUB
      parameter  (NLB = 5, NUB = 4)
C
C     Vector of lower and upper bounds
C
      integer             ILB(NLB),    IUB(NUB)
      double precision BNDS_L(NLB), BNDS_U(NUB), V_L(NLB), V_U(NUB)
C
C     Algorithmic Parameters (INITPARAMS)
C
      integer NARGS
      double precision ARGS(50)
      character*20 CARGS(50)
C
      integer i, IERR, ITER
C
C     Set initial point and bounds:
C
      data X      / 1d0, 5d0, 5d0, 1d0, -24d0 /
      data ILB    /   1,   2,   3,   4,     5 /
      data BNDS_L / 1d0, 1d0, 1d0, 1d0,   0d0 /
      data IUB    /   1,   2,   3,   4 /
      data BNDS_U / 5d0, 5d0, 5d0, 5d0 /
C
C     Set algorithmic parameters:
C
      NARGS = 1
      ARGS(1) = 1.d-10
      CARGS(1) = 'dtol'
      call INITPARAMS(IERR, NARGS, ARGS, CARGS)
      if( IERR.ne.0 ) then
         write(*,*) 'Error initializing algorithmic parameters.'
         write(*,*) 'IERR = ',IERR
         write(*,*)
         write(*,*)
     1        'You might want to check IPOPT.DAT (if you set QCNR>0)'
         write(*,*)
         stop
      endif
C
C     Call optimization routine:
C
      call IPOPT(N, X, M, NLB, ILB, BNDS_L, NUB, IUB, BNDS_U, V_L, V_U,
     1     LAM, LRW, RW, LIW, IW, ITER, IERR)
C
C     Output:
C
      if( IERR.eq.0 ) then
         write(*,*)
         write(*,*) 'The solution was found after ',ITER,' Iterations.'
         write(*,*)
         write(*,*) 'The optimal values of X are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'X  (',i,') = ',X(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the lower bounds are:'
         write(*,*)
         do i = 1, NLB
            write(*,*) 'V_L(',ILB(i),') = ',V_L(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the upper bounds are:'
         write(*,*)
         do i = 1, NUB
            write(*,*) 'V_U(',IUB(i),') = ',V_U(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the equality constraints are:'
         write(*,*)
         do i = 1, M
            write(*,*) 'LAM(',i,') = ',LAM(i)
         enddo
         write(*,*)
      else
         write(*,*)
         write(*,*) 'An error occoured after ',ITER,' Iterations.'
         write(*,*) 'The error code is ',IERR
         write(*,*)
      endif
C
      end
C
C =============================================================================
C
C                    Computation of objective function
C
C =============================================================================
C
      subroutine EVAL_F(N, X, F)
      implicit none
      integer N
      double precision F, X(N)
      F = X(1)*X(4)*(X(1)+X(2)+X(3)) + X(3)
      return
      end
C
C =============================================================================
C
C                Computation of gradient of objective function
C
C =============================================================================
C
      subroutine EVAL_G(N, X, G)
      implicit none
      integer N
      double precision G(N), X(N)
      G(1) = X(4)*(2d0*X(1)+X(2)+X(3))
      G(2) = X(1)*X(4)
      G(3) = X(1)*X(4) + 1d0
      G(4) = X(1)*(X(1)+X(2)+X(3))
      G(5) = 0d0
      return
      end
C
C =============================================================================
C
C                     Computation of equality constraints
C
C =============================================================================
C
      subroutine EVAL_C(N, X, M, C)
      implicit none
      integer N, M
      double precision C(M), X(N)
      C(1) = X(1)*X(2)*X(3)*X(4) - X(5) - 25d0
      C(2) = X(1)**2 + X(2)**2 + X(3)**2 + X(4)**2 - 40d0
      return
      end
C
C =============================================================================
C
C                Computation of Jacobian of equality constraints
C
C =============================================================================
C
      subroutine EVAL_A(TASK, N, X, NZ, A, ACON, AVAR)
      integer TASK, N, NZ
      double precision X(N), A(NZ)
      integer ACON(NZ), AVAR(NZ), I
C
C     structure of Jacobian:
C
      integer AVAR1(9), ACON1(9)
      data  AVAR1 /1, 2, 3, 4, 5, 1, 2, 3, 4/
      data  ACON1 /1, 1, 1, 1, 1, 2, 2, 2, 2/
      save  AVAR1, ACON1
C
      if( TASK.eq.0 ) then
         NZ = 9
      else
        Do I = 1, 9
          AVAR(I) = AVAR1(I)
          ACON(I) = ACON1(I)
        EndDo
        A(1) = X(2)*X(3)*X(4)
        A(2) = X(1)*X(3)*X(4)
        A(3) = X(1)*X(2)*X(4)
        A(4) = X(1)*X(2)*X(3)
        A(5) = -1d0
        A(6) = 2d0*X(1)
        A(7) = 2d0*X(2)
        A(8) = 2d0*X(3)
        A(9) = 2d0*X(4)
      endif
      return
      end
C
C =============================================================================
C
C                Computation of Hessian of Lagrangian
C
C =============================================================================
C
      subroutine EVAL_H(TASK, N, X, M, LAM, NNZH, HESS, IRNH, ICNH)
      implicit none
      integer TASK, N, M, NNZH, i
      double precision X(N), LAM(M), HESS(NNZH)
      integer IRNH(NNZH), ICNH(NNZH)
C
C     structure of Hessian:
C
      integer IRNH1(10), ICNH1(10)
      data  IRNH1 /1, 2, 2, 3, 3, 3, 4, 4, 4, 4/
      data  ICNH1 /1, 1, 2, 1, 2, 3, 1, 2, 3, 4/
      save  IRNH1, ICNH1

      if( TASK.eq.0 ) then
         NNZH = 10
      else
         do i = 1, 10
            IRNH(i) = IRNH1(i)
            ICNH(i) = ICNH1(i)
            HESS(i) = 0d0
         enddo
C
C     objective function
C
         HESS(1) = 2d0*X(4)
         HESS(2) = X(4)
         HESS(4) = X(4)
         HESS(7) = 2d0*X(1) + X(2) + X(3)
         HESS(8) = X(1)
         HESS(9) = X(1)
C
C     first constraint
C
         HESS(2) = HESS(2) + LAM(1) * X(3)*X(4)
         HESS(4) = HESS(4) + LAM(1) * X(2)*X(4)
         HESS(5) = HESS(5) + LAM(1) * X(1)*X(4)
         HESS(7) = HESS(7) + LAM(1) * X(2)*X(3)
         HESS(8) = HESS(8) + LAM(1) * X(1)*X(3)
         HESS(9) = HESS(9) + LAM(1) * X(1)*X(2)
C
C     second constraint
C
         HESS(1) = HESS(1) + LAM(2) * 2d0
         HESS(3) = HESS(3) + LAM(2) * 2d0
         HESS(6) = HESS(6) + LAM(2) * 2d0
         HESS(10)= HESS(10)+ LAM(2) * 2d0
      endif
      return
      end


C
      SUBROUTINE MM(N, A, B, C)
      INTEGER N
      REAL A(N, *), B(N, *), C(N, *)
C
      DO I = 1, N
         CALL SMXPY(N, A(1, I), C(1, I), B)
      ENDDO
C
      RETURN
      END
C
C
C
      SUBROUTINE SMXPY(D, Y, X, M)
      INTEGER D
      REAL X(*), Y(*), M(D, *)
C
      DO J = 1, D
         Y(J) = 0
         DO K  = 1, D
            Y(J) = Y(J) + X(K)*M(J, K)
         ENDDO
      ENDDO
C
      RETURN
      END


PROGRAM TEST_NANINF

  ! PROGRAM TO TEST DISPLAY OF NOT-A-NUMBER-S AND INFINITIES BY M_display
  ! (Appropriate for compilers that support IEEE-arithmetic as described in the Fortran 2003 standard)

  USE, INTRINSIC :: IEEE_ARITHMETIC
  USE TEST_NANINF_MOD
  ! USE DISP_R16MOD ! uncomment this line if testing of disp_r16mod (quad precision) is required
  !
  ! Copyright (c) 2008, Kristj n J nasson, Dept. of Computer Science, University of
  ! Iceland (jonasson@hi.is). This software is free. For details see the file README.

  implicit none
  real(srk) nan, inf, minf

  nan = ieee_value(0._srk, ieee_quiet_nan)
  inf = ieee_value(0._srk, ieee_positive_inf)
  minf = ieee_value(0._srk, ieee_negative_inf)

  call test_ni(nan, inf, minf)

END PROGRAM TEST_NANINF


subroutine amrex_probinit (init,name,namlen,problo,probhi) bind(c)

  implicit none

  integer, intent(in) :: init, namlen
  integer, intent(in) :: name(namlen)
  double precision, intent(in) :: problo(*), probhi(*)

  ! nothing needs to be done here

end subroutine amrex_probinit

subroutine initdata(level, time, lo, hi, &
     phi, phi_lo, phi_hi, &
     dx, prob_lo) bind(C, name="initdata")

  implicit none
  integer, intent(in) :: level, lo(3), hi(3), phi_lo(3), phi_hi(3)
  double precision, intent(in) :: time
  double precision, intent(inout) :: phi(phi_lo(1):phi_hi(1), &
       &                                 phi_lo(2):phi_hi(2), &
       &                                 phi_lo(3):phi_hi(3))
  double precision, intent(in) :: dx(3), prob_lo(3)

  integer          :: dm
  integer          :: i,j,k
  double precision :: x,y,z,r2

  if (phi_lo(3) .eq. 0 .and. phi_hi(3) .eq. 0) then
     dm = 2
  else
     dm = 3
  end if

  !$omp parallel do private(i,j,k,x,y,z,r2) collapse(2)
  do k=lo(3),hi(3)
     do j=lo(2),hi(2)
        z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
        y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
        do i=lo(1),hi(1)
           x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

           if ( dm.eq. 2) then
              r2 = ((x-0.5d0)**2 + (y-0.75d0)**2) / 0.01d0
              phi(i,j,k) = 1.d0 + exp(-r2)
           else
              r2 = ((x-0.5d0)**2 + (y-0.75d0)**2 + (z-0.5d0)**2) / 0.01d0
              phi(i,j,k) = 1.d0 + exp(-r2)
           end if
        end do
     end do
  end do
  !$omp end parallel do

end subroutine initdata


      !!####LIBRARY MODULE: LIB_SPARSKIT_infofun
      MODULE LIB_SPARSKIT_infofun

        !!###PURPOSE
        !! Provide information routines about <SPARSKIT> matrices.

      !!###MODIFICATIONS
        !! {May2006}
        !!   [waw] | William A. Wieselquist | william.wieselquist AT gmail.com
        !!   @ conversion to module

        !!###DEPENDENCIES
        USE LIB_SPARSKIT_formats !!((04-A-LIB_SPARSKIT_formats.f))

      !!###DESCRIPTION
c----------------------------------------------------------------------c
c                          S P A R S K I T                             c
c----------------------------------------------------------------------c
c                  INFORMATION ROUTINES. INFO MODULE                   c
c----------------------------------------------------------------------c
c bandwidth :  Computes  ml     = lower_bandwidth(A)                   c
c                        mu     = upper_bandwidth(A)                   c
c                        iband  = max_bandwidth(A)                     c
c                        bndav  = average_bandwidth(A)                 c
c nonz      :  Computes  nzmaxc = max_column_length(A)                 c
c                        nzminc = min_column_length(A)                 c
c                        nzmaxr = max_row_length(A)                    c
c                        nzminr = min_row_length(A)                    c
c                        nzcol  = zero_column_number(A)                c
c                        nzrow  = zero_row_number(A)                   c
c diag_domi :  Computes  ddomc  = diag_domi_column_percentage(A)       c
c                        ddomr  = diag_domi_row_percentage(A)          c
c frobnorm  :  Computes  Fnorm  = Frobenius_norm(A)                    c
c ansym     :  Computes  fas    = sym_part_Frobenius_norm(A)           c
c                        fan    = nonsym_part_Frobenius_norm(A)        c
c                        imatch = matching_elements_number(A)          c
c                        av     = relative_sym_match(A)                c
c distaij   :  Computes  dist   = average_dist_of_a(i,j)(A)            c
c                        std    = standard_deviation(A)                c
c skyline   :  Computes  nsky   = nonzero_number_in_skyline(A)         c
c distdiag  :  Computes  dist   = element_number_in_eachdiag(A)        c
c bandpart  :  Computes  band   = bandwidth_width(A)                   c
c n_imp_diag:  Computes  ndiag  = important_diag_number(A)             c
c nonz_lud  :  Computes  nlower = nonzero_number_of_lower_part(A)      c
c                        nupper = nonzero_number_of_upper_part(A)      c
c                        ndiag  = nonzero_number_of_maindiag(A)        c
c avnz_col  :  Computes  av     = average_nonzero_number_in_column(A)  c
c                        st     = standard_deviation(A)                c
c vbrinfo   :  Print info on matrix in variable block row format       c
c----------------------------------------------------------------------c

        !!###MODULE PROCEDURES
      CONTAINS

      subroutine bandwidth(n,ja, ia, ml, mu, iband, bndav)
      implicit none
      integer n, ml, mu, iband
      integer ja(*), ia(n+1)
      real*8 bndav
c-----------------------------------------------------------------------
c this routine computes the lower, upper, maximum, and average
c bandwidths.     revised -- July 12, 2001  -- bug fix -- YS.
c-----------------------------------------------------------------------
c On Entry:
c----------
c n     = integer. column dimension of matrix
c a     = real array containing the nonzero elements of the matrix
c         the elements are stored by columns in order
c         (i.e. column i comes before column i+1, but the elements
c         within each column can be disordered).
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c
c on return
c----------
c ml    = lower bandwidth as defined by
c        ml = max(i-j | all  a(i,j).ne. 0)
c mu    = upper bandwidth as defined by
c        mu = max ( j-i | all  a(i,j).ne. 0 )
c iband =  maximum bandwidth as defined by
c         iband = Max (  Max [ j | a(i,j) .ne. 0 ] -
c                        Min [ j | a(i,j) .ne. 0 ] )
c bndav = Average Bandwidth
c-----------------------------------------------------------------------
c     locals
      integer max
      integer j0, j1, jminc, jmaxc, i
c-----------------------------------------------------------------------
      ml = -n
      mu = -n
      bndav = 0.0d0
      iband = 0
      do 10 i=1,n
         j0 = ia(i)
         j1 = ia(i+1) - 1
         jminc = ja(j0)
         jmaxc = ja(j1)
         ml = max(ml,i-jminc)
         mu = max(mu,jmaxc-i)
         iband = max(iband,jmaxc-jminc+1)
         bndav = bndav+real( jmaxc-jminc+1)
 10   continue
      bndav = bndav/real(n)
      return
c-----end-of-bandwidth--------------------------------------------------
c-----------------------------------------------------------------------
      end subroutine
c-----------------------------------------------------------------------
      subroutine nonz(n,sym, ja, ia, iao, nzmaxc, nzminc,
     *     nzmaxr, nzminr, nzcol, nzrow)
      implicit none
      integer n , nzmaxc, nzminc, nzmaxr, nzminr, nzcol, nzrow
      integer ja(*), ia(n+1), iao(n+1)
      logical sym
c----------------------------------------------------------------------
c     this routine computes maximum numbers of nonzero elements
c     per column/row, minimum numbers of nonzero elements per column/row,
c     and  numbers of zero columns/rows.
c----------------------------------------------------------------------
c     On Entry:
c----------
c     n     = integer column dimension of matrix
c     ja    = integer array containing the row indices of elements in a
c     ia    = integer array containing of length n+1 containing the
c     pointers to the beginning of the columns in arrays a and ja.
c     It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c     iao   = similar array for the transpose of the matrix.
c     sym   = logical variable indicating whether or not the matrix is
c     stored in symmetric mode.
c     on return
c----------
c     nzmaxc = max length of columns
c     nzminc = min length of columns
c     nzmaxr = max length of rows
c nzminr = min length of rows
c     nzcol  = number of zero columns
c     nzrow = number of zero rows
c-----------------------------------------------------------------------
      integer  i, j0, j0r, j1r, indiag, k, j1, lenc, lenr
c
      nzmaxc = 0
      nzminc = n
      nzmaxr = 0
      nzminr = n
      nzcol  = 0
      nzrow  = 0
c-----------------------------------------------------------------------
      do 10 i = 1, n
         j0 = ia(i)
         j1 = ia(i+1)
         j0r = iao(i)
         j1r = iao(i+1)
         indiag = 0
         do 20 k=j0, j1-1
            if (ja(k) .eq. i) indiag = 1
 20      continue
c
         lenc = j1-j0
         lenr = j1r-j0r
c
         if (sym) lenc = lenc + lenr - indiag
         if (lenc .le. 0) nzcol = nzcol +1
         nzmaxc = max0(nzmaxc,lenc)
         nzminc = min0(nzminc,lenc)
         if (lenr .le. 0) nzrow = nzrow+1
         nzmaxr = max0(nzmaxr,lenr)
         nzminr = min0(nzminr,lenr)
 10   continue
      return
      end subroutine
c-----------------------------------------------------------------------
      subroutine diag_domi(n,sym,valued,a, ja,ia,ao,jao, iao,
     *     ddomc, ddomr)
      implicit none
      real*8 a(*), ao(*), ddomc, ddomr
      integer n, ja(*), ia(n+1), jao(*), iao(n+1)
      logical sym, valued
c-----------------------------------------------------------------
c     this routine computes the percentage of weakly diagonally
c     dominant rows/columns
c-----------------------------------------------------------------
c     on entry:
c     ---------
c     n     = integer column dimension of matrix
c a     = real array containing the nonzero elements of the matrix
c     the elements are stored by columns in order
c     (i.e. column i comes before column i+1, but the elements
c     within each column can be disordered).
c     ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c     pointers to the beginning of the columns in arrays a and ja.
c     It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c     ao    = real array containing the nonzero elements of the matrix
c     the elements are stored by rows in order
c     (i.e. row i comes before row i+1, but the elements
c     within each row can be disordered).
c ao,jao, iao,
c     structure for transpose of a
c     sym   = logical variable indicating whether or not the matrix is
c     symmetric.
c     valued= logical equal to .true. if values are provided and .false.
c         if only the pattern of the matrix is provided. (in that
c     case a(*) and ao(*) are dummy arrays.
c
c     ON RETURN
c----------
c     ddomc = percentage of weakly diagonally dominant columns
c     ddomr = percentage of weakly diagonally dominant rows
c-------------------------------------------------------------------
c     locals
      integer i, j0, j1, k, j
      real*8 aii, dsumr, dsumc
c     number of diagonally dominant columns
c     real arithmetic used to avoid problems.. YS. 03/27/01
      ddomc = 0.0
c     number of diagonally dominant rows
      ddomr = 0.0
      do 10 i = 1, n
         j0 = ia(i)
         j1 = ia(i+1) - 1
         if (valued) then
            aii = 0.0d0
            dsumc = 0.0d0
            do 20 k=j0,j1
               j = ja(k)
               if (j .eq. i) then
                  aii = abs(a(k))
               else
                  dsumc = dsumc + abs(a(k))
               endif
 20         continue
            dsumr = 0.0d0
            if (.not. sym) then
               do 30 k=iao(i), iao(i+1)-1
                  if (jao(k) .ne. i) dsumr = dsumr+abs(ao(k))
 30            continue
            else
               dsumr = dsumc
            endif
            if (dsumc .le. aii) ddomc = ddomc + 1.0
            if (dsumr .le. aii) ddomr = ddomr + 1.0
         endif
 10   continue
      ddomr = ddomr / real(n)
      ddomc = ddomc / real(n)
      return
c-----------------------------------------------------------------------
c--------end-of-diag_moni-----------------------------------------------
      end subroutine
c-----------------------------------------------------------------------
      subroutine frobnorm(n,sym,a,ja,ia,Fnorm)
      implicit none
      integer n
      real*8 a(*),Fnorm
      integer ja(*),ia(n+1)
      logical sym
c--------------------------------------------------------------------------
c     this routine computes the Frobenius norm of A.
c--------------------------------------------------------------------------
c     on entry:
c-----------
c n      = integer colum dimension of matrix
c a      = real array containing the nonzero elements of the matrix
c          the elements are stored by columns in order
c          (i.e. column i comes before column i+1, but the elements
c          within each column can be disordered).
c ja     = integer array containing the row indices of elements in a.
c ia     = integer array containing of length n+1 containing the
c          pointers to the beginning of the columns in arrays a and
c          ja. It is assumed that ia(*)= 1 and ia(n+1)  = nnz +1.
c sym    = logical variable indicating whether or not the matrix is
c          symmetric.
c
c on return
c-----------
c Fnorm  = Frobenius norm of A.
c--------------------------------------------------------------------------
      real*8 Fdiag
      integer i, k
      Fdiag = 0.0
      Fnorm = 0.0
      do i =1,n
         do k = ia(i), ia(i+1)-1
            if (ja(k) .eq. i) then
               Fdiag = Fdiag + a(k)**2
            else
               Fnorm = Fnorm + a(k)**2
            endif
         enddo
      enddo
      if (sym) then
         Fnorm = 2*Fnorm +Fdiag
      else
        Fnorm = Fnorm + Fdiag
      endif
      Fnorm = sqrt(Fnorm)
      return
      end subroutine
c----------------------------------------------------------------------
      subroutine ansym(n,sym,a,ja,ia,ao,jao,iao,imatch,
     *     av,fas,fan)
c---------------------------------------------------------------------
c     this routine computes the Frobenius norm of the symmetric and
c     non-symmetric parts of A, computes number of matching elements
c     in symmetry and relative symmetry match.
c---------------------------------------------------------------------
c on entry:
c----------
c n   = integer column dimension of matrix
c a   = real array containing the nonzero elements of the matrix
c       the elements are stored by columns in order
c       (i.e. column i comes before column i+1, but the elements
c       within each column can be disordered).
c ja  = integer array containing the row indices of elements in a
c ia  = integer array containing of length n+1 containing the
c       pointers to the beginning of the columns in arrays a and ja.
c       It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c sym = logical variable indicating whether or not the matrix is
c       symmetric.
c on return
c----------
c fas   = Frobenius norm of symmetric part
c fan   = Frobenius norm of non-symmetric part
c imatch = number of matching elements in symmetry
c av     = relative symmetry match (symmetry = 1)
c ao,jao,iao = transpose of A just as a, ja, ia contains
c              information of A.
c-----------------------------------------------------------------------
      implicit real*8 (a-h, o-z)
      real*8 a(*),ao(*),fas,fan,av, Fnorm, st
      integer n, ja(*), ia(n+1), jao(*), iao(n+1),imatch
      logical sym
c-----------------------------------------------------------------------
      nnz    = ia(n+1)-ia(1)
      call csrcsc(n,1,1,a,ja,ia,ao,jao,iao)
      if (sym) goto 7
      st     = 0.0d0
      fas    = 0.0d0
      fan    = 0.0d0
      imatch = 0
      do 6 i=1,n
         k1 = ia(i)
         k2 = iao(i)
         k1max = ia(i+1) - 1
         k2max = iao(i+1) - 1
c
 5       if (k1 .gt. k1max .or. k2 .gt. k2max) goto 6
c
         j1 = ja(k1)
         j2 = jao(k2)
         if (j1 .ne. j2 ) goto 51
         fas = fas + (a(k1)+ao(k2))**2
         fan = fan + (a(k1)-ao(k2))**2
         st  = st + a(k1)**2
         imatch = imatch + 1
 51      k1 = k1+1
         k2 = k2+1
         if (j1 .lt. j2)  k2 = k2 - 1
         if (j1 .gt. j2)  k1 = k1 - 1
         goto 5
 6    continue
      fas = 0.25D0 * fas
      fan = 0.25D0 * fan
 7    call frobnorm(n,sym,ao,jao,iao,Fnorm)
      if (sym) then
         imatch = nnz
         fas = Fnorm
         fan = 0.0d0
      else
         if (imatch.eq.nnz) then
            st = 0.0D0
         else
            st = 0.5D0 * (Fnorm**2 - st)
            if (st.lt.0.0D0) st = 0.0D0
         endif
         fas = sqrt(fas + st)
         fan = sqrt(fan + st)
      endif
      av = real(imatch)/real(nnz)
      return
      end subroutine
c------end-of-ansym-----------------------------------------------------
c-----------------------------------------------------------------------
      subroutine distaij(n,nnz,sym,ja,ia,dist, std)
      implicit real*8 (a-h, o-z)
      real*8  dist, std
      logical sym
        integer ja(*), ia(n+1)
c-----------------------------------------------------------------------
c     this routine computes the average distance of a(i,j) from diag and
c     standard deviation  for this average.
c-----------------------------------------------------------------------
c On entry :
c-----------
c n     = integer. column dimension of matrix
c nnz   = number of nonzero elements of matrix
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c sym   = logical variable indicating whether or not the matrix is
c         symmetric.
c on return
c----------
c dist  = average distance of a(i,j) from diag.
c std   = standard deviation for above average.
c-----------------------------------------------------------------------
c
c distance of an element from diagonal.
c
      dist   = 0.0
      std = 0.0
      do 3 i=1,n
         j0 = ia(i)
         j1 = ia(i+1) - 1
         do 31 k=j0, j1
            j=ja(k)
            dist = dist + real(iabs(j-i) )
 31      continue
 3    continue
      dist = dist/real(nnz)
      do 6 i = 1, n
         do 61 k=ia(i), ia(i+1) - 1
            std=std+(dist-real(iabs(ja(k)-i)))**2
 61      continue
 6    continue
      std = sqrt(std/ real(nnz))
      return
      end subroutine
c-----------------------------------------------------------------------
      subroutine skyline(n,sym,ja,ia,jao,iao,nsky)
      implicit real*8 (a-h, o-z)
      integer n, ja(*), ia(n+1), jao(*), iao(n+1)
      integer nskyl, nskyu, nsky
      logical sym
c-------------------------------------------------------------------
c this routine computes the number of nonzeros in the skyline storage.
c-------------------------------------------------------------------
c
c On entry :
c-----------
c n     = integer. column dimension of matrix
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c iao   = integer array containing of length n+1 containing the
c         pointers to the beginning of the rows in arrays ao and jao.
c         It is assumed that iao(*) = 1 and iao(n+1) = nzz+1.
c jao   = integer array containing the column indices of elements in ao.
c sym   = logical variable indicating whether or not the matrix is
c         symmetric.
c on return
c----------
c nsky  = number of nonzeros in skyline storage
c-------------------------------------------------------------------
c
c nskyu = skyline storage for upper part
      nskyu = 0
c nskyl = skyline storage for lower part
      nskyl = 0
      do 10 i=1,n
         j0 = ia(i)
         j0r = iao(i)

         jminc = ja(j0)
         jminr = jao(j0r)
         if (sym) jminc = jminr

         nskyl = nskyl + i-jminr + 1
         nskyu = nskyu + i-jminc + 1

 10   continue
      nsky = nskyl+nskyu-n
      if (sym)  nsky = nskyl
      return
      end subroutine
c-----------------------------------------------------------------------
      subroutine distdiag(nrow,ncol,ja,ia,dist)
      implicit real*8 (a-h, o-z)
      integer nrow,ncol,ja(*), ia(nrow+1),dist(*)
c----------------------------------------------------------------------
c this routine computes the numbers of elements in each diagonal.
c----------------------------------------------------------------------
c On entry :
c-----------
c nrow  = integer. row dimension of matrix
c ncol  = integer. column dimension of matrix
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c on return
c----------
c dist  = integer array containing the numbers of elements in each of
c         the nrow+ncol-1 diagonals of A. dist(k) contains the
c         number of elements in diagonal '-nrow+k'.  k ranges from
c         1 to (nrow+ncol-1).
c----------------------------------------------------------------------
      nnz  = ia(nrow+1)-ia(1)
      n2   = nrow+ncol-1
      do 8 i=1, n2
         dist(i) = 0
 8    continue
      do 9 i=1, nrow
         k1 = ia(i)
         k2 = ia(i+1) -1
         do 91 k=k1, k2
            j = ja(k)
            dist(nrow+j-i) = dist(nrow+j-i) +1
 91      continue
 9    continue
      return
      end subroutine
c-----------------------------------------------------------------------
      subroutine bandpart(n,ja,ia,dist,nper,band)
      implicit real*8 (a-h, o-z)
      integer n,ja(*), ia(n+1),dist(*)
      integer nper,band
c-------------------------------------------------------------------------
c this routine computes the bandwidth of the banded matrix, which contains
c 'nper' percent of the original matrix.
c-------------------------------------------------------------------------
c On entry :
c-----------
c n     = integer. column dimension of matrix
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c dist  = integer array containing the numbers of elements in the
c         matrix with different distance of row indices and column
c         indices.
c nper  = percentage of matrix  within the bandwidth
c on return
c----------
c band  = the width of the bandwidth
c----------------------------------------------------------------------
      nnz  = ia(n+1)-ia(1)
      iacc  = dist(n)
      band  = 0
      j     = 0
 10   j     = j+1
      iacc  = iacc + dist(n+j) +dist(n-j)
      if (iacc*100 .le. nnz*nper) then
         band = band +1
         goto 10
      endif
      return
      end subroutine
c-----------------------------------------------------------------------
      subroutine  n_imp_diag(n,nnz,dist, ipar1,ndiag,ioff,dcount)
      implicit real*8 (a-h, o-z)
      real*8  dcount(*)
      integer n,nnz, dist(*), ndiag, ioff(*), ipar1
c-----------------------------------------------------------------------
c     this routine computes the most important diagonals.
c-----------------------------------------------------------------------
c
c On entry :
c-----------
c n     = integer. column dimension of matrix
c nnz   = number of nonzero elements of matrix
c dist  = integer array containing the numbers of elements in the
c         matrix with different distance of row indices and column
c         indices. ipar1 = percentage of nonzero  elements of A that
c         a diagonal should have in order to be an important diagonal
c on return
c----------
c ndiag = number of the most important diagonals
c ioff  = the offsets with respect to the main diagonal
c dcount= the accumulated percentages
c-----------------------------------------------------------------------
      n2 = n+n-1
      ndiag = 10
      ndiag = min0(n2,ndiag)
      itot  = 0
      ii = 0
      idiag = 0
c     sort diagonals by decreasing order of weights.
 40   jmax = 0
      i    = 1
      do 41 k=1, n2
         j = dist(k)
         if (j .lt. jmax) goto 41
         i = k
         jmax = j
 41   continue
c     permute ----
c     save offsets and accumulated count if diagonal is acceptable
c     (if it has at least ipar1*nnz/100 nonzero elements)
c     quite if no more acceptable diagonals --
c
      if (jmax*100 .lt. ipar1*nnz) goto 4
      ii = ii+1
      ioff(ii) = i-n
      dist(i)   = - jmax
      itot = itot + jmax
      dcount(ii) = real(100*itot)/real(nnz)
      if (ii .lt. ndiag) goto 40
 4    continue
      ndiag = ii
      return
c-----------------------------------------------------------------------
      end subroutine
c-----------------------------------------------------------------------
      subroutine nonz_lud(n,ja,ia,nlower, nupper, ndiag)
      implicit real*8 (a-h, o-z)
      integer n,  ja(*), ia(n+1)
      integer nlower, nupper, ndiag
c-----------------------------------------------------------------------
c this routine computes the number of nonzero elements in strict lower
c part, strict upper part, and main diagonal.
c-----------------------------------------------------------------------
c
c On entry :
c-----------
c n     = integer. column dimension of matrix
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c on return
c----------
c nlower= number of nonzero elements in strict lower part
c nupper= number of nonzero elements in strict upper part
c ndiag = number of nonzero elements in main diagonal
c-------------------------------------------------------------------
c
c number of nonzero elements in upper part
c
      nupper = 0
      ndiag = 0

      do 3 i=1,n
c     indiag = nonzero diagonal element indicator
         do 31 k=ia(i), ia(i+1)-1
            j=ja(k)
            if (j .lt. i) nupper = nupper+1
            if (j .eq. i) ndiag = ndiag + 1
 31      continue
 3    continue
      nlower = ia(n+1)-1-nupper-ndiag
      return
      end subroutine
c-----------------------------------------------------------------------
      subroutine avnz_col(n,ja,ia,iao, ndiag, av, st)
      implicit real*8 (a-h, o-z)
      real*8 av, st
      integer n,  ja(*), ia(n+1), iao(n+1)
c---------------------------------------------------------------------
c     this routine computes average number of nonzero elements/column and
c     standard deviation for this average
c---------------------------------------------------------------------
c
c On entry :
c-----------
c n     = integer. column dimension of matrix
c ja    = integer array containing the row indices of elements in a
c ia    = integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c         It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c ndiag = number of the most important diagonals
c On return
c----------
c av    = average number of nonzero elements/column
c st    = standard deviation for this average
c Notes
c---------
c standard deviation will not be correct for symmetric storage.
c----------------------------------------------------------------------
c     standard deviatioan for the average
      st = 0.0d0
c     average and standard deviation
c
      av = real(ia(n+1)-1)/real(n)
c
c     will be corrected later.
c
      do 3 i=1,n
         j0 = ia(i)
         j1 = ia(i+1) - 1
c     indiag = nonzero diagonal element indicator
         do 31 k=j0, j1
            j=ja(k)
 31      continue
         lenc = j1+1-j0
         st = st + (real(lenc) - av)**2
 3    continue
c
      st = sqrt( st / real(n) )
      return
      end subroutine
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
      subroutine vbrinfo(nr, nc, kvstr, kvstc, ia, ja, ka, iwk, iout)
c-----------------------------------------------------------------------
      integer nr, nc, kvstr(nr+1), kvstc(nc+1), ia(nr+1), ja(*), ka(*)
      integer iwk(nr+nc+2+nr), iout
c-----------------------------------------------------------------------
c     Print info on matrix in variable block row format.
c-----------------------------------------------------------------------
c     On entry:
c--------------
c     nr,nc   = matrix block row and block column dimension
c     kvstr   = first row number for each block row
c     kvstc   = first column number for each block column
c     ia,ja,ka,a = input matrix in VBR format
c     iout    = unit number for printed output
c
c     On return:
c---------------
c     Printed output to unit number specified in iout.  If a non-square
c     matrix is provided, the analysis will be performed on the block
c     rows, otherwise a row/column conformal partitioning will be used.
c
c     Work space:
c----------------
c     iwk(1:nb+1) = conformal block partitioning
c        (nb is unknown at start but is no more than nr+nc)
c     iwk(nb+2:nb+2+nr) = frequency of each blocksize
c     The workspace is not assumed to be initialized to zero, nor is it
c     left that way.
c
c-----------------------------------------------------------------------
c-----local variables
      integer n, nb, nnz, nnzb, i, j, neq, max, num
      character*101 tmpst
      integer bsiz(10), freq(10)
c-----------------------------------------------------------------------
      n = kvstr(nr+1)-1
      nnz = ka(ia(nr+1)) - ka(1)
      nnzb = ia(nr+1) - ia(1)
      write (iout, 96)
      write (iout, 100) n, nnz, real(nnz)/real(n)
      write (iout, 101) nr, nnzb, real(nnzb)/real(nr)
c-----if non-square matrix, do analysis on block rows,
c     else do analysis on conformal partitioning
      if (kvstr(nr+1) .ne. kvstc(nc+1)) then
         write (iout, 103)
         do i = 1, nr+1
            iwk(i) = kvstr(i)
         enddo
         nb = nr
      else
         call kvstmerge(nr, kvstr, nc, kvstc, nb, iwk)
         if ((nr .ne. nc) .or. (nc .ne. nb)) write (iout, 104) nb
      endif
c-----accumulate frequencies of each blocksize
      max = 1
      iwk(1+nb+2) = 0
      do i = 1, nb
         neq = iwk(i+1) - iwk(i)
         if (neq .gt. max) then
            do j = max+1, neq
               iwk(j+nb+2) = 0
            enddo
            max = neq
         endif
         iwk(neq+nb+2) = iwk(neq+nb+2) + 1
      enddo
c-----store largest 10 of these blocksizes
      num = 0
      do i = max, 1, -1
         if ((iwk(i+nb+2) .ne. 0) .and. (num .lt. 10)) then
            num = num + 1
            bsiz(num) = i
            freq(num) = iwk(i+nb+2)
         endif
      enddo
c-----print information about blocksizes
      write (iout, 109) num
      write (tmpst,'(10i6)') (bsiz(j),j=1,num)
      write (iout,110) num,tmpst
      write (tmpst,'(10i6)') (freq(j),j=1,num)
      write (iout,111) tmpst
      write (iout, 96)
c-----------------------------------------------------------------------
 99    format (2x,38(2h *))
 96    format (6x,' *',65(1h-),'*')
 100   format(
     * 6x,' *  Number of rows                                   = ',
     * i10,'  *'/
     * 6x,' *  Number of nonzero elements                       = ',
     * i10,'  *'/
     * 6x,' *  Average number of nonzero elements/Row           = ',
     * f10.4,'  *')
 101   format(
     * 6x,' *  Number of block rows                             = ',
     * i10,'  *'/
     * 6x,' *  Number of nonzero blocks                         = ',
     * i10,'  *'/
     * 6x,' *  Average number of nonzero blocks/Block row       = ',
     * f10.4,'  *')
 103   format(
     * 6x,' *  Non-square matrix.                                 ',
     *     '            *'/
     * 6x,' *  Performing analysis on block rows.                 ',
     *     '            *')
 104   format(
     * 6x,' *  Non row-column conformal partitioning supplied.    ',
     *     '            *'/
     * 6x,' *  Using conformal partitioning.  Number of bl rows = ',
     * i10,'  *')
 109   format(
     * 6x,' *  Number of different blocksizes                   = ',
     * i10,'  *')
 110   format(6x,' *  The ', i2, ' largest dimension nodes',
     *     ' have dimension    : ',10x,'  *',/,
     * 6x,' *',a61,3x,' *')
 111   format(6x,' *  The frequency of nodes these ',
     *     'dimensions are      : ',10x,'  *',/,
     * 6x,' *',a61,3x,' *')
c---------------------------------
      return
      end subroutine
c-----------------------------------------------------------------------
c-----------------------end-of-vbrinfo----------------------------------
      end module


!*****************************************************************************
!
! Different implementations of a simple single precision A-X plus Y function
! on a CPU and GPU, to verify this code works.
!
! x = ax + y
! x,y,z: vector
! a: scalar
!*****************************************************************************

!*****************************************************************************
! Kernels
!*****************************************************************************

module saxpy_cuda_kernels_mod
contains

attributes(global) subroutine saxpy_gpu_cuda_kernel(a, x, y)
   implicit none
   real :: x(:), y(:)
   real, value :: a
   integer :: i, n

   n = size(x)
   i = blockDim%x * (blockIdx%x - 1) + threadIdx%x

   if (i<=n) then
      y(i) = a*x(i)+y(i)
   end if

end subroutine saxpy_gpu_cuda_kernel

end module saxpy_cuda_kernels_mod


      SUBROUTINE GENBUN (NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C
C     SUBROUTINE GENBUN SOLVES THE LINEAR SYSTEM OF EQUATIONS
C
C          A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
C
C          + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J)
C
C               FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C     THE INDICES I+1 AND I-1 ARE EVALUATED MODULO M, I.E.,
C     X(0,J) = X(M,J) AND X(M+1,J) = X(1,J), AND X(I,0) MAY BE EQUAL TO
C     0, X(I,2), OR X(I,N) AND X(I,N+1) MAY BE EQUAL TO 0, X(I,N-1), OR
C     X(I,1) DEPENDING ON AN INPUT PARAMETER.
C
C
C     * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C             * * * * * *   ON INPUT    * * * * * *
C
C     NPEROD
C       INDICATES THE VALUES THAT X(I,0) AND X(I,N+1) ARE ASSUMED TO
C       HAVE.
C
C       = 0  IF X(I,0) = X(I,N) AND X(I,N+1) = X(I,1).
C       = 1  IF X(I,0) = X(I,N+1) = 0  .
C       = 2  IF X(I,0) = 0 AND X(I,N+1) = X(I,N-1).
C       = 3  IF X(I,0) = X(I,2) AND X(I,N+1) = X(I,N-1).
C       = 4  IF X(I,0) = X(I,2) AND X(I,N+1) = 0.
C
C     N
C       THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.  N MUST BE GREATER
C       THAN 2.
C
C     MPEROD
C       = 0 IF A(1) AND C(M) ARE NOT ZERO
C       = 1 IF A(1) = C(M) = 0
C
C     M
C       THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.  M MUST BE GREATER
C       THAN 2.
C
C     A,B,C
C       ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE
C       COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE.  IF MPEROD = 0
C       THE ARRAY ELEMENTS MUST NOT DEPEND UPON THE INDEX I, BUT MUST BE
C       CONSTANT.  SPECIFICALLY, THE SUBROUTINE CHECKS THE FOLLOWING
C       CONDITION
C
C             A(I) = C(1)
C             C(I) = C(1)
C             B(I) = B(1)
C
C       FOR I=1,2,...,M.
C
C     IDIMY
C       THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS
C       IT APPEARS IN THE PROGRAM CALLING GENBUN.  THIS PARAMETER IS
C       USED TO SPECIFY THE VARIABLE DIMENSION OF Y.  IDIMY MUST BE AT
C       LEAST M.
C
C     Y
C       A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C       SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE.  Y MUST BE
C       DIMENSIONED AT LEAST M*N.
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.  W MAY REQUIRE UP TO 4*N + (10 + INT(LOG2(N)))*M
C       LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY
C       GENBUN AND IS RETURNED IN LOCATION W(1).
C
C
C             * * * * * *   ON OUTPUT     * * * * * *
C
C     Y
C       CONTAINS THE SOLUTION X.
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS  EXCEPT
C       FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  M .LE. 2  .
C       = 2  N .LE. 2
C       = 3  IDIMY .LT. M
C       = 4  NPEROD .LT. 0 OR NPEROD .GT. 4
C       = 5  MPEROD .LT. 0 OR MPEROD .GT. 1
C       = 6  A(I) .NE. C(1) OR C(I) .NE. C(1) OR B(I) .NE. B(1) FOR
C            SOME I=1,2,...,M.
C       = 7  A(1) .NE. 0 OR C(M) .NE. 0 AND MPEROD = 1
C
C     W
C       W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   A(M),B(M),C(M),Y(IDIMY,N),W(SEE PARAMETER LIST)
C     ARGUMENTS
C
C     LATEST         JUNE 1, 1976
C     REVISION
C
C     SUBPROGRAMS    GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,TRIX,TRI3,
C     REQUIRED       PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         NONE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        STANDARDIZED APRIL 1, 1973
C                    REVISED AUGUST 20,1973
C                    REVISED JANUARY 1, 1976
C
C     ALGORITHM      THE LINEAR SYSTEM IS SOLVED BY A CYCLIC REDUCTION
C                    ALGORITHM DESCRIBED IN THE REFERENCE.
C
C     SPACE          4944(DECIMAL) = 11520(OCTAL) LOCATIONS ON THE NCAR
C     REQUIRED       CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE GENBUN IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N), BUT ALSO DEPENDS ON THE INPUT
C                    PARAMETER NPEROD.  SOME TYPICAL VALUES ARE LISTED
C                    IN THE TABLE BELOW.  MORE COMPREHENSIVE TIMING
C                    CHARTS MAY BE FOUND IN THE REFERENCE.
C                       TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                    UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE
C                    A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE
C                    'PURPOSE' WITH
C
C                       A(I) = C(I) = -0.5*B(I) = 1,       I=1,2,...,M
C
C                    AND, WHEN MPEROD = 1
C
C                       A(1) = C(M) = 0
C                       A(M) = C(1) = 2.
C
C                    THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS-
C                    TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS
C                    COMPUTED.  USING THIS ARRAY Y SUBROUTINE GENBUN WAS
C                    CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z.  THEN
C                    THE RELATIVE ERROR, DEFINED AS
C
C                       E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J)))
C
C                    WHERE THE TWO MAXIMA ARE TAKEN OVER ALL I=1,2,...,M
C                    AND J=1,2,...,N, WAS COMPUTED.  THE VALUE OF E IS
C                    GIVEN IN THE TABLE BELOW FOR SOME TYPICAL VALUES OF
C                    M AND N.
C
C
C                       M (=N)    MPEROD    NPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         31        0         0          36     6.E-14
C                         31        1         1          21     4.E-13
C                         31        1         3          41     3.E-13
C                         32        0         0          29     9.E-14
C                         32        1         1          32     3.E-13
C                         32        1         3          48     1.E-13
C                         33        0         0          36     9.E-14
C                         33        1         1          30     4.E-13
C                         33        1         3          34     1.E-13
C                         63        0         0         150     1.E-13
C                         63        1         1          91     1.E-12
C                         63        1         3         173     2.E-13
C                         64        0         0         122     1.E-13
C                         64        1         1         128     1.E-12
C                         64        1         3         199     6.E-13
C                         65        0         0         143     2.E-13
C                         65        1         1         120     1.E-12
C                         65        1         3         138     4.E-13
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUE FORTRAN.
C                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      SWEET, R., 'A CYCLIC REDUCTION ALGORITHM FOR
C                    SOLVING BLOCK TRIDIAGONAL SYSTEMS OF ARBITRARY
C                    DIMENSIONS,' SIAM J. ON NUMER. ANAL.,
C                    14(SEPT., 1977), PP. 706-720.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      DIMENSION       Y(IDIMY,1)
      DIMENSION       W(1)       ,B(1)       ,A(1)       ,C(1)
      IERROR = 0
      IF (M .LE. 2) IERROR = 1
      IF (N .LE. 2) IERROR = 2
      IF (IDIMY .LT. M) IERROR = 3
      IF (NPEROD.LT.0 .OR. NPEROD.GT.4) IERROR = 4
      IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5
      IF (MPEROD .EQ. 1) GO TO 102
      DO 101 I=2,M
         IF (A(I) .NE. C(1)) GO TO 103
         IF (C(I) .NE. C(1)) GO TO 103
         IF (B(I) .NE. B(1)) GO TO 103
  101 CONTINUE
      GO TO 104
  102 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7
      GO TO 104
  103 IERROR = 6
  104 IF (IERROR .NE. 0) RETURN
      MP1 = M+1
      IWBA = MP1
      IWBB = IWBA+M
      IWBC = IWBB+M
      IWB2 = IWBC+M
      IWB3 = IWB2+M
      IWW1 = IWB3+M
      IWW2 = IWW1+M
      IWW3 = IWW2+M
      IWD = IWW3+M
      IWTCOS = IWD+M
      IWP = IWTCOS+4*N
      DO 106 I=1,M
         K = IWBA+I-1
         W(K) = -A(I)
         K = IWBC+I-1
         W(K) = -C(I)
         K = IWBB+I-1
         W(K) = 2.-B(I)
         DO 105 J=1,N
            Y(I,J) = -Y(I,J)
  105    CONTINUE
  106 CONTINUE
      MP = MPEROD+1
      NP = NPEROD+1
      GO TO (114,107),MP
  107 GO TO (108,109,110,111,123),NP
  108 CALL POISP2 (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      GO TO 112
  109 CALL POISD2 (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1),
     1             W(IWD),W(IWTCOS),W(IWP))
      GO TO 112
  110 CALL POISN2 (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      GO TO 112
  111 CALL POISN2 (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
  112 IPSTOR = W(IWW1)
      IREV = 2
      IF (NPEROD .EQ. 4) GO TO 124
  113 GO TO (127,133),MP
  114 CONTINUE
C
C     REORDER UNKNOWNS WHEN MP =0
C
      MH = (M+1)/2
      MHM1 = MH-1
      MODD = 1
      IF (MH*2 .EQ. M) MODD = 2
      DO 119 J=1,N
         DO 115 I=1,MHM1
            MHPI = MH+I
            MHMI = MH-I
            W(I) = Y(MHMI,J)-Y(MHPI,J)
            W(MHPI) = Y(MHMI,J)+Y(MHPI,J)
  115    CONTINUE
         W(MH) = 2.*Y(MH,J)
         GO TO (117,116),MODD
  116    W(M) = 2.*Y(M,J)
  117    CONTINUE
         DO 118 I=1,M
            Y(I,J) = W(I)
  118    CONTINUE
  119 CONTINUE
      K = IWBC+MHM1-1
      I = IWBA+MHM1
      W(K) = 0.
      W(I) = 0.
      W(K+1) = 2.*W(K+1)
      GO TO (120,121),MODD
  120 CONTINUE
      K = IWBB+MHM1-1
      W(K) = W(K)-W(I-1)
      W(IWBC-1) = W(IWBC-1)+W(IWBB-1)
      GO TO 122
  121 W(IWBB-1) = W(K+1)
  122 CONTINUE
      GO TO 107
C
C     REVERSE COLUMNS WHEN NPEROD = 4.
C
  123 IREV = 1
      NBY2 = N/2
  124 DO 126 J=1,NBY2
         MSKIP = N+1-J
         DO 125 I=1,M
            A1 = Y(I,J)
            Y(I,J) = Y(I,MSKIP)
            Y(I,MSKIP) = A1
  125    CONTINUE
  126 CONTINUE
      GO TO (110,113),IREV
  127 CONTINUE
      DO 132 J=1,N
         DO 128 I=1,MHM1
            MHMI = MH-I
            MHPI = MH+I
            W(MHMI) = .5*(Y(MHPI,J)+Y(I,J))
            W(MHPI) = .5*(Y(MHPI,J)-Y(I,J))
  128    CONTINUE
         W(MH) = .5*Y(MH,J)
         GO TO (130,129),MODD
  129    W(M) = .5*Y(M,J)
  130    CONTINUE
         DO 131 I=1,M
            Y(I,J) = W(I)
  131    CONTINUE
  132 CONTINUE
  133 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR W ARRAY.
C
      W(1) = IPSTOR+IWP-1
      RETURN
      END


	FUNCTION PR_HGMK  ( value )
C************************************************************************
C* PR_HGMK								*
C*									*
C* This function divides a value by 1000.  It can be used to convert	*
C* meters to kilometers.						*
C*									*
C* REAL PR_HGMK  ( VALUE )						*
C*									*
C* Input parameters:							*
C*	VALUE		REAL		Value				*
C*									*
C* Output parameters:							*
C*	PR_HGMK		REAL		Value / 1000			*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84	Original source				*
C* G. Huffman/GSC	7/88	Documentation				*
C* S. Schotz/GSC        9/89    Documentation				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C-----------------------------------------------------------------------
C*	Check for missing value.
C
	IF  ( ERMISS ( value ) )  THEN
	    PR_HGMK = RMISSD
	  ELSE
	    PR_HGMK = value / 1000.
	END IF
C*
	RETURN
	END


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief global variables for inverse calculations
module mod_inverse
      integer mpara_tp, para_weight, data_weight
      integer maxiter_inv, iter_inv, covar, resmat, iter_out
      integer relax_max, relax_out, reg_type
      integer icovarp, icovard
!
      double precision reg_para, relax_inv, rms_data
      double precision rms_para, tol_inv
!     need an update of the jacobian
      logical update_dd, lib_override
!     abort flag for inverse iteration
      logical abort_inv
!     provide diagonal of the hesse matrix
      logical hdiag_provide
end module mod_inverse


program grid_3d

  integer :: i, j, k

  integer, parameter :: nx = 2
  integer, parameter :: ny = 2
  integer, parameter :: nz = 24
  integer, parameter :: nzonesx = 64
  integer, parameter :: nzonesy = 64
  integer, parameter :: nzonesz = 768

  integer :: ix, iy, iz
  integer :: nlevs, ngrids

 99 format(i1)
100 format('         ((',i4,',',i4,',',i4,') (',i4,',',i4,',',i4,') ('i4,',',i4,',',i4,'))')
101 format('   ((',i4,',',i4,',',i4,') (',i4,',',i4,',',i4,') ('i4,',',i4,',',i4,')) ', i8)

  ix = 0
  nlevs = 1
  ngrids = nx*ny*nz

  write (*, 99) nlevs
  write (*,101) 0,0,0,nzonesx-1,nzonesy-1,nzonesz-1,0,0,0,ngrids
  do i = 1, nx

     iy = 0
     do j = 1, ny

        iz = 0
        do k = 1, nz

           write (*,100) ix,iy,iz, ix+nzonesx/nx-1,iy+nzonesy/ny-1,iz+nzonesz/nz-1,0,0,0

           iz = iz + nzonesz/nz
        enddo

        iy = iy + nzonesy/ny
     enddo

     ix = ix + nzonesx/nx
  enddo

end program grid_3d


*> \brief \b DTBT03
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB,
*                          SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK,
*                          RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIAG, TRANS, UPLO
*       INTEGER            KD, LDAB, LDB, LDX, N, NRHS
*       DOUBLE PRECISION   RESID, SCALE, TSCAL
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * ), CNORM( * ),
*      $                   WORK( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DTBT03 computes the residual for the solution to a scaled triangular
*> system of equations  A*x = s*b  or  A'*x = s*b  when A is a
*> triangular band matrix. Here A' is the transpose of A, s is a scalar,
*> and x and b are N by NRHS matrices.  The test ratio is the maximum
*> over the number of right hand sides of
*>    norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
*> where op(A) denotes A or A' and EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the matrix A is upper or lower triangular.
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the operation applied to A.
*>          = 'N':  A *x = b  (No transpose)
*>          = 'T':  A'*x = b  (Transpose)
*>          = 'C':  A'*x = b  (Conjugate transpose = Transpose)
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*>          DIAG is CHARACTER*1
*>          Specifies whether or not the matrix A is unit triangular.
*>          = 'N':  Non-unit triangular
*>          = 'U':  Unit triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KD
*> \verbatim
*>          KD is INTEGER
*>          The number of superdiagonals or subdiagonals of the
*>          triangular band matrix A.  KD >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices X and B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*>          AB is DOUBLE PRECISION array, dimension (LDAB,N)
*>          The upper or lower triangular band matrix A, stored in the
*>          first kd+1 rows of the array. The j-th column of A is stored
*>          in the j-th column of the array AB as follows:
*>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= KD+1.
*> \endverbatim
*>
*> \param[in] SCALE
*> \verbatim
*>          SCALE is DOUBLE PRECISION
*>          The scaling factor s used in solving the triangular system.
*> \endverbatim
*>
*> \param[in] CNORM
*> \verbatim
*>          CNORM is DOUBLE PRECISION array, dimension (N)
*>          The 1-norms of the columns of A, not counting the diagonal.
*> \endverbatim
*>
*> \param[in] TSCAL
*> \verbatim
*>          TSCAL is DOUBLE PRECISION
*>          The scaling factor used in computing the 1-norms in CNORM.
*>          CNORM actually contains the column norms of TSCAL*A.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
*>          The computed solution vectors for the system of linear
*>          equations.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          The right hand side vectors for the system of linear
*>          equations.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          The maximum over the number of right hand sides of
*>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE DTBT03( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB,
     $                   SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK,
     $                   RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            KD, LDAB, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RESID, SCALE, TSCAL
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   AB( LDAB, * ), B( LDB, * ), CNORM( * ),
     $                   WORK( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            IX, J
      DOUBLE PRECISION   BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, IDAMAX, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DLABAD, DSCAL, DTBMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0
*
      IF( N.LE.0 .OR. NRHS.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
      EPS = DLAMCH( 'Epsilon' )
      SMLNUM = DLAMCH( 'Safe minimum' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Compute the norm of the triangular matrix A using the column
*     norms already computed by DLATBS.
*
      TNORM = ZERO
      IF( LSAME( DIAG, 'N' ) ) THEN
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 10 J = 1, N
               TNORM = MAX( TNORM, TSCAL*ABS( AB( KD+1, J ) )+
     $                 CNORM( J ) )
   10       CONTINUE
         ELSE
            DO 20 J = 1, N
               TNORM = MAX( TNORM, TSCAL*ABS( AB( 1, J ) )+CNORM( J ) )
   20       CONTINUE
         END IF
      ELSE
         DO 30 J = 1, N
            TNORM = MAX( TNORM, TSCAL+CNORM( J ) )
   30    CONTINUE
      END IF
*
*     Compute the maximum over the number of right hand sides of
*        norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
*
      RESID = ZERO
      DO 40 J = 1, NRHS
         CALL DCOPY( N, X( 1, J ), 1, WORK, 1 )
         IX = IDAMAX( N, WORK, 1 )
         XNORM = MAX( ONE, ABS( X( IX, J ) ) )
         XSCAL = ( ONE / XNORM ) / DBLE( KD+1 )
         CALL DSCAL( N, XSCAL, WORK, 1 )
         CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK, 1 )
         CALL DAXPY( N, -SCALE*XSCAL, B( 1, J ), 1, WORK, 1 )
         IX = IDAMAX( N, WORK, 1 )
         ERR = TSCAL*ABS( WORK( IX ) )
         IX = IDAMAX( N, X( 1, J ), 1 )
         XNORM = ABS( X( IX, J ) )
         IF( ERR*SMLNUM.LE.XNORM ) THEN
            IF( XNORM.GT.ZERO )
     $         ERR = ERR / XNORM
         ELSE
            IF( ERR.GT.ZERO )
     $         ERR = ONE / EPS
         END IF
         IF( ERR*SMLNUM.LE.TNORM ) THEN
            IF( TNORM.GT.ZERO )
     $         ERR = ERR / TNORM
         ELSE
            IF( ERR.GT.ZERO )
     $         ERR = ONE / EPS
         END IF
         RESID = MAX( RESID, ERR )
   40 CONTINUE
*
      RETURN
*
*     End of DTBT03
*
      END


PROGRAM HydrostaticPolytrope1D

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE GravityProblemsInitializationModule, ONLY: &
    InitializeHydrostaticPolytrope
  USE ErrorAnalysisModule, ONLY: &
    InitializeErrorAnalysis, &
    FinalizeErrorAnalysis
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK
  USE GravitySolutionModule, ONLY: &
    SolveGravity

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
            = 'HydrostaticPolytrope1D', &
           nX_Option &
             = [ 16, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 10, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 0.8_DP, Pi,     4.0_DP ], &
           nNodes_Option &
             = 3, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           EquationOfState_Option &
             = 'IDEAL', &
           Gamma_IDEAL_Option &
             = 2.0_DP, &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d0, &
           BetaTVD_Option &
             = 1.8d0, &
           ApplyPositivityLimiter_Option &
             = .TRUE., &
           EvolveGravity_Option &
             = .TRUE., &
           GravitySolver_Option &
             = 'Newtonian_Poseidon', &
           nStages_SSP_RK_Option &
             = 3 )

  CALL InitializeHydrostaticPolytrope

  CALL SolveGravity

  CALL InitializeErrorAnalysis

  CALL EvolveFields &
         ( t_begin  = 0.0_DP, &
           t_end    = 1.0d+1, &
           dt_write = 1.0d-1, &
           UpdateFields = SSP_RK )

  CALL FinalizeErrorAnalysis

  CALL FinalizeProgram

END PROGRAM HydrostaticPolytrope1D