*DECK DBOLS
      SUBROUTINE DBOLS (W, MDW, MROWS, NCOLS, BL, BU, IND, IOPT, X,
     +   RNORM, MODE, RW, IW)
C***BEGIN PROLOGUE  DBOLS
C***PURPOSE  Solve the problem
C                 E*X = F (in the least  squares  sense)
C            with bounds on selected X values.
C***LIBRARY   SLATEC
C***CATEGORY  K1A2A, G2E, G2H1, G2H2
C***TYPE      DOUBLE PRECISION (SBOLS-S, DBOLS-D)
C***KEYWORDS  BOUNDS, CONSTRAINTS, INEQUALITY, LEAST SQUARES, LINEAR
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C   **** All INPUT and OUTPUT real variables are DOUBLE PRECISION ****
C
C     The user must have dimension statements of the form:
C
C       DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS),
C      * X(NCOLS+NX), RW(5*NCOLS)
C       INTEGER IND(NCOLS), IOPT(1+NI), IW(2*NCOLS)
C
C     (Here NX=number of extra locations required for option 4; NX=0
C     for no options; NX=NCOLS if this option is in use. Here NI=number
C     of extra locations required for options 1-6; NI=0 for no
C     options.)
C
C   INPUT
C   -----
C
C    --------------------
C    W(MDW,*),MROWS,NCOLS
C    --------------------
C     The array W(*,*) contains the matrix [E:F] on entry. The matrix
C     [E:F] has MROWS rows and NCOLS+1 columns. This data is placed in
C     the array W(*,*) with E occupying the first NCOLS columns and the
C     right side vector F in column NCOLS+1. The row dimension, MDW, of
C     the array W(*,*) must satisfy the inequality MDW .ge. MROWS.
C     Other values of MDW are errors. The values of MROWS and NCOLS
C     must be positive. Other values are errors. There is an exception
C     to this when using option 1 for accumulation of blocks of
C     equations. In that case MROWS is an OUTPUT variable ONLY, and the
C     matrix data for [E:F] is placed in W(*,*), one block of rows at a
C     time.  MROWS contains the number of rows in the matrix after
C     triangularizing several blocks of equations. This is an OUTPUT
C     parameter ONLY when option 1 is used. See IOPT(*) CONTENTS
C     for details about option 1.
C
C    ------------------
C    BL(*),BU(*),IND(*)
C    ------------------
C     These arrays contain the information about the bounds that the
C     solution values are to satisfy. The value of IND(J) tells the
C     type of bound and BL(J) and BU(J) give the explicit values for
C     the respective upper and lower bounds.
C
C    1.    For IND(J)=1, require X(J) .ge. BL(J).
C          (the value of BU(J) is not used.)
C    2.    For IND(J)=2, require X(J) .le. BU(J).
C          (the value of BL(J) is not used.)
C    3.    For IND(J)=3, require X(J) .ge. BL(J) and
C                                X(J) .le. BU(J).
C    4.    For IND(J)=4, no bounds on X(J) are required.
C          (the values of BL(J) and BU(J) are not used.)
C
C     Values other than 1,2,3 or 4 for IND(J) are errors. In the case
C     IND(J)=3 (upper and lower bounds) the condition BL(J) .gt. BU(J)
C     is an error.
C
C    -------
C    IOPT(*)
C    -------
C     This is the array where the user can specify nonstandard options
C     for DBOLSM( ). Most of the time this feature can be ignored by
C     setting the input value IOPT(1)=99. Occasionally users may have
C     needs that require use of the following subprogram options. For
C     details about how to use the options see below: IOPT(*) CONTENTS.
C
C     Option Number   Brief Statement of Purpose
C     ------ ------   ----- --------- -- -------
C           1         Return to user for accumulation of blocks
C                     of least squares equations.
C           2         Check lengths of all arrays used in the
C                     subprogram.
C           3         Standard scaling of the data matrix, E.
C           4         User provides column scaling for matrix E.
C           5         Provide option array to the low-level
C                     subprogram DBOLSM( ).
C           6         Move the IOPT(*) processing pointer.
C          99         No more options to change.
C
C    ----
C    X(*)
C    ----
C     This array is used to pass data associated with option 4. Ignore
C     this parameter if this option is not used. Otherwise see below:
C     IOPT(*) CONTENTS.
C
C    OUTPUT
C    ------
C
C    ----------
C    X(*),RNORM
C    ----------
C     The array X(*) contains a solution (if MODE .ge.0 or .eq.-22) for
C     the constrained least squares problem. The value RNORM is the
C     minimum residual vector length.
C
C    ----
C    MODE
C    ----
C     The sign of MODE determines whether the subprogram has completed
C     normally, or encountered an error condition or abnormal status. A
C     value of MODE .ge. 0 signifies that the subprogram has completed
C     normally. The value of MODE (.GE. 0) is the number of variables
C     in an active status: not at a bound nor at the value ZERO, for
C     the case of free variables. A negative value of MODE will be one
C     of the cases -37,-36,...,-22, or -17,...,-2. Values .lt. -1
C     correspond to an abnormal completion of the subprogram. To
C     understand the abnormal completion codes see below: ERROR
C     MESSAGES for DBOLS( ). AN approximate solution will be returned
C     to the user only when max. iterations is reached, MODE=-22.
C     Values for MODE=-37,...,-22 come from the low-level subprogram
C     DBOLSM(). See the section ERROR MESSAGES for DBOLSM() in the
C     documentation for DBOLSM().
C
C    -----------
C    RW(*),IW(*)
C    -----------
C     These are working arrays with 5*NCOLS and 2*NCOLS entries.
C     (normally the user can ignore the contents of these arrays,
C     but they must be dimensioned properly.)
C
C    IOPT(*) CONTENTS
C    ------- --------
C     The option array allows a user to modify internal variables in
C     the subprogram without recompiling the source code. A central
C     goal of the initial software design was to do a good job for most
C     people. Thus the use of options will be restricted to a select
C     group of users. The processing of the option array proceeds as
C     follows: a pointer, here called LP, is initially set to the value
C     1. This value is updated as each option is processed. At the
C     pointer position the option number is extracted and used for
C     locating other information that allows for options to be changed.
C     The portion of the array IOPT(*) that is used for each option is
C     fixed; the user and the subprogram both know how many locations
C     are needed for each option. A great deal of error checking is
C     done by the subprogram on the contents of the option array.
C     Nevertheless it is still possible to give the subprogram optional
C     input that is meaningless. For example option 4 uses the
C     locations X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1) for passing
C     scaling data. The user must manage the allocation of these
C     locations.
C
C   1
C   -
C     This option allows the user to solve problems with a large number
C     of rows compared to the number of variables. The idea is that the
C     subprogram returns to the user (perhaps many times) and receives
C     new least squares equations from the calling program unit.
C     Eventually the user signals "that's all" and then computes the
C     solution with one final call to subprogram DBOLS( ). The value of
C     MROWS is an OUTPUT variable when this option is used. Its value
C     is always in the range 0 .le. MROWS .le. NCOLS+1. It is equal to
C     the number of rows after the triangularization of the entire set
C     of equations. If LP is the processing pointer for IOPT(*), the
C     usage for the sequential processing of blocks of equations is
C
C        IOPT(LP)=1
C        Move block of equations to W(*,*) starting at
C        the first row of W(*,*).
C        IOPT(LP+3)=# of rows in the block; user defined
C
C     The user now calls DBOLS( ) in a loop. The value of IOPT(LP+1)
C     directs the user's action. The value of IOPT(LP+2) points to
C     where the subsequent rows are to be placed in W(*,*).
C
C      .<LOOP
C      . CALL DBOLS()
C      . IF(IOPT(LP+1) .EQ. 1) THEN
C      .    IOPT(LP+3)=# OF ROWS IN THE NEW BLOCK; USER DEFINED
C      .    PLACE NEW BLOCK OF IOPT(LP+3) ROWS IN
C      .    W(*,*) STARTING AT ROW IOPT(LP+2).
C      .
C      .    IF( THIS IS THE LAST BLOCK OF EQUATIONS ) THEN
C      .       IOPT(LP+1)=2
C      .<------CYCLE LOOP
C      .    ELSE IF (IOPT(LP+1) .EQ. 2) THEN
C      <-------EXIT LOOP SOLUTION COMPUTED IF MODE .GE. 0
C      . ELSE
C      . ERROR CONDITION; SHOULD NOT HAPPEN.
C      .<END LOOP
C
C     Use of this option adds 4 to the required length of IOPT(*).
C
C
C   2
C   -
C     This option is useful for checking the lengths of all arrays used
C     by DBOLS() against their actual requirements for this problem.
C     The idea is simple: the user's program unit passes the declared
C     dimension information of the arrays. These values are compared
C     against the problem-dependent needs within the subprogram. If any
C     of the dimensions are too small an error message is printed and a
C     negative value of MODE is returned, -11 to -17. The printed error
C     message tells how long the dimension should be. If LP is the
C     processing pointer for IOPT(*),
C
C        IOPT(LP)=2
C        IOPT(LP+1)=Row dimension of W(*,*)
C        IOPT(LP+2)=Col. dimension of W(*,*)
C        IOPT(LP+3)=Dimensions of BL(*),BU(*),IND(*)
C        IOPT(LP+4)=Dimension of X(*)
C        IOPT(LP+5)=Dimension of RW(*)
C        IOPT(LP+6)=Dimension of IW(*)
C        IOPT(LP+7)=Dimension of IOPT(*)
C         .
C        CALL DBOLS()
C
C     Use of this option adds 8 to the required length of IOPT(*).
C
C   3
C   -
C     This option changes the type of scaling for the data matrix E.
C     Nominally each nonzero column of E is scaled so that the
C     magnitude of its largest entry is equal to the value ONE. If LP
C     is the processing pointer for IOPT(*),
C
C        IOPT(LP)=3
C        IOPT(LP+1)=1,2 or 3
C            1= Nominal scaling as noted;
C            2= Each nonzero column scaled to have length ONE;
C            3= Identity scaling; scaling effectively suppressed.
C         .
C        CALL DBOLS()
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   4
C   -
C     This option allows the user to provide arbitrary (positive)
C     column scaling for the matrix E. If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=4
C        IOPT(LP+1)=IOFF
C        X(NCOLS+IOFF),...,X(NCOLS+IOFF+NCOLS-1)
C        = Positive scale factors for cols. of E.
C         .
C        CALL DBOLS()
C
C     Use of this option adds 2 to the required length of IOPT(*) and
C     NCOLS to the required length of X(*).
C
C   5
C   -
C     This option allows the user to provide an option array to the
C     low-level subprogram DBOLSM(). If LP is the processing pointer
C     for IOPT(*),
C
C        IOPT(LP)=5
C        IOPT(LP+1)= Position in IOPT(*) where option array
C                    data for DBOLSM() begins.
C         .
C        CALL DBOLS()
C
C     Use of this option adds 2 to the required length of IOPT(*).
C
C   6
C   -
C     Move the processing pointer (either forward or backward) to the
C     location IOPT(LP+1). The processing point is moved to entry
C     LP+2 of IOPT(*) if the option is left with -6 in IOPT(LP).  For
C     example to skip over locations 3,...,NCOLS+2 of IOPT(*),
C
C       IOPT(1)=6
C       IOPT(2)=NCOLS+3
C       (IOPT(I), I=3,...,NCOLS+2 are not defined here.)
C       IOPT(NCOLS+3)=99
C       CALL DBOLS()
C
C     CAUTION: Misuse of this option can yield some very hard
C     -to-find bugs.  Use it with care.
C
C   99
C   --
C     There are no more options to change.
C
C     Only option numbers -99, -6,-5,...,-1, 1,2,...,6, and 99 are
C     permitted. Other values are errors. Options -99,-1,...,-6 mean
C     that the respective options 99,1,...,6 are left at their default
C     values. An example is the option to modify the (rank) tolerance:
C
C       IOPT(1)=-3 Option is recognized but not changed
C       IOPT(2)=2  Scale nonzero cols. to have length ONE
C       IOPT(3)=99
C
C    ERROR MESSAGES for DBOLS()
C    ----- -------- --- -------
C
C WARNING IN...
C DBOLS(). MDW=(I1) MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         2
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). NCOLS=(I1) THE NO. OF VARIABLES MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         3
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). FOR J=(I1), IND(J)=(I2) MUST BE 1-4.
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         0
C ERROR NUMBER =         4
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). FOR J=(I1), BOUND BL(J)=(R1) IS .GT. BU(J)=(R2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, R1=    0.
C           IN ABOVE MESSAGE, R2=    ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         6
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). ISCALE OPTION=(I1) MUST BE 1-3.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         7
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). OFFSET PAST X(NCOLS) (I1) FOR USER-PROVIDED  COLUMN SCALING
C MUST BE POSITIVE.
C           IN ABOVE MESSAGE, I1=         0
C ERROR NUMBER =         8
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). EACH PROVIDED COL. SCALE FACTOR MUST BE POSITIVE.
C COMPONENT (I1) NOW = (R1).
C           IN ABOVE MESSAGE, I1=        ND. .LE. MDW=(I2).
C           IN ABOVE MESSAGE, I1=         1
C           IN ABOVE MESSAGE, I2=         0
C ERROR NUMBER =        10
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS().THE ROW DIMENSION OF W(,)=(I1) MUST BE .GE.THE NUMBER OF ROWS=
C (I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        11
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). THE COLUMN DIMENSION OF W(,)=(I1) MUST BE .GE. NCOLS+1=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        12
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS().THE DIMENSIONS OF THE ARRAYS BL(),BU(), AND IND()=(I1) MUST BE
C .GE. NCOLS=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        13
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). THE DIMENSION OF X()=(I1) MUST BE .GE. THE REQD. LENGTH=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        14
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS(). THE DIMENSION OF RW()=(I1) MUST BE .GE. 5*NCOLS=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         3
C ERROR NUMBER =        15
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS() THE DIMENSION OF IW()=(I1) MUST BE .GE. 2*NCOLS=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         2
C ERROR NUMBER =        16
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C WARNING IN...
C DBOLS() THE DIMENSION OF IOPT()=(I1) MUST BE .GE. THE REQD. LEN.=(I2).
C           IN ABOVE MESSAGE, I1=         0
C           IN ABOVE MESSAGE, I2=         1
C ERROR NUMBER =        17
C (NORMALLY A RETURN TO THE USER TAKES PLACE FOLLOWING THIS MESSAGE.)
C
C***REFERENCES  R. J. Hanson, Linear least squares with bounds and
C                 linear constraints, Report SAND82-1517, Sandia
C                 Laboratories, August 1982.
C***ROUTINES CALLED  DBOLSM, DCOPY, DNRM2, DROT, DROTG, IDAMAX, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   821220  DATE WRITTEN
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBOLS
C
C     SOLVE LINEAR LEAST SQUARES SYSTEM WITH BOUNDS ON
C     SELECTED VARIABLES.
C     REVISED 850329-1400
C     REVISED YYMMDD-HHMM
C     TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN
C     EDITING AT THE CARD 'C++'.
C     CHANGE THIS SUBPROGRAM NAME TO DBOLS AND THE STRINGS
C     /SCOPY/ TO /DCOPY/, /SBOL/ TO /DBOL/,
C     /SNRM2/ TO /DNRM2/, /ISAMAX/ TO /IDAMAX/,
C     /SROTG/ TO /DROTG/, /SROT/ TO /DROT/, /E0/ TO /D0/,
C     /REAL            / TO /DOUBLE PRECISION/.
C ++
      DOUBLE PRECISION W(MDW,*),BL(*),BU(*),X(*),RW(*)
      DOUBLE PRECISION SC, SS, ONE, DNRM2, RNORM, ZERO
C
C     THIS VARIABLE SHOULD REMAIN TYPE REAL.
      INTEGER IND(*),IOPT(*),IW(*)
      LOGICAL CHECKL
      CHARACTER*8 XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
      SAVE IGO,LOCACC,LOPT,ISCALE
      DATA IGO/0/
C***FIRST EXECUTABLE STATEMENT  DBOLS
      NERR = 0
      MODE = 0
      IF (IGO.EQ.0) THEN
C     DO(CHECK VALIDITY OF INPUT DATA)
C     PROCEDURE(CHECK VALIDITY OF INPUT DATA)
C
C     SEE THAT MDW IS .GT.0. GROSS CHECK ONLY.
          IF (MDW.LE.0) THEN
              WRITE (XERN1, '(I8)') MDW
              CALL XERMSG ('SLATEC', 'DBOLS', 'MDW = ' // XERN1 //
     *           ' MUST BE POSITIVE.', 2, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 190
          ENDIF
C
C     SEE THAT NUMBER OF UNKNOWNS IS POSITIVE.
          IF (NCOLS.LE.0) THEN
              WRITE (XERN1, '(I8)') NCOLS
              CALL XERMSG ('SLATEC', 'DBOLS', 'NCOLS = ' // XERN1 //
     *           ' THE NO. OF VARIABLES MUST BE POSITIVE.', 3, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 190
          ENDIF
C
C     SEE THAT CONSTRAINT INDICATORS ARE ALL WELL-DEFINED.
          DO 10 J = 1,NCOLS
              IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN
                  WRITE (XERN1, '(I8)') J
                  WRITE (XERN2, '(I8)') IND(J)
                  CALL XERMSG ('SLATEC', 'DBOLS', 'IND(' // XERN1 //
     *               ') = ' // XERN2 // ' MUST BE 1-4.', 4, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
   10     CONTINUE
C
C     SEE THAT BOUNDS ARE CONSISTENT.
          DO 20 J = 1,NCOLS
              IF (IND(J).EQ.3) THEN
                  IF (BL(J).GT.BU(J)) THEN
                      WRITE (XERN1, '(I8)') J
                      WRITE (XERN3, '(1PE15.6)') BL(J)
                      WRITE (XERN4, '(1PE15.6)') BU(J)
                      CALL XERMSG ('SLATEC', 'DBOLS', 'BOUND BL(' //
     *                   XERN1 // ') = ' // XERN3 // ' IS .GT. BU(' //
     *                   XERN1 // ') = ' // XERN4, 5, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 190
                  ENDIF
              ENDIF
   20     CONTINUE
C     END PROCEDURE
C     DO(PROCESS OPTION ARRAY)
C     PROCEDURE(PROCESS OPTION ARRAY)
          ZERO = 0.D0
          ONE = 1.D0
          CHECKL = .FALSE.
          LENX = NCOLS
          ISCALE = 1
          IGO = 2
          LOPT = 0
          LP = 0
          LDS = 0
   30     CONTINUE
          LP = LP + LDS
          IP = IOPT(LP+1)
          JP = ABS(IP)
C
C     TEST FOR NO MORE OPTIONS.
          IF (IP.EQ.99) THEN
              IF (LOPT.EQ.0) LOPT = LP + 1
              GO TO 50
          ELSE IF (JP.EQ.99) THEN
              LDS = 1
              GO TO 30
          ELSE IF (JP.EQ.1) THEN
              IF (IP.GT.0) THEN
C
C     SET UP DIRECTION FLAG, ROW STACKING POINTER
C     LOCATION, AND LOCATION FOR NUMBER OF NEW ROWS.
                  LOCACC = LP + 2
C
C                  IOPT(LOCACC-1)=OPTION NUMBER FOR SEQ. ACCUMULATION.
C     CONTENTS..   IOPT(LOCACC  )=USER DIRECTION FLAG, 1 OR 2.
C                  IOPT(LOCACC+1)=ROW STACKING POINTER.
C                  IOPT(LOCACC+2)=NUMBER OF NEW ROWS TO PROCESS.
C     USER ACTION WITH THIS OPTION..
C      (SET UP OPTION DATA FOR SEQ. ACCUMULATION IN IOPT(*).
C      MUST ALSO START PROCESS WITH IOPT(LOCACC)=1.)
C      (MOVE BLOCK OF EQUATIONS INTO W(*,*)  STARTING AT FIRST
C       ROW OF W(*,*).  SET IOPT(LOCACC+2)=NO. OF ROWS IN BLOCK.)
C              LOOP
C              CALL DBOLS()
C
C                  IF(IOPT(LOCACC) .EQ. 1) THEN
C                      STACK EQUAS., STARTING AT ROW IOPT(LOCACC+1),
C                       INTO W(*,*).
C                       SET IOPT(LOCACC+2)=NO. OF EQUAS.
C                      IF LAST BLOCK OF EQUAS., SET IOPT(LOCACC)=2.
C                  ELSE IF IOPT(LOCACC) .EQ. 2) THEN
C                      (PROCESS IS OVER. EXIT LOOP.)
C                  ELSE
C                      (ERROR CONDITION. SHOULD NOT HAPPEN.)
C                  END IF
C              END LOOP
C              SET IOPT(LOCACC-1)=-OPTION NUMBER FOR SEQ. ACCUMULATION.
C              CALL DBOLS( )
                  IOPT(LOCACC+1) = 1
                  IGO = 1
              ENDIF
              LDS = 4
              GO TO 30
          ELSE IF (JP.EQ.2) THEN
              IF (IP.GT.0) THEN
C
C     GET ACTUAL LENGTHS OF ARRAYS FOR CHECKING AGAINST NEEDS.
                  LOCDIM = LP + 2
C
C     LMDW.GE.MROWS
C     LNDW.GE.NCOLS+1
C     LLB .GE.NCOLS
C     LLX .GE.NCOLS+EXTRA REQD. IN OPTIONS.
C     LLRW.GE.5*NCOLS
C     LLIW.GE.2*NCOLS
C     LIOP.GE. AMOUNT REQD. FOR IOPTION ARRAY.
                  LMDW = IOPT(LOCDIM)
                  LNDW = IOPT(LOCDIM+1)
                  LLB = IOPT(LOCDIM+2)
                  LLX = IOPT(LOCDIM+3)
                  LLRW = IOPT(LOCDIM+4)
                  LLIW = IOPT(LOCDIM+5)
                  LIOPT = IOPT(LOCDIM+6)
                  CHECKL = .TRUE.
              ENDIF
              LDS = 8
              GO TO 30
C
C     OPTION TO MODIFY THE COLUMN SCALING.
          ELSE IF (JP.EQ.3) THEN
              IF (IP.GT.0) THEN
                  ISCALE = IOPT(LP+2)
C
C     SEE THAT ISCALE IS 1 THRU 3.
                  IF (ISCALE.LT.1 .OR. ISCALE.GT.3) THEN
                      WRITE (XERN1, '(I8)') ISCALE
                      CALL XERMSG ('SLATEC', 'DBOLS', 'ISCALE OPTION = '
     *                   // XERN1 // ' MUST BE 1-3', 7, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 190
                  ENDIF
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION THE USER HAS PROVIDED SCALING.  THE
C     SCALE FACTORS FOR THE COLUMNS BEGIN IN X(NCOLS+IOPT(LP+2)).
          ELSE IF (JP.EQ.4) THEN
              IF (IP.GT.0) THEN
                  ISCALE = 4
                  IF (IOPT(LP+2).LE.0) THEN
                      WRITE (XERN1, '(I8)') IOPT(LP+2)
                      CALL XERMSG ('SLATEC', 'DBOLS',
     *                   'OFFSET PAST X(NCOLS) (' // XERN1 //
     *                   ') FOR USER-PROVIDED COLUMN SCALING MUST ' //
     *                   'BE POSITIVE.',  8, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                      GO TO 190
                  ENDIF
                  CALL DCOPY(NCOLS,X(NCOLS+IOPT(LP+2)),1,RW,1)
                  LENX = LENX + NCOLS
                  DO 40 J = 1,NCOLS
                      IF (RW(J).LE.ZERO) THEN
                          WRITE (XERN1, '(I8)') J
                          WRITE (XERN3, '(1PE15.6)') RW(J)
                          CALL XERMSG ('SLATEC', 'DBOLS',
     *                       'EACH PROVIDED COLUMN SCALE FACTOR ' //
     *                       'MUST BE POSITIVE.$$COMPONENT ' // XERN1 //
     *                       ' NOW = ' // XERN3, 9, 1)
                          GO TO 190
                      ENDIF
   40             CONTINUE
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     IN THIS OPTION AN OPTION ARRAY IS PROVIDED TO DBOLSM().
          ELSE IF (JP.EQ.5) THEN
              IF (IP.GT.0) THEN
                  LOPT = IOPT(LP+2)
              ENDIF
              LDS = 2
C     CYCLE FOREVER
              GO TO 30
C
C     THIS OPTION USES THE NEXT LOC OF IOPT(*) AS AN
C     INCREMENT TO SKIP.
          ELSE IF (JP.EQ.6) THEN
              IF (IP.GT.0) THEN
                  LP = IOPT(LP+2) - 1
                  LDS = 0
              ELSE
                  LDS = 2
              ENDIF
C     CYCLE FOREVER
              GO TO 30
C
C     NO VALID OPTION NUMBER WAS NOTED. THIS IS AN ERROR CONDITION.
          ELSE
              WRITE (XERN1, '(I8)') JP
              CALL XERMSG ('SLATEC', 'DBOLS', 'THE OPTION NUMBER = ' //
     *           XERN1 // ' IS NOT DEFINED.', 6, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
              GO TO 190
          ENDIF
   50     CONTINUE
C     END PROCEDURE
          IF (CHECKL) THEN
C     DO(CHECK LENGTHS OF ARRAYS)
C     PROCEDURE(CHECK LENGTHS OF ARRAYS)
C
C     THIS FEATURE ALLOWS THE USER TO MAKE SURE THAT THE
C     ARRAYS ARE LONG ENOUGH FOR THE INTENDED PROBLEM SIZE AND USE.
              IF (LMDW.LT.MROWS) THEN
                  WRITE (XERN1, '(I8)') LMDW
                  WRITE (XERN2, '(I8)') MROWS
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *               'THE ROW DIMENSION OF W(,) = ' // XERN1 //
     *               ' MUST BE .GE. THE NUMBER OF ROWS = ' // XERN2,
     *               11, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LNDW.LT.NCOLS+1) THEN
                  WRITE (XERN1, '(I8)') LNDW
                  WRITE (XERN2, '(I8)') NCOLS+1
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *               'THE COLUMN DIMENSION OF W(,) = ' // XERN1 //
     *               ' MUST BE .GE. NCOLS+1 = ' // XERN2, 12, 1)
                  GO TO 190
              ENDIF
              IF (LLB.LT.NCOLS) THEN
                  WRITE (XERN1, '(I8)') LLB
                  WRITE (XERN2, '(I8)') NCOLS
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *           'THE DIMENSIONS OF THE ARRAYS BL(), BU(), AND IND() = '
     *               // XERN1 // ' MUST BE .GE. NCOLS = ' // XERN2,
     *               13, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLX.LT.LENX) THEN
                  WRITE (XERN1, '(I8)') LLX
                  WRITE (XERN2, '(I8)') LENX
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *               'THE DIMENSION OF X() = ' // XERN1 //
     *               ' MUST BE .GE. THE REQUIRED LENGTH = ' // XERN2,
     *               14, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLRW.LT.5*NCOLS) THEN
                  WRITE (XERN1, '(I8)') LLRW
                  WRITE (XERN2, '(I8)') 5*NCOLS
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *               'THE DIMENSION OF RW() = ' // XERN1 //
     *               ' MUST BE .GE. 5*NCOLS = ' // XERN2, 15, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LLIW.LT.2*NCOLS) THEN
                  WRITE (XERN1, '(I8)') LLIW
                  WRITE (XERN2, '(I8)') 2*NCOLS
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *               'THE DIMENSION OF IW() = ' // XERN1 //
     *               ' MUST BE .GE. 2*NCOLS = ' // XERN2, 16, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
              IF (LIOPT.LT.LP+1) THEN
                  WRITE (XERN1, '(I8)') LIOPT
                  WRITE (XERN2, '(I8)') LP+1
                  CALL XERMSG ('SLATEC', 'DBOLS',
     *               'THE DIMENSION OF IOPT() = ' // XERN1 //
     *               ' MUST BE .GE. THE REQUIRED LEN = ' // XERN2, 17,1)
C     DO(RETURN TO USER PROGRAM UNIT)
                  GO TO 190
              ENDIF
C     END PROCEDURE
          ENDIF
      ENDIF
      GO TO (60,90),IGO
      GO TO 180
C
C     GO BACK TO THE USER FOR ACCUMULATION OF LEAST SQUARES
C     EQUATIONS AND DIRECTIONS TO QUIT PROCESSING.
C     CASE 1
   60 CONTINUE
C     DO(ACCUMULATE LEAST SQUARES EQUATIONS)
C     PROCEDURE(ACCUMULATE LEAST SQUARES EQUATIONS)
      MROWS = IOPT(LOCACC+1) - 1
      INROWS = IOPT(LOCACC+2)
      MNEW = MROWS + INROWS
      IF (MNEW.LT.0 .OR. MNEW.GT.MDW) THEN
          WRITE (XERN1, '(I8)') MNEW
          WRITE (XERN2, '(I8)') MDW
          CALL XERMSG ('SLATEC', 'DBOLS', 'NO. OF ROWS = ' // XERN1 //
     *       ' MUST BE .GE. 0 .AND. .LE. MDW = ' // XERN2, 10, 1)
C     DO(RETURN TO USER PROGRAM UNIT)
          GO TO 190
      ENDIF
      DO 80 J = 1,MIN(NCOLS+1,MNEW)
          DO 70 I = MNEW,MAX(MROWS,J) + 1,-1
              IBIG = IDAMAX(I-J,W(J,J),1) + J - 1
C
C     PIVOT FOR INCREASED STABILITY.
              CALL DROTG(W(IBIG,J),W(I,J),SC,SS)
              CALL DROT(NCOLS+1-J,W(IBIG,J+1),MDW,W(I,J+1),MDW,SC,SS)
              W(I,J) = ZERO
   70     CONTINUE
   80 CONTINUE
      MROWS = MIN(NCOLS+1,MNEW)
      IOPT(LOCACC+1) = MROWS + 1
      IGO = IOPT(LOCACC)
C     END PROCEDURE
      IF (IGO.EQ.2) THEN
          IGO = 0
      ENDIF
      GO TO 180
C     CASE 2
   90 CONTINUE
C     DO(INITIALIZE VARIABLES AND DATA VALUES)
C     PROCEDURE(INITIALIZE VARIABLES AND DATA VALUES)
      DO 150 J = 1,NCOLS
          GO TO (100,110,120,130),ISCALE
          GO TO 140
  100     CONTINUE
C     CASE 1
C
C     THIS IS THE NOMINAL SCALING. EACH NONZERO
C     COL. HAS MAX. NORM EQUAL TO ONE.
          IBIG = IDAMAX(MROWS,W(1,J),1)
          RW(J) = ABS(W(IBIG,J))
          IF (RW(J).EQ.ZERO) THEN
              RW(J) = ONE
          ELSE
              RW(J) = ONE/RW(J)
          ENDIF
          GO TO 140
  110     CONTINUE
C     CASE 2
C
C     THIS CHOICE OF SCALING MAKES EACH NONZERO COLUMN
C     HAVE EUCLIDEAN LENGTH EQUAL TO ONE.
          RW(J) = DNRM2(MROWS,W(1,J),1)
          IF (RW(J).EQ.ZERO) THEN
              RW(J) = ONE
          ELSE
              RW(J) = ONE/RW(J)
          ENDIF
          GO TO 140
  120     CONTINUE
C     CASE 3
C
C     THIS CASE EFFECTIVELY SUPPRESSES SCALING BY SETTING
C     THE SCALING MATRIX TO THE IDENTITY MATRIX.
          RW(1) = ONE
          CALL DCOPY(NCOLS,RW,0,RW,1)
          GO TO 160
  130     CONTINUE
C     CASE 4
          GO TO 160
  140     CONTINUE
  150 CONTINUE
  160 CONTINUE
C     END PROCEDURE
C     DO(SOLVE BOUNDED LEAST SQUARES PROBLEM)
C     PROCEDURE(SOLVE BOUNDED LEAST SQUARES PROBLEM)
C
C     INITIALIZE IBASIS(*), J=1,NCOLS, AND IBB(*), J=1,NCOLS,
C     TO =J,AND =1, FOR USE IN DBOLSM( ).
      DO 170 J = 1,NCOLS
          IW(J) = J
          IW(J+NCOLS) = 1
          RW(3*NCOLS+J) = BL(J)
          RW(4*NCOLS+J) = BU(J)
  170 CONTINUE
      CALL DBOLSM(W,MDW,MROWS,NCOLS,RW(3*NCOLS+1),RW(4*NCOLS+1),IND,
     .            IOPT(LOPT),X,RNORM,MODE,RW(NCOLS+1),RW(2*NCOLS+1),RW,
     .            IW,IW(NCOLS+1))
C     END PROCEDURE
      IGO = 0
  180 CONTINUE
      RETURN
C     PROCEDURE(RETURN TO USER PROGRAM UNIT)
  190 IF(MODE.GE.0)MODE = -NERR
      IGO = 0
      RETURN
C     END PROCEDURE
      END


module time_step_mod
  use kind_params_mod
  use field_mod
  implicit none

contains

  subroutine invoke_time_step(cufld, cvfld, ufld, unew, uold, &
                              vfld, vnew, vold, &
                              pfld, pnew, pold, &
                              hfld, zfld, tdt)
    use compute_cu_mod, only: compute_cu_code
    use compute_cv_mod, only: compute_cv_code
    use compute_z_mod,  only: compute_z_code
    use compute_h_mod,  only: compute_h_code
    use compute_unew_mod, only: compute_unew_code
    use compute_vnew_mod, only: compute_vnew_code
    use compute_pnew_mod, only: compute_pnew_code
    use time_smooth_mod, only: time_smooth_code
    use apply_bcs_mod, only: invoke_apply_bcs
    implicit none
    type(r2d_field), intent(inout) :: cufld, cvfld
    type(r2d_field), intent(inout) :: unew, vnew, pnew
    type(r2d_field), intent(inout) :: hfld, zfld, pfld, &
                                               ufld, vfld
    type(r2d_field), intent(inout) :: uold, vold, pold
    real(go_wp),     intent(in)    :: tdt

    ! Locals
    integer     :: I, J, idim1, idim2
    real(go_wp) :: dx, dy

    ! COMPUTE CAPITAL U, CAPITAL V, Z AND H

    do J=cufld%internal%ystart, cufld%internal%ystop
       do I=cufld%internal%xstart, cufld%internal%xstop

          call compute_cu_code(i, j, cufld%data, pfld%data, ufld%data)
       end do
    end do
    do J=cvfld%internal%ystart, cvfld%internal%ystop
       do I=cvfld%internal%xstart, cvfld%internal%xstop

          call compute_cv_code(i, j, cvfld%data, pfld%data, vfld%data)
       end do
    end do
    dx = zfld%grid%dx
    dy = zfld%grid%dy

    do J=zfld%internal%ystart, zfld%internal%ystop, 1
       do I=zfld%internal%xstart, zfld%internal%xstop, 1

          call compute_z_code(i, j,      &
                              zfld%data, &
                              pfld%data, &
                              ufld%data, &
                              vfld%data, &
                              dx, dy)

       end do
    end do

    DO J=hfld%internal%ystart, hfld%internal%ystop, 1
       DO I=hfld%internal%xstart, hfld%internal%xstop, 1

          CALL compute_h_code(i, j, hfld%data, &
                              pfld%data, ufld%data, vfld%data)
       END DO
    END DO

    ! PERIODIC CONTINUATION

    ! This call could be generated automatically by PSyclone
    call invoke_apply_bcs(CUfld)
    call invoke_apply_bcs(CVfld)
    call invoke_apply_bcs(Hfld)
    call invoke_apply_bcs(Zfld)

    ! COMPUTE NEW VALUES U,V AND P
    dx = unew%grid%dx

    DO J=unew%internal%ystart, unew%internal%ystop, 1
       DO I=unew%internal%xstart, unew%internal%xstop, 1

          CALL compute_unew_code(i, j,                  &
                                 unew%data, uold%data,  &
                                 zfld%data, cvfld%data, &
                                 hfld%data, tdt, dx)
       END DO
    END DO

    dy = vnew%grid%dy

    DO J=vnew%internal%ystart, vnew%internal%ystop, 1
       DO I=vnew%internal%xstart, vnew%internal%xstop, 1

          CALL compute_vnew_code(i, j,                  &
                                 vnew%data, vold%data,  &
                                 zfld%data, cufld%data, &
                                 hfld%data, tdt, dy)
       END DO
    END DO
    dx = pnew%grid%dx
    dy = pnew%grid%dy

    DO J=pnew%internal%ystart, pnew%internal%ystop, 1
       DO I=pnew%internal%xstart, pnew%internal%xstop, 1

          CALL compute_pnew_code(i, j,                 &
                                 pnew%data, pold%data, &
                                 cufld%data, cvfld%data, &
                                 tdt, dx, dy)
       END DO
    END DO

    ! PERIODIC CONTINUATION

    ! This call could be generated by PSyclone
    call invoke_apply_bcs(UNEW)
    call invoke_apply_bcs(VNEW)
    call invoke_apply_bcs(PNEW)

    ! Time is in seconds but we never actually need it
    !CALL increment(time, dt)

    ! TIME SMOOTHING AND UPDATE FOR NEXT CYCLE

    ! Here we field objects to get at raw data.
    idim1 = SIZE(ufld%data, 1)
    idim2 = SIZE(ufld%data, 2)

    ! Loop over 'columns'
    DO J=1,idim2
      DO I=1,idim1
         CALL time_smooth_code(i, j, &
                               ufld%data, unew%data, uold%data)
      END DO
    END DO

    ! Here we will query what should be field objects to get at
    ! raw data.
    idim1 = SIZE(vfld%data, 1)
    idim2 = SIZE(vfld%data, 2)

    ! Loop over 'columns'
    DO J=1,idim2
      DO I=1,idim1
         CALL time_smooth_code(i, j, &
                               vfld%data, vnew%data, vold%data)
      END DO
    END DO

    ! Here we will query what should be field objects to get at
    ! raw data.
    idim1 = SIZE(pfld%data, 1)
    idim2 = SIZE(pfld%data, 2)

    DO J=1,idim2
      DO I=1,idim1
         CALL time_smooth_code(i, j, &
                               pfld%data, pnew%data, pold%data)
      END DO
    END DO

    call copy_field(UNEW, Ufld)
    call copy_field(VNEW, Vfld)
    call copy_field(PNEW, pfld)

  end subroutine invoke_time_step

end module time_step_mod


! volume_integral.f90
! author: sunder

!-----------------------------------------------------------------------
! Find the element volume integral
!-----------------------------------------------------------------------

subroutine volume_integral(lduh, lFhi)
    use ader_dg
    implicit none
    ! Argument list
    real, intent(in)  :: lFhi(nVar,nDim,nDOF(1),nDOF(2)) ! nonlinear flux tensor in each space-time DOF
    real, intent(out) :: lduh(nVar,nDOF(1),nDOF(2))      ! spatial degrees of freedom

    ! Local variables
    integer           :: i,j

    ! Initialize the update DOF

    lduh = 0.0d0

    ! x - direction

    do j = 1, nDOF(2)
        lduh(:,:,j) = lduh(:,:,j) + matmul( lFhi(:,1,:,j), transpose(Kxi) )*wGPN(j)/dx(1)
    end do

    ! y - direction

    do i = 1, nDOF(1)
        lduh(:,i,:) = lduh(:,i,:) + matmul( lFhi(:,2,i,:), transpose(Kxi) )*wGPN(i)/dx(2)
    end do

    continue

end subroutine volume_integral


c----------------------------------------------------------------------c
      subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr)
c-----------------------------------------------------------------------
c     implicit none
      integer n,ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr
      real*8 a(*),alu(*),w(n),droptol

c----------------------------------------------------------------------*
c                      *** ILUT preconditioner ***                     *
c      incomplete LU factorization with dual truncation mechanism      *
c----------------------------------------------------------------------*
c     Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996  *
c----------------------------------------------------------------------*
c PARAMETERS
c-----------
c
c on entry:
c==========
c n       = integer. The row dimension of the matrix A. The matrix
c
c a,ja,ia = matrix stored in Compressed Sparse Row format.
c
c lfil    = integer. The fill-in parameter. Each row of L and each row
c           of U will have a maximum of lfil elements (excluding the
c           diagonal element). lfil must be .ge. 0.
c           ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO
c           EARLIER VERSIONS.
c
c droptol = real*8. Sets the threshold for dropping small terms in the
c           factorization. See below for details on dropping strategy.
c
c
c iwk     = integer. The lengths of arrays alu and jlu. If the arrays
c           are not big enough to store the ILU factorizations, ilut
c           will stop with an error message.
c
c On return:
c===========
c
c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing
c           the L and U factors together. The diagonal (stored in
c           alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix
c           contains the i-th row of L (excluding the diagonal entry=1)
c           followed by the i-th row of U.
c
c ju      = integer array of length n containing the pointers to
c           the beginning of each row of U in the matrix alu,jlu.
c
c ierr    = integer. Error message with the following meaning.
c           ierr  = 0    --> successful return.
c           ierr .gt. 0  --> zero pivot encountered at step number ierr.
c           ierr  = -1   --> Error. input matrix may be wrong.
c                            (The elimination process has generated a
c                            row in L or U whose length is .gt.  n.)
c           ierr  = -2   --> The matrix L overflows the array al.
c           ierr  = -3   --> The matrix U overflows the array alu.
c           ierr  = -4   --> Illegal value for lfil.
c           ierr  = -5   --> zero row encountered.
c
c work arrays:
c=============
c jw      = integer work array of length 2*n.
c w       = real work array of length n
c
c----------------------------------------------------------------------
c w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u]
c jw(n+1:2n)  stores nonzero indicators
c
c Notes:
c ------
c The diagonal elements of the input matrix must be  nonzero (at least
c 'structurally').
c
c----------------------------------------------------------------------*
c---- Dual drop strategy works as follows.                             *
c                                                                      *
c     1) Theresholding in L and U as set by droptol. Any element whose *
c        magnitude is less than some tolerance (relative to the abs    *
c        value of diagonal element in u) is dropped.                   *
c                                                                      *
c     2) Keeping only the largest lfil elements in the i-th row of L   *
c        and the largest lfil elements in the i-th row of U (excluding *
c        diagonal elements).                                           *
c                                                                      *
c Flexibility: one  can use  droptol=0  to get  a strategy  based on   *
c keeping  the largest  elements in  each row  of L  and U.   Taking   *
c droptol .ne.  0 but lfil=n will give  the usual threshold strategy   *
c (however, fill-in is then mpredictible).                             *
c----------------------------------------------------------------------*
c     locals
      integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,len
      real*8 tnorm, t, abs, s, fact
      if (lfil .lt. 0) goto 998
c-----------------------------------------------------------------------
c     initialize ju0 (points to next element to be added to alu,jlu)
c     and pointer array.
c-----------------------------------------------------------------------
      ju0 = n+2
      jlu(1) = ju0
c
c     initialize nonzero indicator array.
c
      do 1 j=1,n
         jw(n+j)  = 0
 1    continue
c-----------------------------------------------------------------------
c     beginning of main loop.
c-----------------------------------------------------------------------
      do 500 ii = 1, n
         j1 = ia(ii)
         j2 = ia(ii+1) - 1
         tnorm = 0.0d0
         do 501 k=j1,j2
            tnorm = tnorm+abs(a(k))
 501     continue
         if (tnorm .eq. 0.0) goto 999
         tnorm = tnorm/real(j2-j1+1)
c
c     unpack L-part and U-part of row of A in arrays w
c
         lenu = 1
         lenl = 0
         jw(ii) = ii
         w(ii) = 0.0
         jw(n+ii) = ii
c
         do 170  j = j1, j2
            k = ja(j)
            t = a(j)
            if (k .lt. ii) then
               lenl = lenl+1
               jw(lenl) = k
               w(lenl) = t
               jw(n+k) = lenl
            else if (k .eq. ii) then
               w(ii) = t
            else
               lenu = lenu+1
               jpos = ii+lenu-1
               jw(jpos) = k
               w(jpos) = t
               jw(n+k) = jpos
            endif
 170     continue
         jj = 0
         len = 0
c
c     eliminate previous rows
c
 150     jj = jj+1
         if (jj .gt. lenl) goto 160
c-----------------------------------------------------------------------
c     in order to do the elimination in the correct order we must select
c     the smallest column index among jw(k), k=jj+1, ..., lenl.
c-----------------------------------------------------------------------
         jrow = jw(jj)
         k = jj
c
c     determine smallest column index
c
         do 151 j=jj+1,lenl
            if (jw(j) .lt. jrow) then
               jrow = jw(j)
               k = j
            endif
 151     continue
c
         if (k .ne. jj) then
c     exchange in jw
            j = jw(jj)
            jw(jj) = jw(k)
            jw(k) = j
c     exchange in jr
            jw(n+jrow) = jj
            jw(n+j) = k
c     exchange in w
            s = w(jj)
            w(jj) = w(k)
            w(k) = s
         endif
c
c     zero out element in row by setting jw(n+jrow) to zero.
c
         jw(n+jrow) = 0
c
c     get the multiplier for row to be eliminated (jrow).
c
         fact = w(jj)*alu(jrow)
         if (abs(fact) .le. droptol) goto 150
c
c     combine current row and row jrow
c
         do 203 k = ju(jrow), jlu(jrow+1)-1
            s = fact*alu(k)
            j = jlu(k)
            jpos = jw(n+j)
            if (j .ge. ii) then
c
c     dealing with upper part.
c
               if (jpos .eq. 0) then
c
c     this is a fill-in element
c
                  lenu = lenu+1
                  if (lenu .gt. n) goto 995
                  i = ii+lenu-1
                  jw(i) = j
                  jw(n+j) = i
                  w(i) = - s
               else
c
c     this is not a fill-in element
c
                  w(jpos) = w(jpos) - s
               endif
            else
c
c     dealing  with lower part.
c
               if (jpos .eq. 0) then
c
c     this is a fill-in element
c
                  lenl = lenl+1
                  if (lenl .gt. n) goto 995
                  jw(lenl) = j
                  jw(n+j) = lenl
                  w(lenl) = - s
               else
c
c     this is not a fill-in element
c
                  w(jpos) = w(jpos) - s
               endif
            endif
 203     continue
c
c     store this pivot element -- (from left to right -- no danger of
c     overlap with the working elements in L (pivots).
c
         len = len+1
         w(len) = fact
         jw(len)  = jrow
         goto 150
 160     continue
c
c     reset double-pointer to zero (U-part)
c
         do 308 k=1, lenu
            jw(n+jw(ii+k-1)) = 0
 308     continue
c
c     update L-matrix
c
         lenl = len
         len = min0(lenl,lfil)
c
c     sort by quick-split
c
         if(lenl.GT.0) then
         call qsplit (w,jw,lenl,len)
         endif
c
c     store L-part
c
         do 204 k=1, len
            if (ju0 .gt. iwk) goto 996
            alu(ju0) =  w(k)
            jlu(ju0) =  jw(k)
            ju0 = ju0+1
 204     continue
c
c     save pointer to beginning of row ii of U
c
         ju(ii) = ju0
c
c     update U-matrix -- first apply dropping strategy
c
         len = 0
         do 205 k=1, lenu-1
            if (abs(w(ii+k)) .gt. droptol*tnorm) then
               len = len+1
               w(ii+len) = w(ii+k)
               jw(ii+len) = jw(ii+k)
            endif
205      continue
         lenu = len+1
         len = min0(lenu,lfil)
c
      if((lenu-1).GT.0) then
      call qsplit (w(ii+1), jw(ii+1), lenu-1,len)
      endif
c
c     copy
c
         t = abs(w(ii))
         if (len + ju0 .gt. iwk) goto 997
         do 302 k=ii+1,ii+len-1
            jlu(ju0) = jw(k)
            alu(ju0) = w(k)
            t = t + abs(w(k) )
            ju0 = ju0+1
 302     continue
c
c     store inverse of diagonal element of u
c
         if (w(ii) .eq. 0.0) w(ii) = (0.0001 + droptol)*tnorm
c
         alu(ii) = 1.0d0/ w(ii)
c
c     update pointer to beginning of next row of U.
c
         jlu(ii+1) = ju0
c-----------------------------------------------------------------------
c     end main loop
c-----------------------------------------------------------------------
 500  continue
      ierr = 0
      return
c
c     incomprehensible error. Matrix must be wrong.
c
 995  ierr = -1
      return
c
c     insufficient storage in L.
c
 996  ierr = -2
      return
c
c     insufficient storage in U.
c
 997  ierr = -3
      return
c
c     illegal lfil entered.
c
 998  ierr = -4
      return
c
c     zero row encountered
c
 999  ierr = -5
      return
c----------------end-of-ilut--------------------------------------------
      end


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine newder(f,dy,r,nr)
c     ================================================================
c
      implicit real*8 (a-h,o-z)
c
      integer    i
c
      real*8 r(nr),c(4),f(nr),dy(nr)
c
      ip1=1
      do i=1,nr-1
	ip1=ip1+1

        call fit(r,f,nr,i,c)

      dr=r(ip1)-r(i)
      c2=c(4)*dr
      if(i.gt.1) then
c Use the previous fit and the current fit to form a five-point interpolation
c   f5(r)=0.5*(f4(r)+f4p(r))+(f4(r)-f4p(r))*(r-0.5*(rm+rp))/(rp-rm)
c So the derivative is
c   df5(r)=0.5*(df4(r)+df4p(r))+(df4(r)-df4p(r))*(r-0.5*(rm+rp))/(rp-rm)
c          +(f4(r)-f4p(r))/(rp-rm)
c   but f4(r)=f4p(r)=f(i)
	dyold=dy(i)
	dynew=c(3)-c(1)*c2
        dy(i)=0.5d0*(dy(i)+dynew)
	if(i.gt.2.and.i.lt.nr-1) then
	  dr=r(i+2)-r(i-2)
	  rj=0.5d0*(r(i+2)+r(i-2))
	  dy(i)=dy(i)+(dynew-dyold)*(r(i)-rj)/dr
	endif
      else
        dy(i)=c(3)-c(1)*c2
      endif
      dy(i+1)=c(3)+(f(ip1)-f(i)+c(1)-c(2)*dr)*c2
      enddo
      return
      end


	SUBROUTINE DP_UDIF  ( idata, kxky, nbits, p1, difmin, scale,
     +			      misflg, kx, grid, iret )
C************************************************************************
C* DP_UDIF								*
C*									*
C* This subroutine unpacks a grid in the GEMPAK DIF format.  The	*
C* value of the difference between a point and the previous point	*
C* is packed using the equations:					*
C*									*
C*	IDIF  =  NINT ( ( GDIF - DIFMIN ) / SCALE )			*
C*	GDIF  =  DIFMIN  +  IDIF * SCALE				*
C*									*
C* DP_UDIF  ( IDATA, KXKY, NBITS, P1, DIFMIN, SCALE, MISFLG, KX,	*
C*            GRID, IRET )						*
C*									*
C* Input parameters:							*
C*	IDATA (*)	INTEGER		Packed data			*
C*	KXKY		INTEGER		Total number of grid points	*
C*	NBITS		INTEGER		Number of bits			*
C*	P1		REAL		Value of first grid point	*
C*	DIFMIN		REAL		Minimum value of differences	*
C*	SCALE		REAL		Scaling factor			*
C*	MISFLG		LOGICAL		Missing data flag		*
C*	KX		INTEGER		Number of points in x dir	*
C*									*
C* Output parameters:							*
C*	GRID (KX,KY)	REAL		Grid data			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-10 = NBITS invalid		*
C*					-11 = invalid data range	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 3/89						*
C* T. Piper/GSC		 3/99	Corrected prolog			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid  (KX,*)
	INTEGER		idata (*)
	LOGICAL		misflg
C*
	LOGICAL		first, line
C*
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for valid input.
C
	IF  ( ( nbits .le. 1 ) .or. ( nbits .gt. 31 ) )  THEN
	    iret = -10
	    RETURN
	END IF
C
C*	Set missing data value and compute ky.
C
	imiss = 2 ** nbits - 1
	ky    = kxky / kx
C
C*	Loop through all the data points.
C
	first = .true.
	ibit  = 1
	iword = 1
	DO  j = 1, ky
	    line = .false.
	    DO  i = 1, kx
C
C*		Get the integer from the buffer.
C
		jshft = nbits + ibit - 33
		idat  = 0
		idat  = ISHFT ( idata (iword), jshft )
		idat  = IAND  ( idat, imiss )
C
C*		Check to see if packed integer overflows into next word.
C
		IF  ( jshft .gt. 0 )  THEN
		    jshft = jshft - 32
		    idat2 = 0
		    idat2 = ISHFT ( idata (iword+1), jshft )
		    idat  = IOR ( idat, idat2 )
		END IF
C
C*		Set location for next word.
C
		ibit = ibit + nbits
		IF  ( ibit .gt. 32 )  THEN
		    ibit  = ibit - 32
		    iword = iword + 1
		END IF
C
C*		Compute data value.
C
		IF  ( misflg .and. ( idat .eq. imiss ) )  THEN
		    grid (i,j) = RMISSD
		  ELSE
		    IF  ( first )  THEN
			grid (i,j) = p1
			psav  = p1
			plin  = p1
			line  = .true.
			first = .false.
		      ELSE
			IF  ( .not. line )  THEN
			    grid (i,j) = plin + (difmin + idat * scale)
			    line = .true.
			    plin = grid (i,j)
			  ELSE
			    grid (i,j) = psav + (difmin + idat * scale)
			END IF
			psav = grid (i,j)
		    END IF
		END IF
	    END DO
	END DO
C*
	RETURN
	END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert from camera coordinates (line,sample) to ring plane coordinates
C (radius,longitude) for a perspective projection camera system.  The
C line-sample coordinates are assumed to be in object space.
C
      SUBROUTINE RING_INV(OM,VSC,FL,OAL,OAS,SCALE,RLINE,RSAMP,
     &		radius,rlon,ind)
      IMPLICIT NONE
      REAL*8 OM(3,3)		!Camera to planet transformation matrix
      REAL*8 VSC(3)		!Vector from target center to spacecraft (RS)
      REAL*4 FL			!Camera focal length in mm
      REAL*4 OAL,OAS		!Optical axis intercept line-sample
      REAL*4 SCALE 		!Picture scale in pixels/mm
      REAL*8 RLINE,RSAMP 	!Input image coordinates
      REAL*8 RADIUS,RLON	!Output ring coordinates.
      INTEGER*4 IND		! =1 If RADIUS,RLON are valid, =0 otherwise

      REAL*8 x0,y0,z0,xc,yc,zc,x,y,S
      REAL*8 PI/3.141592653589793D0/,DPR

      DPR = 180.D0/PI          !degrees per radian

C     ...Vector from spacecraft to point on ring in camera coordinate system
      x0 = RSAMP - OAS
      y0 = RLINE - OAL
      z0 = FL*SCALE
C     ...Convert vector to target-centered coordinates
      xc = OM(1,1)*x0 + OM(2,1)*y0 + OM(3,1)*z0
      yc = OM(1,2)*x0 + OM(2,2)*y0 + OM(3,2)*z0
      zc = OM(1,3)*x0 + OM(2,3)*y0 + OM(3,3)*z0

      S = -VSC(3)/zc		!Scale in km per pixel
      IF (S.LT.0.) THEN		!Camera is looking away from ring plane
	IND = 0
        RETURN
      ENDIF

      X = S*xc + VSC(1)
      Y = S*yc + VSC(2)
      RADIUS = DSQRT(X**2+Y**2)
      RLON = - DMOD(DATAN2(Y,X)*DPR,360.D0)	!West longitude
      IF (RLON .LT. 0.D0) RLON= RLON+360.D0
      IND = 1
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: tables.f,v 1.1 2010/02/23 01:10:43 rtoy Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE TABLES (IDO,IP,WA)
      REAL  WA(IDO,IP-1,2)
C
      TPI = 8.*ATAN(1.)
      ARGZ = TPI/REAL(IP)
      ARG1 = TPI/REAL(IDO*IP)
      DO 110 J=2,IP
         ARG2 = REAL(J-1)*ARG1
         DO 100 I=1,IDO
            ARG3 = REAL(I-1)*ARG2
            WA(I,J-1,1) = COS(ARG3)
            WA(I,J-1,2) = SIN(ARG3)
  100    CONTINUE
         IF (IP .LE. 5) GO TO 110
         ARG4 = REAL(J-1)*ARGZ
         WA(1,J-1,1) = COS(ARG4)
         WA(1,J-1,2) = SIN(ARG4)
  110 CONTINUE
      RETURN
      END


!Modified version of Komatsu's CRL function
!(http://www.mpa-garching.mpg.de/~komatsu/crl/)
!compute_pk_nowiggle for CosmoSIS - AM

! A sample program for computing the linear power spectrum
! of density fluctuations using Eisenstein&Hu's transfer function
! without the baryonic oscillation. See Eq.(29) of
! Eisenstein & Hu, ApJ, 496, 605 (1998)
! - k is in units of h Mpc^-1
! - P(k) is in units of h^-3 Mpc^3
! January 1, 2012: E.Komatsu

MODULE Compute_Pk_NoWiggle
  USE interface_tools
  USE pk_EisensteinHu
  IMPLICIT none

private
public compute_pknowiggle

contains

  subroutine compute_pknowiggle(k_ov_h,A_s,n_s,h0,om0,ob0,pk)
    !  k_ov_h in h Mpc^-1

    real(dl), INTENT(IN) :: k_ov_h,A_s,h0,om0,ob0,n_s
    real(dl),INTENT(INOUT) :: pk
    DOUBLE PRECISION :: trans
    CALL eisensteinhu(k_ov_h*h0,om0*h0**2d0,ob0/om0,trans)
    ! Eq.(74) of Komatsu et al., ApJS, 180, 330 (2009) with kWMAP=0.05/Mpc
    ! Remember that ak is in units of h/Mpc whereas "k" in Eq.(74) is in units
    ! of 1/Mpc. Be carefull you are using the same definition of As in other modules
    ! i.e same k_pivot

    pk=A_s*(2d0*k_ov_h**2d0*2998d0**2d0/5d0/om0)**2d0 &
         *trans**2d0*(k_ov_h*h0/0.05d0)**(n_s-1d0) &
         *2d0*3.14159265359d0**2d0/k_ov_h**3d0

    !  I commented growth_z0**2d0 so you have to put the z dependence by hands.
  end subroutine compute_pknowiggle

END MODULE Compute_Pk_NoWiggle


c $Revision: 2.4 $
c     subprogram binsum

c-- calculate interpolation weights and vsum

      subroutine binsum( nf, x, y, z, f,
     &			 xx, yy, zz, vsum,
     &			 ixmin, ixmax, iymin,
     &			 iymax, izmin, izmax,
     &			 imax, jmax, kmax, ndatamax )

      real*4 x(ndatamax),y(ndatamax),z(ndatamax),f(ndatamax)
      real*4 xx(imax),yy(jmax),zz(kmax)
      real*4 vsum(2,imax,jmax,kmax)
      integer*4 ixmin(ndatamax),ixmax(ndatamax)
      integer*4 iymin(ndatamax),iymax(ndatamax)
      integer*4 izmin(ndatamax),izmax(ndatamax)

      common /parms/ imin,jmin,kmin,
     &               xwin2,ywin2,zwin2,
     &               xh,yh,zh,
     &               dx,dy,dz,
     &               xlo,xhi,ylo,yhi,zlo,
     &               dxd,dyd

      data xfac/-0.6931/

      do n=1,nf
        ixmin(n)=max(nint((x(n)-xwin2-xlo+0.5*dx)/dx),1)
        ixmax(n)=min(nint((x(n)+xwin2-xlo+0.5*dx)/dx),imax)
        iymin(n)=max(nint((y(n)-ywin2-ylo+0.5*dy)/dy),1)
        iymax(n)=min(nint((y(n)+ywin2-ylo+0.5*dy)/dy),jmax)
        izmin(n)=max(nint((z(n)-zwin2-zlo+0.5*dz)/dz),1)
        izmax(n)=min(nint((z(n)+zwin2-zlo+0.5*dz)/dz),kmax)
c        print *, x(n),y(n),z(n), f(n)
c	print *,' ixmin, ixmax', ixmin(n), ixmax(n)
c	print *,' iymin, iymax', iymin(n), iymax(n)
c	print *,' izmin, izmax', izmin(n), izmax(n)
      enddo

      do n=1,nf
        do kk=izmin(n),izmax(n)
          do jj=iymin(n),iymax(n)
            do ii=ixmin(n),ixmax(n)

c- - this is the algorithm coded for weights

                fac=exp( xfac*(((x(n)-xx(ii))/xh)**2
     &                       + ((y(n)-yy(jj))/yh)**2
     &			     + ((z(n)-zz(kk))/zh)**2) )

c            print *, 'x, xx,  y, yy,  z, zz, fac f',
c     &        x(n), xx(ii),  y(n), yy(jj), z(n), zz(kk), fac, f(n)

                vsum(1,ii,jj,kk)=vsum(1,ii,jj,kk)+f(n)*fac
                vsum(2,ii,jj,kk)=vsum(2,ii,jj,kk)+fac
            enddo
          enddo
        enddo
      enddo
      return
      end


C --------------------------FileRead----------------------------------
C Author:  Nicolas Luco
C Last Revised:  11 September 2003
C Reference:  "Dynamics of Structures" (1995) by A.K. Chopra
C
C Alpha = 2% as used in:
C   "EFFECTS OF EARTHQUAKE RECORD SCALING ON NONLINEAR STRUCTURAL RESPONSE"
C   Report on PEER-LL Program Task 1G00 Addendum (Sub-Task 1 of 3)
C   Nicolas Luco & Paolo Bazzurro
C   AIR Worldwide Corporation (San Francisco, CA)
C
C INPUT:
C ======
C T     = periods                           (scalar )
C z     = damping ratios                    ( " )
C dy    = yield displacements               ( " )
C alpha = strain hardening ratios           ( " )
C ag    = ground acceleration time history  ( length(ag) x 1 )
C Dtg   = time step of ag                   ( scalar )
C Dt    = analyis time step                 ( scalar )
C
C OUTPUT:
C =======
C   d  = relative displacement response time history  ( length(ag) )
C   v  = relative velocity response time history      ( " )
C   a  = acceleration response time history           ( " )
C   fs = force response time history                  ( " )
C
C --------------------------------------------------------------------
      subroutine InElastic( T, dy, ag, dt, nt, maxD)
      implicit none
      integer             :: i, j, nt
      real                :: T, z, dy, alpha, dt, AA, BB, fy
      real                :: Sd, Sv, Sa
      real                :: ggg, beta, m, w, pi, c, k, kalpha
      real                :: ki, DPi, Ddi, maxD, maxV, maxA
      real                :: fsmax, fsmin, Df, DR, Dvi, Kki
      real, dimension(nt) :: tt, d, v, a, fs, ag, p
C --------------------------------------------------------------------
      data ggg/0.5/
      data beta/0.16666667/
      data alpha/0.02/
      data z/0.05/
      data pi/3.14159265358979323846/
C --------------------------------------------------------------------
C m*a + c*v + fs(k,fy,kalpha) = p
C --------------------------------------------------------------------
      m = 1.0
      w = 2.0*pi / T
      c = z * (2.0*m*w)
      k = (w**2.0 * m)
      fy = k * dy
      kalpha = k * alpha

      do i = 1,nt
         tt(i) = REAL(i-1)*dt
         p(i) = -ag(i)*m
         d(i) = 0.0
         v(i) = 0.0
         a(i) = 0.0
         fs(i) = 0.0
      enddo

      a(1) = ( p(1) - c*v(1) - fs(1) ) / m
      AA = (1.0/(beta*dt))*m + (ggg/beta)*c
      BB = (1.0/(2.0*beta))*m + dt*((ggg/(2.0*beta))-1.0)*c

      do i = 1,(nt-1)

          DPi = p(i+1)-p(i) + AA*v(i) + BB*a(i)

          ki = k
        if(((DPi .GT. 0.0) .AND. (fs(i) .GE. fy+kalpha*(d(i)-dy))).OR.
     +   ((DPi .LT. 0.0) .AND. (fs(i) .LE. -fy+kalpha*(d(i)+dy))))then
              ki = kalpha
          endif

C = ki + GAMMA/(BETA*dt)*c + 1/(BETA*dt**2.0)*m
          Kki = ki + AA/dt

          Ddi = DPi / Kki
          fs(i+1) = fs(i) + ki*Ddi
          d(i+1) = d(i) + Ddi

          fsmax =  fy + kalpha*(d(i+1)-dy)
          fsmin = -fy + kalpha*(d(i+1)+dy)

          if( fs(i+1) .GT. fsmax ) then
              fs(i+1) = fsmax
              Df = fs(i+1) - fs(i) + (Kki-ki)*Ddi
              DR = DPi - Df
              Ddi = Ddi + DR / Kki
              d(i+1) = d(i) + Ddi
          endif

          if( fs(i+1) .LT. fsmin ) then
              fs(i+1) = fsmin
              Df = fs(i+1) - fs(i) + (Kki-ki)*Ddi
              DR = DPi - Df
              Ddi = Ddi + DR / Kki
              d(i+1) = d(i) + Ddi
          endif

          Dvi = (ggg/(beta*dt))*Ddi - (ggg/beta)*v(i) +
     +          dt*(1.0-(ggg/(2.0*beta)))*a(i)
          v(i+1) = v(i) + Dvi
          a(i+1) = (p(i+1) - c*v(i+1) - fs(i+1))/m

      enddo

C Spectral values
C ---------------
      Sd = maxval( abs(d) )
      Sv = Sd * (2.0*pi/T)
      Sa = Sd * (2.0*pi/T)**2.0

      maxD = maxval(abs(d))
      maxV = maxval(abs(v))
      maxA = maxval(abs(a))

      end subroutine InElastic
C --------------------------------------------------------------------


! { dg-do run }

if (modulo (-8., -5.) .ne. -3.) call abort ()

end


      PROGRAM LA_SSPSV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements"
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SPSV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, N, NN, NRHS
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IPIV(:)
      REAL(WP), ALLOCATABLE :: B(:,:), AP(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'SSPSV Example Program Results.'
      N = 5; NRHS = 3
      WRITE(*,'(5H N = , I4, 9H; NRHS = , I4)') N, NRHS
      NN = N*(N+1)/2
      ALLOCATE ( AP(NN), B(N,NRHS), IPIV(N) )

      OPEN(UNIT=21,FILE='spsv.ma',STATUS='UNKNOWN')
      DO I=1,NN
            READ(21,'(F3.0)') AP(I)
         ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix AP :'
      DO I=1,NN; WRITE(*,"(15(I3,1X,1X),I3,1X))") INT(AP(I));
      ENDDO

      OPEN(UNIT=21,FILE='spsv.mb',STATUS='UNKNOWN')
      DO I=1,N
         READ(21,'(F3.0)') B(I,1)
      ENDDO
      CLOSE(21)

      WRITE(*,*)'Matrix B :'
      DO I=1,N; WRITE(*,"(10(I3,1X,1X),I3,1X)')") INT(B(I,1));
      ENDDO

      WRITE(*,*)" CALL LA_SPSV( AP, B, 'L', IPIV )"

      CALL LA_SPSV( AP, B, 'L', IPIV )

      WRITE(*,*)'AP on exit: '
      DO I=1,NN; WRITE(*,"(15(E13.5))") AP(I);
      ENDDO

      WRITE(*,*)'Matrix B on exit :'
      DO I=1,N; WRITE(*,"(F9.5)") B(I,1);
      ENDDO
      WRITE(*,*)'IPIV = ', IPIV

      END PROGRAM LA_SSPSV_EXAMPLE


! This function identifies the set of row vectors in a Vandermonde
! matrix that should be kept. It outputs the row indices, however
! it expects the Vandermonde matrix to be provided in its transpose.
! Inspiration for greedy selection technique from:
!
!    Bos, Len, et al. "Computing multivariate Fekete and Leja points
!    by numerical linear algebra." SIAM Journal on Numerical Analysis
!    48.5 (2010): 1984-1999. DOI 10.1137/090779024
!
! USES LAPACK:
!    DGEQP3  --  (double precision QR decomposition with column pivoting)
!
! INPUT:
!    VM_T  --  The transposed Vandermonde matrix. Given functions
!              {f_1, ..., f_k} and points {p_1, ..., p_n}, we have
!                   VM_T_{i,j} = f_i(p_j)
!
! OUTPUT:
!    INDS  --  The sequence of indices (of the points {p_i}) that
!              are most useful in determining an interpolant. E.g.
!              to make a Vandermonde matrix square that was
!              previously long (more points than functions), use the
!              points at indices JPVT(1:K) as the Fekete points.
!
SUBROUTINE FEKETE_INDICES(VM_T, INDS, INFO)
  USE ISO_FORTRAN_ENV, ONLY: REAL64
  EXTERNAL :: DGEQP3
  REAL(KIND=REAL64), INTENT(IN), DIMENSION(:,:) :: VM_T
  INTEGER, INTENT(OUT), DIMENSION(SIZE(VM_T,2)) :: INDS
  INTEGER, INTENT(OUT)                          :: INFO
  ! Local variables.
  REAL(KIND=REAL64), DIMENSION(SIZE(VM_T,1))   :: TAU
  REAL(KIND=REAL64), DIMENSION(:), ALLOCATABLE :: WORK
  ! Set all columns to be "free" (movable).
  INDS(:) = 0
  ! Do a work array size query (store size in TAU).
  CALL DGEQP3(SIZE(VM_T,1), SIZE(VM_T,2), VM_T, SIZE(VM_T,1), &
       INDS, TAU, TAU, -1, INFO)
  ! Allocate the work array.
  ALLOCATE( WORK(INT(TAU(1))) )
  ! Call the QR (with column pivoting) function.
  CALL DGEQP3(SIZE(VM_T,1), SIZE(VM_T,2), VM_T, SIZE(VM_T,1), &
       INDS, TAU, WORK, SIZE(WORK), INFO)
  DEALLOCATE( WORK )
END SUBROUTINE FEKETE_INDICES

! Evaluate polynomials at points to construct a Vandermonde matrix,
! the lengths are the number of terms in each polynomial, the indices
! are the active index terms in each polynomial.
!
! This should be super fast, aka even a matrix with 100M elements should
! take less than one second. For some reason it appears to slow down when
! (SIZE(POINTS, 1) == 1). That is the reason for including schedule(dynamic),
! which does not have a huge negative effect otherwise.
SUBROUTINE EVALUATE_VANDERMONDE(POINTS, DEGREES, INDICES, VANDERMONDE)
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  REAL(KIND=REAL64),   INTENT(IN),  DIMENSION(:,:) :: POINTS
  INTEGER(KIND=INT64), INTENT(IN),  DIMENSION(:)   :: DEGREES
  INTEGER(KIND=INT64), INTENT(IN),  DIMENSION(:,:) :: INDICES
  REAL(KIND=REAL64),   INTENT(OUT), DIMENSION(SIZE(DEGREES),SIZE(POINTS,2)) :: VANDERMONDE
  ! Local variables.
  INTEGER :: I, J
  ! Compute the Vandermonde matrix values.
  !$omp parallel do schedule(dynamic) private(i,j)
  pts : DO I = 1,SIZE(POINTS,2)
     funcs : DO J = 1,SIZE(DEGREES)
        ! Assign the value of the Vandermonde matrix at this point.
        IF (DEGREES(J) .EQ. 0_INT64) THEN
           VANDERMONDE(J,I) = 1.0_REAL64
        ELSE
           VANDERMONDE(J,I) = PRODUCT(POINTS(INDICES(1:DEGREES(J),J), I))
        END IF
     END DO funcs
  END DO pts
  !$omp end parallel do
END SUBROUTINE EVALUATE_VANDERMONDE


  !! Local Data
  REAL(NTREAL) :: alpha
  REAL(NTREAL) :: threshold
  !! Temporary Variables
  INTEGER :: working_index_a, working_index_b
  !! Counter Variables
  INTEGER :: counter_a, counter_b, counter_c

  !! Process Optional Parameters
  IF (.NOT. PRESENT(alpha_in)) THEN
     alpha = 1.0d+0
  ELSE
     alpha = alpha_in
  END IF
  IF (.NOT. PRESENT(threshold_in)) THEN
     threshold = 0.0d+0
  ELSE
     threshold = threshold_in
  END IF

  counter_a = 1
  counter_b = 1
  counter_c = 1
  sum_loop: DO WHILE(counter_a .LE. SIZE(inner_index_a) .AND. counter_b .LE. &
       & SIZE(inner_index_b))
     !! Current inner indices and values
     working_index_a = inner_index_a(counter_a)
     working_index_b = inner_index_b(counter_b)
     working_value_a = alpha*values_a(counter_a)
     working_value_b = values_b(counter_b)
     !! Figure out from which vector an insertion will be performed
     IF (working_index_a .EQ. working_index_b) THEN
        IF (ABS(working_value_a + working_value_b) .GT. threshold) THEN
           inner_index_c(counter_c) = working_index_a
           values_c(counter_c) = working_value_a + working_value_b
           counter_c = counter_c + 1
        END IF
        counter_a = counter_a + 1
        counter_b = counter_b + 1
     ELSE IF (working_index_a .GT. working_index_b) THEN
        IF (ABS(working_value_b) .GT. threshold) THEN
           inner_index_c(counter_c) = working_index_b
           values_c(counter_c) = working_value_b
           counter_c = counter_c + 1
        END IF
        counter_b = counter_b + 1
     ELSE !! implies working_index_b > working_index_b
        IF (ABS(working_value_a) .GT. threshold) THEN
           inner_index_c(counter_c) = working_index_a
           values_c(counter_c) = working_value_a
           counter_c = counter_c + 1
        END IF
        counter_a = counter_a + 1
     END IF
  END DO sum_loop

  !! Handle case where one was blank
  cleanup_a: DO WHILE (counter_a .LE. SIZE(inner_index_a))
     inner_index_c(counter_c) = inner_index_a(counter_a)
     values_c(counter_c) = values_a(counter_a)*alpha
     counter_a = counter_a + 1
     counter_c = counter_c + 1
  END DO cleanup_a
  cleanup_b: DO WHILE (counter_b .LE. SIZE(inner_index_b))
     inner_index_c(counter_c) = inner_index_b(counter_b)
     values_c(counter_c) = values_b(counter_b)
     counter_b = counter_b + 1
     counter_c = counter_c + 1
  END DO cleanup_b

  total_values_c = counter_c - 1


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program test_inv_gamma

! test the gamma distribution random number generator routine
! with different means, standard deviations, and iteration counts.

use      types_mod, only : r8
use  utilities_mod, only : register_module, &
                           open_file, close_file, &
                           initialize_utilities, finalize_utilities, &
                           squeeze_out_blanks
use random_seq_mod, only : random_seq_type, init_random_seq, random_inverse_gamma

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
integer :: i, j, n, f
real(r8) :: r1, sum, sumsq, a, b, l
real(r8) :: mean, var, sd, compmean, compvar, compsd, compdiffm, compdiffsd
logical  :: write_this_one
character(len=256) :: fname, temp

character(len=50) :: formf = '(I12,2(F8.3),4(F12.5),2(F16.10),2(F12.5))'
logical :: write_me = .true.       ! if true, write each distribution into a file for later diagnostics
integer :: write_limit = 1000000   ! but only if rep count is not greater than this limit

type t_inputs
 real(r8) :: t_alpha
 real(r8) :: t_beta
 integer  :: t_nreps
end type

! to add more tests or change the parameters, specify a test count
! and update the sets of inputs here:

integer, parameter :: ntests = 27
type(t_inputs) :: t(ntests) = (/ &
     t_inputs(  3.0_r8,  0.20_r8,       100), &
     t_inputs(  3.0_r8,  0.20_r8,     10000), &
     t_inputs(  3.0_r8,  0.20_r8,   1000000), &
     t_inputs(  3.0_r8,  0.20_r8, 100000000), &
     t_inputs(  5.0_r8,  0.40_r8,   4000000), &
     t_inputs(  5.0_r8,  2.00_r8,   5000000), &
     t_inputs(  5.0_r8,  0.60_r8,       100), &
     t_inputs(  5.0_r8,  0.60_r8,     10000), &
     t_inputs(  5.0_r8,  0.60_r8,   1000000), &
     t_inputs(  5.0_r8,  0.60_r8, 100000000), &
     t_inputs(  3.0_r8,  0.50_r8,   1000000), &
     t_inputs(  4.0_r8,  0.50_r8,   1000000), &
     t_inputs(  5.0_r8,  0.50_r8,   1000000), &
     t_inputs(  6.0_r8,  0.50_r8,   1000000), &
     t_inputs(  6.0_r8,  0.01_r8,   1000000), &
     t_inputs( 86.0_r8,  0.01_r8,   1000000), &
     t_inputs(  6.6_r8,  0.01_r8,   1000000), &
     t_inputs(  6.0_r8,  0.01_r8,   1000000), &
     t_inputs(956.0_r8,  0.01_r8,   1000000), &
     t_inputs( 36.0_r8,  0.01_r8,   1000000), &
     t_inputs(  6.0_r8,  0.03_r8,   1000000), &
     t_inputs(  6.0_r8,  0.09_r8,   1000000), &
     t_inputs(  6.0_r8,  9.00_r8,   1000000), &
     t_inputs(  6.0_r8,  0.10_r8,   1000000), &
     t_inputs(  6.0_r8,  0.80_r8,   1000000), &
     t_inputs(  6.0_r8,  0.50_r8,   1000000), &
     t_inputs(  6.0_r8,  3.50_r8,   1000000)  /)

call initialize_utilities('test_inv_gamma')
call register_module(source,revision,revdate)

write(*, *) ''
write(*, *) 'sample size     input a & b       computed mean, sd         actual mean, sd       diff mean         diff sd        % diff mean,  sd'
write(*, *) ''

do j=1, ntests

   call init_random_seq(r, 5)

   a = t(j)%t_alpha
   b = t(j)%t_beta
   n = t(j)%t_nreps

   ! save all values in a file for post-plotting?
   write_this_one = (write_me .and. n <= write_limit)

   if (write_this_one) then
      write(temp, "(A,F8.3,A,F8.3,A,I10)") "invgamma_", a, "_", b, "_", n
      call squeeze_out_blanks(temp, fname)
      f = open_file(fname)
   endif

   ! analytical values:

   ! lambda = scale, beta = rate
   l = 1.0_r8 / b

   if (a > 1.0_r8) then
      mean  = b / (a - 1.0_r8)
   else
      mean  = b  ! ??
   endif
   if (a > 2.0_r8) then
      sd  = sqrt((b*b) / ((a - 1.0)**2 * (a - 2.0_r8)))
   else
      sd  = b    ! ??
   endif

   sum = 0.0_r8
   sumsq = 0.0_r8

   ! inverse gamma wants shape and scale.
   do i = 1, n
      r1 = random_inverse_gamma(r, a, l)

      if (write_this_one) write(f,*) r1

      sum = sum + r1
      sumsq = sumsq + (r1 - mean)**2
   end do

   if (write_this_one) call close_file(f)

   ! computed values:
   compmean = sum / n
   compsd = sqrt(sumsq/n)

   ! differences
   compdiffm  = compmean - mean
   compdiffsd = compsd - sd

   write(*, formf) n, a, b, mean, sd, compmean, compsd, compdiffm, compdiffsd, &
                      abs(compdiffm/mean) * 100._r8, abs(compdiffsd/sd) * 100._r8

enddo

call finalize_utilities()

end program test_inv_gamma

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!  SW4 LICENSE
! # ----------------------------------------------------------------------
! # SW4 - Seismic Waves, 4th order
! # ----------------------------------------------------------------------
! # Copyright (c) 2013, Lawrence Livermore National Security, LLC.
! # Produced at the Lawrence Livermore National Laboratory.
! #
! # Written by:
! # N. Anders Petersson (petersson1@llnl.gov)
! # Bjorn Sjogreen      (sjogreen2@llnl.gov)
! #
! # LLNL-CODE-643337
! #
! # All rights reserved.
! #
! # This file is part of SW4, Version: 1.0
! #
! # Please also read LICENCE.txt, which contains "Our Notice and GNU General Public License"
! #
! # This program is free software; you can redistribute it and/or modify
! # it under the terms of the GNU General Public License (as published by
! # the Free Software Foundation) version 2, dated June 1991.
! #
! # This program is distributed in the hope that it will be useful, but
! # WITHOUT ANY WARRANTY; without even the IMPLIED WARRANTY OF
! # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the terms and
! # conditions of the GNU General Public License for more details.
! #
! # You should have received a copy of the GNU General Public License
! # along with this program; if not, write to the Free Software
! # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
c-----------------------------------------------------------------------
      subroutine WAVEPROPBOP_4( iop, iop2, bop, bop2, gh2, h, s )

***********************************************************************
***
*** SBP operator of order 2/4 for approximating 1st derivative. 5pt stencil.
***
***********************************************************************

      implicit none
      real*8 bop(4,6), bop2(4,6), gh2, h(4), s(0:4), iop(5), iop2(5)

*** Norm
      h(1) = 17d0/48
      h(2) = 59d0/48
      h(3) = 43d0/48
      h(4) = 49d0/48

*** First derivative interior, 4th order
      iop(1) =  1d0/12
      iop(2) = -2d0/3
      iop(3) =  0d0
      iop(4) =  2d0/3
      iop(5) = -1d0/12

*** First derivative bop, 2nd order
      bop(1,1) = -24.D0/17.D0
      bop(1,2) = 59.D0/34.D0
      bop(1,3) = -4.D0/17.D0
      bop(1,4) = -3.D0/34.D0
      bop(1,5) = 0
      bop(1,6) = 0
      bop(2,1) = -1.D0/2.D0
      bop(2,2) = 0
      bop(2,3) = 1.D0/2.D0
      bop(2,4) = 0
      bop(2,5) = 0
      bop(2,6) = 0
      bop(3,1) = 4.D0/43.D0
      bop(3,2) = -59.D0/86.D0
      bop(3,3) = 0
      bop(3,4) = 59.D0/86.D0
      bop(3,5) = -4.D0/43.D0
      bop(3,6) = 0
      bop(4,1) = 3.D0/98.D0
      bop(4,2) = 0
      bop(4,3) = -59.D0/98.D0
      bop(4,4) = 0
      bop(4,5) = 32.D0/49.D0
      bop(4,6) = -4.D0/49.D0

*** Second derivative interior, 4th order
      iop2(1) = -1d0/12
      iop2(2) =  4d0/3
      iop2(3) = -5d0/2
      iop2(4) =  4d0/3
      iop2(5) = -1d0/12

*** Second derivative bop, 2nd order
      gh2 = 12d0/17
      bop2(1,1) = -14.D0/17.D0
      bop2(1,2) = -13.D0/17.D0
      bop2(1,3) = 20.D0/17.D0
      bop2(1,4) = -5.D0/17.D0
      bop2(1,5) = 0
      bop2(1,6) = 0

      bop2(2,1) = 1
      bop2(2,2) = -2
      bop2(2,3) = 1
      bop2(2,4) = 0
      bop2(2,5) = 0
      bop2(2,6) = 0

      bop2(3,1) = -4.D0/43.D0
      bop2(3,2) = 59.D0/43.D0
      bop2(3,3) = -110.D0/43.D0
      bop2(3,4) = 59.D0/43.D0
      bop2(3,5) = -4.D0/43.D0
      bop2(3,6) = 0

      bop2(4,1) = -1.D0/49.D0
      bop2(4,2) = 0
      bop2(4,3) = 59.D0/49.D0
      bop2(4,4) = -118.D0/49.D0
      bop2(4,5) = 64d0/49
      bop2(4,6) = -4d0/49

*** boundary derivative, 4th order
      s(0) = -1d0/4
      s(1) = -5d0/6
      s(2) =  3d0/2
      s(3) = -1d0/2
      s(4) =  1d0/12

      end

c-----------------------------------------------------------------------
      subroutine WAVEPROPBOP_6( iop, iop2, bop, bop2, gh2, h, s )

***********************************************************************
***
*** SBP operator of order 3/6 for approximating 1st derivative. 7pt stencil
***
***********************************************************************

      implicit none
      real*8 bop(6,9), bop2(6,9), gh2, h(6), s(0:6), iop(7), iop2(7)

*** Norm
      h(1) = 13649.D0/43200.D0
      h(2) = 12013.D0/8640.D0
      h(3) = 2711.D0/4320.D0
      h(4) = 5359.D0/4320.D0
      h(5) = 7877.D0/8640.D0
      h(6) = 43801.D0/43200.D0

*** First derivative interior, 6th order
      iop(1) = -1d0/60
      iop(2) =  3d0/20
      iop(3) = -3d0/4
      iop(4) =  0d0
      iop(5) = -iop(3)
      iop(6) = -iop(2)
      iop(7) = -iop(1)

*** First derivative bop, 3nd order
      bop(1,1) = -21600.D0/13649.D0
      bop(1,2) = 2089388.D0/1023675.D0
      bop(1,3) = -352679.D0/2047350.D0
      bop(1,4) = -137949.D0/341225.D0
      bop(1,5) = 150971.D0/2047350.D0
      bop(1,6) = 45313.D0/1023675.D0
      bop(1,7) = 0
      bop(1,8) = 0
      bop(1,9) = 0
      bop(2,1) = -2089388.D0/4504875.D0
      bop(2,2) = 0
      bop(2,3) = 91517.D0/300325.D0
      bop(2,4) = 403421.D0/1801950.D0
      bop(2,5) = -12887.D0/300325.D0
      bop(2,6) = -65743.D0/3003250.D0
      bop(2,7) = 0
      bop(2,8) = 0
      bop(2,9) = 0
      bop(3,1) = 352679.D0/4066500.D0
      bop(3,2) = -91517.D0/135550.D0
      bop(3,3) = 0
      bop(3,4) = 139001.D0/203325.D0
      bop(3,5) = -27193.D0/271100.D0
      bop(3,6) = 3451.D0/677750.D0
      bop(3,7) = 0
      bop(3,8) = 0
      bop(3,9) = 0
      bop(4,1) = 137949.D0/1339750.D0
      bop(4,2) = -403421.D0/1607700.D0
      bop(4,3) = -139001.D0/401925.D0
      bop(4,4) = 0
      bop(4,5) = 433951.D0/803850.D0
      bop(4,6) = -478079.D0/8038500.D0
      bop(4,7) = 72.D0/5359.D0
      bop(4,8) = 0
      bop(4,9) = 0
      bop(5,1) = -150971.D0/5907750.D0
      bop(5,2) = 12887.D0/196925.D0
      bop(5,3) = 27193.D0/393850.D0
      bop(5,4) = -433951.D0/590775.D0
      bop(5,5) = 0
      bop(5,6) = 759996.D0/984625.D0
      bop(5,7) = -1296.D0/7877.D0
      bop(5,8) = 144.D0/7877.D0
      bop(5,9) = 0
      bop(6,1) = -45313.D0/3285075.D0
      bop(6,2) = 65743.D0/2190050.D0
      bop(6,3) = -3451.D0/1095025.D0
      bop(6,4) = 478079.D0/6570150.D0
      bop(6,5) = -759996.D0/1095025.D0
      bop(6,6) = 0
      bop(6,7) = 32400.D0/43801.D0
      bop(6,8) = -6480.D0/43801.D0
      bop(6,9) = 720.D0/43801.D0

*** Second derivative interior, 6th order
      iop2(1) = 1d0/90
      iop2(2) =-3d0/20
      iop2(3) = 3d0/2
      iop2(4) = -49d0/18
      iop2(5) = iop2(3)
      iop2(6) = iop2(2)
      iop2(7) = iop2(1)

*** Second derivative bop, 3rd order
      gh2 = 7200d0/13649
      bop2(1,1) = 10490.D0/40947.D0
      bop2(1,2) = -178907.D0/54596.D0
      bop2(1,3) = 163609.D0/40947.D0
      bop2(1,4) = -147397.D0/81894.D0
      bop2(1,5) = 3747.D0/13649.D0
      bop2(1,6) = 3755.D0/163788.D0
      bop2(1,7) = 0
      bop2(1,8) = 0
      bop2(1,9) = 0
      bop2(2,1) = 6173.D0/5860.D0
      bop2(2,2) = -2066.D0/879.D0
      bop2(2,3) = 3283.D0/1758.D0
      bop2(2,4) = -303.D0/293.D0
      bop2(2,5) = 2111.D0/3516.D0
      bop2(2,6) = -601.D0/4395.D0
      bop2(2,7) = 0
      bop2(2,8) = 0
      bop2(2,9) = 0
      bop2(3,1) = -52391.D0/81330.D0
      bop2(3,2) = 134603.D0/32532.D0
      bop2(3,3) = -21982.D0/2711.D0
      bop2(3,4) = 112915.D0/16266.D0
      bop2(3,5) = -46969.D0/16266.D0
      bop2(3,6) = 30409.D0/54220.D0
      bop2(3,7) = 0
      bop2(3,8) = 0
      bop2(3,9) = 0
      bop2(4,1) = 68603.D0/321540.D0
      bop2(4,2) = -12423.D0/10718.D0
      bop2(4,3) = 112915.D0/32154.D0
      bop2(4,4) = -75934.D0/16077.D0
      bop2(4,5) = 53369.D0/21436.D0
      bop2(4,6) = -54899.D0/160770.D0
      bop2(4,7) = 48.D0/5359.D0
      bop2(4,8) = 0
      bop2(4,9) = 0
      bop2(5,1) = -7053.D0/39385.D0
      bop2(5,2) = 86551.D0/94524.D0
      bop2(5,3) = -46969.D0/23631.D0
      bop2(5,4) = 53369.D0/15754.D0
      bop2(5,5) = -87904.D0/23631.D0
      bop2(5,6) = 820271.D0/472620.D0
      bop2(5,7) = -1296.D0/7877.D0
      bop2(5,8) = 96.D0/7877.D0
      bop2(5,9) = 0
      bop2(6,1) = 21035.D0/525612.D0
      bop2(6,2) = -24641.D0/131403.D0
      bop2(6,3) = 30409.D0/87602.D0
      bop2(6,4) = -54899.D0/131403.D0
      bop2(6,5) = 820271.D0/525612.D0
      bop2(6,6) = -117600.D0/43801.D0
      bop2(6,7) = 64800.D0/43801.D0
      bop2(6,8) = -6480.D0/43801.D0
      bop2(6,9) = 480.D0/43801.D0

      s(0) = -1d0/6
      s(1) = -77d0/60
      s(2) = 5d0/2
      s(3) = -5d0/3
      s(4) = 5d0/6
      s(5) = -1d0/4
      s(6) = 1d0/30

      end

      subroutine GETBOP4S2( bop, hnorm )
      implicit none
      real*8 bop(4,6), hnorm(4)
*** First derivative bop, 2nd order
      bop(1,1) = -24.D0/17.D0
      bop(1,2) = 59.D0/34.D0
      bop(1,3) = -4.D0/17.D0
      bop(1,4) = -3.D0/34.D0
      bop(1,5) = 0
      bop(1,6) = 0
      bop(2,1) = -1.D0/2.D0
      bop(2,2) = 0
      bop(2,3) = 1.D0/2.D0
      bop(2,4) = 0
      bop(2,5) = 0
      bop(2,6) = 0
      bop(3,1) = 4.D0/43.D0
      bop(3,2) = -59.D0/86.D0
      bop(3,3) = 0
      bop(3,4) = 59.D0/86.D0
      bop(3,5) = -4.D0/43.D0
      bop(3,6) = 0
      bop(4,1) = 3.D0/98.D0
      bop(4,2) = 0
      bop(4,3) = -59.D0/98.D0
      bop(4,4) = 0
      bop(4,5) = 32.D0/49.D0
      bop(4,6) = -4.D0/49.D0
      hnorm(1) = 17d0/48
      hnorm(2) = 59d0/48
      hnorm(3) = 43d0/48
      hnorm(4) = 49d0/48
      end

c-----------------------------------------------------------------------
      subroutine BOPEXT4TH( bop, bope )
      implicit none
      integer i, j
      real*8 bop(4,6), bope(6,8), d4a, d4b
      do j=1,8
         do i=1,6
            bope(i,j) = 0
         enddo
      enddo
      do j=1,6
         do i=1,4
            bope(i,j) = bop(i,j)
         enddo
      enddo
      d4a = 2d0/3
      d4b = -1d0/12
      bope(5,3) = -d4b
      bope(5,4) = -d4a
      bope(5,6) =  d4a
      bope(5,7) =  d4b
      bope(6,4) = -d4b
      bope(6,5) = -d4a
      bope(6,7) =  d4a
      bope(6,8) =  d4b
      end
c-----------------------------------------------------------------------
      subroutine VARCOEFFS4( acof, ghcof )
      implicit none
      real*8 acof(6,8,8), ghcof(6)
*** acofs(i,j,k) is coefficient of a(k) in stencil coefficient (i,j)
*** ghcof is coefficient of ghost point, a(1)*ghcof*u(0) in stencil at i=1.
      ghcof(1) = 12d0/17
      ghcof(2) = 0
      ghcof(3) = 0
      ghcof(4) = 0
      ghcof(5) = 0
      ghcof(6) = 0
      acof(1,1,1) = 104.D0/289.D0
      acof(1,1,2) = -2476335.D0/2435692.D0
      acof(1,1,3) = -16189.D0/84966.D0
      acof(1,1,4) = -9.D0/3332.D0
      acof(1,1,5) = 0
      acof(1,1,6) = 0
      acof(1,1,7) = 0
      acof(1,1,8) = 0
      acof(1,2,1) = -516.D0/289.D0
      acof(1,2,2) = 544521.D0/1217846.D0
      acof(1,2,3) = 2509879.D0/3653538.D0
      acof(1,2,4) = 0
      acof(1,2,5) = 0
      acof(1,2,6) = 0
      acof(1,2,7) = 0
      acof(1,2,8) = 0
      acof(1,3,1) = 312.D0/289.D0
      acof(1,3,2) = 1024279.D0/2435692.D0
      acof(1,3,3) = -687797.D0/1217846.D0
      acof(1,3,4) = 177.D0/3332.D0
      acof(1,3,5) = 0
      acof(1,3,6) = 0
      acof(1,3,7) = 0
      acof(1,3,8) = 0
      acof(1,4,1) = -104.D0/289.D0
      acof(1,4,2) = 181507.D0/1217846.D0
      acof(1,4,3) = 241309.D0/3653538.D0
      acof(1,4,4) = 0
      acof(1,4,5) = 0
      acof(1,4,6) = 0
      acof(1,4,7) = 0
      acof(1,4,8) = 0
      acof(1,5,1) = 0
      acof(1,5,2) = 0
      acof(1,5,3) = 5.D0/2193.D0
      acof(1,5,4) = -48.D0/833.D0
      acof(1,5,5) = 0
      acof(1,5,6) = 0
      acof(1,5,7) = 0
      acof(1,5,8) = 0
      acof(1,6,1) = 0
      acof(1,6,2) = 0
      acof(1,6,3) = 0
      acof(1,6,4) = 6.D0/833.D0
      acof(1,6,5) = 0
      acof(1,6,6) = 0
      acof(1,6,7) = 0
      acof(1,6,8) = 0
      acof(1,7,1) = 0
      acof(1,7,2) = 0
      acof(1,7,3) = 0
      acof(1,7,4) = 0
      acof(1,7,5) = 0
      acof(1,7,6) = 0
      acof(1,7,7) = 0
      acof(1,7,8) = 0
      acof(1,8,1) = 0
      acof(1,8,2) = 0
      acof(1,8,3) = 0
      acof(1,8,4) = 0
      acof(1,8,5) = 0
      acof(1,8,6) = 0
      acof(1,8,7) = 0
      acof(1,8,8) = 0
      acof(2,1,1) = 12.D0/17.D0
      acof(2,1,2) = 544521.D0/4226642.D0
      acof(2,1,3) = 2509879.D0/12679926.D0
      acof(2,1,4) = 0
      acof(2,1,5) = 0
      acof(2,1,6) = 0
      acof(2,1,7) = 0
      acof(2,1,8) = 0
      acof(2,2,1) = -59.D0/68.D0
      acof(2,2,2) = -1633563.D0/4226642.D0
      acof(2,2,3) = -21510077.D0/25359852.D0
      acof(2,2,4) = -12655.D0/372939.D0
      acof(2,2,5) = 0
      acof(2,2,6) = 0
      acof(2,2,7) = 0
      acof(2,2,8) = 0
      acof(2,3,1) = 2.D0/17.D0
      acof(2,3,2) = 1633563.D0/4226642.D0
      acof(2,3,3) = 2565299.D0/4226642.D0
      acof(2,3,4) = 40072.D0/372939.D0
      acof(2,3,5) = 0
      acof(2,3,6) = 0
      acof(2,3,7) = 0
      acof(2,3,8) = 0
      acof(2,4,1) = 3.D0/68.D0
      acof(2,4,2) = -544521.D0/4226642.D0
      acof(2,4,3) = 987685.D0/25359852.D0
      acof(2,4,4) = -14762.D0/124313.D0
      acof(2,4,5) = 0
      acof(2,4,6) = 0
      acof(2,4,7) = 0
      acof(2,4,8) = 0
      acof(2,5,1) = 0
      acof(2,5,2) = 0
      acof(2,5,3) = 1630.D0/372939.D0
      acof(2,5,4) = 18976.D0/372939.D0
      acof(2,5,5) = 0
      acof(2,5,6) = 0
      acof(2,5,7) = 0
      acof(2,5,8) = 0
      acof(2,6,1) = 0
      acof(2,6,2) = 0
      acof(2,6,3) = 0
      acof(2,6,4) = -1.D0/177.D0
      acof(2,6,5) = 0
      acof(2,6,6) = 0
      acof(2,6,7) = 0
      acof(2,6,8) = 0
      acof(2,7,1) = 0
      acof(2,7,2) = 0
      acof(2,7,3) = 0
      acof(2,7,4) = 0
      acof(2,7,5) = 0
      acof(2,7,6) = 0
      acof(2,7,7) = 0
      acof(2,7,8) = 0
      acof(2,8,1) = 0
      acof(2,8,2) = 0
      acof(2,8,3) = 0
      acof(2,8,4) = 0
      acof(2,8,5) = 0
      acof(2,8,6) = 0
      acof(2,8,7) = 0
      acof(2,8,8) = 0
      acof(3,1,1) = -96.D0/731.D0
      acof(3,1,2) = 1024279.D0/6160868.D0
      acof(3,1,3) = -687797.D0/3080434.D0
      acof(3,1,4) = 177.D0/8428.D0
      acof(3,1,5) = 0
      acof(3,1,6) = 0
      acof(3,1,7) = 0
      acof(3,1,8) = 0
      acof(3,2,1) = 118.D0/731.D0
      acof(3,2,2) = 1633563.D0/3080434.D0
      acof(3,2,3) = 2565299.D0/3080434.D0
      acof(3,2,4) = 40072.D0/271803.D0
      acof(3,2,5) = 0
      acof(3,2,6) = 0
      acof(3,2,7) = 0
      acof(3,2,8) = 0
      acof(3,3,1) = -16.D0/731.D0
      acof(3,3,2) = -5380447.D0/6160868.D0
      acof(3,3,3) = -3569115.D0/3080434.D0
      acof(3,3,4) = -331815.D0/362404.D0
      acof(3,3,5) = -283.D0/6321.D0
      acof(3,3,6) = 0
      acof(3,3,7) = 0
      acof(3,3,8) = 0
      acof(3,4,1) = -6.D0/731.D0
      acof(3,4,2) = 544521.D0/3080434.D0
      acof(3,4,3) = 2193521.D0/3080434.D0
      acof(3,4,4) = 8065.D0/12943.D0
      acof(3,4,5) = 381.D0/2107.D0
      acof(3,4,6) = 0
      acof(3,4,7) = 0
      acof(3,4,8) = 0
      acof(3,5,1) = 0
      acof(3,5,2) = 0
      acof(3,5,3) = -14762.D0/90601.D0
      acof(3,5,4) = 32555.D0/271803.D0
      acof(3,5,5) = -283.D0/2107.D0
      acof(3,5,6) = 0
      acof(3,5,7) = 0
      acof(3,5,8) = 0
      acof(3,6,1) = 0
      acof(3,6,2) = 0
      acof(3,6,3) = 0
      acof(3,6,4) = 9.D0/2107.D0
      acof(3,6,5) = -11.D0/6321.D0
      acof(3,6,6) = 0
      acof(3,6,7) = 0
      acof(3,6,8) = 0
      acof(3,7,1) = 0
      acof(3,7,2) = 0
      acof(3,7,3) = 0
      acof(3,7,4) = 0
      acof(3,7,5) = 0
      acof(3,7,6) = 0
      acof(3,7,7) = 0
      acof(3,7,8) = 0
      acof(3,8,1) = 0
      acof(3,8,2) = 0
      acof(3,8,3) = 0
      acof(3,8,4) = 0
      acof(3,8,5) = 0
      acof(3,8,6) = 0
      acof(3,8,7) = 0
      acof(3,8,8) = 0
      acof(4,1,1) = -36.D0/833.D0
      acof(4,1,2) = 181507.D0/3510262.D0
      acof(4,1,3) = 241309.D0/10530786.D0
      acof(4,1,4) = 0
      acof(4,1,5) = 0
      acof(4,1,6) = 0
      acof(4,1,7) = 0
      acof(4,1,8) = 0
      acof(4,2,1) = 177.D0/3332.D0
      acof(4,2,2) = -544521.D0/3510262.D0
      acof(4,2,3) = 987685.D0/21061572.D0
      acof(4,2,4) = -14762.D0/103243.D0
      acof(4,2,5) = 0
      acof(4,2,6) = 0
      acof(4,2,7) = 0
      acof(4,2,8) = 0
      acof(4,3,1) = -6.D0/833.D0
      acof(4,3,2) = 544521.D0/3510262.D0
      acof(4,3,3) = 2193521.D0/3510262.D0
      acof(4,3,4) = 8065.D0/14749.D0
      acof(4,3,5) = 381.D0/2401.D0
      acof(4,3,6) = 0
      acof(4,3,7) = 0
      acof(4,3,8) = 0
      acof(4,4,1) = -9.D0/3332.D0
      acof(4,4,2) = -181507.D0/3510262.D0
      acof(4,4,3) = -2647979.D0/3008796.D0
      acof(4,4,4) = -80793.D0/103243.D0
      acof(4,4,5) = -1927.D0/2401.D0
      acof(4,4,6) = -2.D0/49.D0
      acof(4,4,7) = 0
      acof(4,4,8) = 0
      acof(4,5,1) = 0
      acof(4,5,2) = 0
      acof(4,5,3) = 57418.D0/309729.D0
      acof(4,5,4) = 51269.D0/103243.D0
      acof(4,5,5) = 1143.D0/2401.D0
      acof(4,5,6) = 8.D0/49.D0
      acof(4,5,7) = 0
      acof(4,5,8) = 0
      acof(4,6,1) = 0
      acof(4,6,2) = 0
      acof(4,6,3) = 0
      acof(4,6,4) = -283.D0/2401.D0
      acof(4,6,5) = 403.D0/2401.D0
      acof(4,6,6) = -6.D0/49.D0
      acof(4,6,7) = 0
      acof(4,6,8) = 0
      acof(4,7,1) = 0
      acof(4,7,2) = 0
      acof(4,7,3) = 0
      acof(4,7,4) = 0
      acof(4,7,5) = 0
      acof(4,7,6) = 0
      acof(4,7,7) = 0
      acof(4,7,8) = 0
      acof(4,8,1) = 0
      acof(4,8,2) = 0
      acof(4,8,3) = 0
      acof(4,8,4) = 0
      acof(4,8,5) = 0
      acof(4,8,6) = 0
      acof(4,8,7) = 0
      acof(4,8,8) = 0
      acof(5,1,1) = 0
      acof(5,1,2) = 0
      acof(5,1,3) = 5.D0/6192.D0
      acof(5,1,4) = -1.D0/49.D0
      acof(5,1,5) = 0
      acof(5,1,6) = 0
      acof(5,1,7) = 0
      acof(5,1,8) = 0
      acof(5,2,1) = 0
      acof(5,2,2) = 0
      acof(5,2,3) = 815.D0/151704.D0
      acof(5,2,4) = 1186.D0/18963.D0
      acof(5,2,5) = 0
      acof(5,2,6) = 0
      acof(5,2,7) = 0
      acof(5,2,8) = 0
      acof(5,3,1) = 0
      acof(5,3,2) = 0
      acof(5,3,3) = -7381.D0/50568.D0
      acof(5,3,4) = 32555.D0/303408.D0
      acof(5,3,5) = -283.D0/2352.D0
      acof(5,3,6) = 0
      acof(5,3,7) = 0
      acof(5,3,8) = 0
      acof(5,4,1) = 0
      acof(5,4,2) = 0
      acof(5,4,3) = 28709.D0/151704.D0
      acof(5,4,4) = 51269.D0/101136.D0
      acof(5,4,5) = 381.D0/784.D0
      acof(5,4,6) = 1.D0/6.D0
      acof(5,4,7) = 0
      acof(5,4,8) = 0
      acof(5,5,1) = 0
      acof(5,5,2) = 0
      acof(5,5,3) = -349.D0/7056.D0
      acof(5,5,4) = -247951.D0/303408.D0
      acof(5,5,5) = -577.D0/784.D0
      acof(5,5,6) = -5.D0/6.D0
      acof(5,5,7) = -1.D0/24.D0
      acof(5,5,8) = 0
      acof(5,6,1) = 0
      acof(5,6,2) = 0
      acof(5,6,3) = 0
      acof(5,6,4) = 1135.D0/7056.D0
      acof(5,6,5) = 1165.D0/2352.D0
      acof(5,6,6) = 1.D0/2.D0
      acof(5,6,7) = 1.D0/6.D0
      acof(5,6,8) = 0
      acof(5,7,1) = 0
      acof(5,7,2) = 0
      acof(5,7,3) = 0
      acof(5,7,4) = 0
      acof(5,7,5) = -1.D0/8.D0
      acof(5,7,6) = 1.D0/6.D0
      acof(5,7,7) = -1.D0/8.D0
      acof(5,7,8) = 0
      acof(5,8,1) = 0
      acof(5,8,2) = 0
      acof(5,8,3) = 0
      acof(5,8,4) = 0
      acof(5,8,5) = 0
      acof(5,8,6) = 0
      acof(5,8,7) = 0
      acof(5,8,8) = 0
      acof(6,1,1) = 0
      acof(6,1,2) = 0
      acof(6,1,3) = 0
      acof(6,1,4) = 1.D0/392.D0
      acof(6,1,5) = 0
      acof(6,1,6) = 0
      acof(6,1,7) = 0
      acof(6,1,8) = 0
      acof(6,2,1) = 0
      acof(6,2,2) = 0
      acof(6,2,3) = 0
      acof(6,2,4) = -1.D0/144.D0
      acof(6,2,5) = 0
      acof(6,2,6) = 0
      acof(6,2,7) = 0
      acof(6,2,8) = 0
      acof(6,3,1) = 0
      acof(6,3,2) = 0
      acof(6,3,3) = 0
      acof(6,3,4) = 3.D0/784.D0
      acof(6,3,5) = -11.D0/7056.D0
      acof(6,3,6) = 0
      acof(6,3,7) = 0
      acof(6,3,8) = 0
      acof(6,4,1) = 0
      acof(6,4,2) = 0
      acof(6,4,3) = 0
      acof(6,4,4) = -283.D0/2352.D0
      acof(6,4,5) = 403.D0/2352.D0
      acof(6,4,6) = -1.D0/8.D0
      acof(6,4,7) = 0
      acof(6,4,8) = 0
      acof(6,5,1) = 0
      acof(6,5,2) = 0
      acof(6,5,3) = 0
      acof(6,5,4) = 1135.D0/7056.D0
      acof(6,5,5) = 1165.D0/2352.D0
      acof(6,5,6) = 1.D0/2.D0
      acof(6,5,7) = 1.D0/6.D0
      acof(6,5,8) = 0
      acof(6,6,1) = 0
      acof(6,6,2) = 0
      acof(6,6,3) = 0
      acof(6,6,4) = -47.D0/1176.D0
      acof(6,6,5) = -5869.D0/7056.D0
      acof(6,6,6) = -3.D0/4.D0
      acof(6,6,7) = -5.D0/6.D0
      acof(6,6,8) = -1.D0/24.D0
      acof(6,7,1) = 0
      acof(6,7,2) = 0
      acof(6,7,3) = 0
      acof(6,7,4) = 0
      acof(6,7,5) = 1.D0/6.D0
      acof(6,7,6) = 1.D0/2.D0
      acof(6,7,7) = 1.D0/2.D0
      acof(6,7,8) = 1.D0/6.D0
      acof(6,8,1) = 0
      acof(6,8,2) = 0
      acof(6,8,3) = 0
      acof(6,8,4) = 0
      acof(6,8,5) = 0
      acof(6,8,6) = -1.D0/8.D0
      acof(6,8,7) = 1.D0/6.D0
      acof(6,8,8) = -1.D0/8.D0
*** 129 non-zero out of 384.
      end


MODULE support

  IMPLICIT NONE

  !Use SELECTED_REAL_KIND to get a kind value for a double precision number
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15, 307)
  INTEGER, PARAMETER :: its = 10000000

  CONTAINS

  SUBROUTINE seed_rng
    INTEGER :: rand_size, time
    INTEGER, DIMENSION(:), ALLOCATABLE :: seed

    !Fortran RNG seeding is a bit strange. This works
    CALL RANDOM_SEED(size=rand_size)
    ALLOCATE(seed(1:rand_size))
    CALL SYSTEM_CLOCK(time)
    seed = time
    CALL RANDOM_SEED(put=seed)
    DEALLOCATE(seed)
  END SUBROUTINE seed_rng

  FUNCTION get_random_in_range() RESULT(rnum)

    REAL(dp) :: rnum

    CALL RANDOM_NUMBER(rnum)
    rnum = rnum * 2.0_dp - 1.0_dp
  END FUNCTION get_random_in_range

END MODULE support

PROGRAM main
  USE support

  INTEGER :: count = 0, index
  REAL(dp) :: d1, d2

  CALL seed_rng
  DO index = 0, its - 1
    ! random numbers between ±1
    d1=get_random_in_range()
    d2=get_random_in_range()
    if (d1*d1 + d2*d2 <= 1) count = count + 1
  END DO

  PRINT *, count, its
END PROGRAM main


      SUBROUTINE NMONAP( XSQUAR, DELA, SI, NSAMPS, IV2AD, IANS, itype,
     &    ans )
C     NMONAP computes time shifts like nmo.  It does NOT applied the shifts.
c  Actually, this computes the an array of indices pointing to the input
c  array.
C  FAST NMO IS TX=X**2/2*V**2*T0 + T0
C  SLOW BUT ACCURATE NMO IS TX=SQRT(T0**2+X**2/V**2)
C  *** NOTE ***  THIS ROUTINE DOES NOT USE THE AP.
C  (NMO IS REALLY TX-T0, SO NMONAP IS NOT REALLY NMO)
C
C  ARGUMENTS:
C    XSQUAR - THE SQUARE OF THE RANGE (SHOT RECEIVER DISTANCE)
C    DELA   - THE FIRST T0 VALUE NEEDED.  THE DEEP WATER DELAY.
C    SI     - THE SAMPLE INTERVAL IN SECONDS.
C    NSAMPS - THE NUMBER OF TX VALUES TO COMPUTE. IANS MUST BE NSAMPS LONG.
C    IV2AD  - THE AP SIMULATOR ADDRESS OF THE SQUARE OF THE VELOCITIES.  EVERY
C             TIME SAMPLE MUST HAVE A VELOCITY. I.E. THERE MUST BE NSAMPS
C             VELOCITIES.  THE VELOCITY AT IV2AD MUST BE ASSOCIATED WITH TIME
C             DELAY, AT IV2AD+1 THE V FOR DELAY+SI, ETC.
C    IANS   - AN ARRAY TO RECEIVE THE INDEXES POINTING TO THE DATA ARRAY TX.
c    itype = 1 means NMO (tx=sqrt(t0**2 + x**2/v**2))
c          = 2 means DENMO or movein (t0 = sqrt(tx**2-x**2/v**2))
c          = 3 means SMO (Slant Move Out (t0 = tx - x/v))
c    ans - The array of TXs, the type real time TX time.
C
C  COPYRIGHTED BY PAUL HENKART, SEISMIC REFLECTION PROCESSORS, SAN DIEGO, 12 JAN 1983
C
c   mod 2 Mar 98 - change move in to use t0 velocities rather than tx.
c   mod 25 Jul 01 - movein with t0 bombed when the t0 data was before
c                   the delay.  i.e. delays were not handled quite right.
c   mod 17 Jul 02 - Add returning of the TX array
C
      COMMON /APMEM/A(32767)
      DIMENSION IANS(1), ans(1)
C
      DELAY = DELA
      CONST = SI/2.-DELAY
      IV = IV2AD-1
      X2 = XSQUAR                                                       ! It is faster not to have ARGUMENTS IN LOOPS (INDIRECT ADDRESSING)
      T0=DELAY-SI
      IF( itype .EQ. 1 ) THEN
C****
C****  SLOW NMO HERE
C****
          DO 100 I=1,NSAMPS
             T=T0+SI*FLOAT(I)                                           ! ADDING SI LEADS TO ROUND OFF ERRORS
             TEMP=SQRT(T*T+X2/A(IV+I))
             ans(i) = temp
             IANS(I)=IFIX((TEMP+CONST)/SI)+1                            ! ADD SI/2 TO ROUND OFF SAMPLE INTERVAL
  100     CONTINUE
      ELSEIF( itype .EQ. 2 ) THEN
c****
c****   Move In
c****   The trick here is that each output sample is a tx sample, but
c****   the velocities were given for t0, so find out what the moveout
c****   is, then subtract the move out from time of the velocity in
c****   order to find the velocity for the tx time.
c****
          DO 200 i = 1, nsamps
             t = t0 + si * FLOAT(i)
             temp =  t*t - x2 / a(iv+i)
c	 print *,' i=',i,' iv=',iv,' a()=',a(iv+i),' si=',si,' t=',t,
c     &   ' temp=',temp
             IF( temp .LE. 0. ) THEN
                 temp = t
             ELSE
                 temp = SQRT(temp)
             ENDIF
c             itemp = (t-temp-t0) / si
             itemp = NINT((t-temp) / si)
             IF( itemp .GE. i ) itemp = i-1
             jtemp = i-itemp
c             IF( jtemp .LT. 0 .OR. jtemp .GT. nsamps .OR.
c     &           a(iv+jtemp) .LE. 0 ) THEN
c	 print *,' i=',i,' it=',itemp,' t=',t,' temp=',temp,a(iv+i-itemp)
c                 STOP
c             ENDIF
             temp = t*t - x2 / a(iv+i-itemp)
             IF( temp .GT. 0 ) THEN
                 temp = SQRT(temp)
             ELSE
                 temp = 0.
             ENDIF
             ians(i) = IFIX((temp+const)/si) + 1
c**** The T0 data may be before the start of data, so use the first sample
             IF( ians(i) .LT. 1 ) ians(i) = 1
c	 	print *,' i=',i,' ians=',ians(i),' temp=',temp
c		print *,' temp=',temp,' const=',const,' a=',a(iv+i-itemp),
c     &     ' t=',t,' x2=',x2,' itemp=',itemp
  200     CONTINUE
      ELSEIF( itype .EQ. 3 ) THEN
c****
c****     Slant Move Out
          x = SQRT( x2 )
          DO 300 i = 1, nsamps
             t = t0 + si * FLOAT(i)
             temp = t + SQRT(x2/a(iv+i))
             ians(i) = IFIX((temp+const)/si) + 1
  300     CONTINUE
      ENDIF
      RETURN
      END