*DECK DIR
      SUBROUTINE DIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ,
     $     RWORK, IWORK)
C***BEGIN PROLOGUE  DIR
C***DATE WRITTEN   890404   (YYMMDD)
C***REVISION DATE  890404   (YYMMDD)
C***CATEGORY NO.  D2A4, D2B4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(DIR-D),
C             Linear system, Sparse, Iterative Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Preconditioned Iterative Refinement sparse Ax = b solver.
C            Routine to solve a general linear system  Ax = b  using
C            iterative refinement with a matrix splitting.
C***DESCRIPTION
C *Usage:
C     INTEGER  N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER  ITER, IERR, IUNIT, IWORK(USER DEFINABLE)
C     DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), DZ(N)
C     DOUBLE PRECISION RWORK(USER DEFINABLE)
C     EXTERNAL MATVEC, MSOLVE
C
C     CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSLOVE, ITOL,
C    $     TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK)
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Integer A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "Description", below
C         for more late breaking details...
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which performs the matrix vector multiply
C         Y = A*X given A and X.  The name of the MATVEC routine must
C         be declared external in the calling program.  The calling
C         sequence to MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X
C         upon return, X is an input vector, NELT is the number of
C         non-zeros in the SLAP IA, JA, A storage for the matrix A.
C         ISYM is a flag which, if non-zero, denotes that A is
C         symmetric and only the lower or upper triangle is stored.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R for
C         Z given R with the preconditioning matrix M (M is supplied via
C         RWORK and IWORK arrays).  The name of the MSOLVE routine must
C         be declared external in the calling program.  The calling
C         sequence to MSOLVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is the right-hand side
C         vector, and Z is the solution upon return.  IA, JA, A and
C         ISYM are defined as above.  RWORK is a double precision array
C         that can be used to pass necessary preconditioning information
C         and/or workspace to MSOLVE.  IWORK is an integer work array
C         for the same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :WORK     Double Precision R(N).
C Z      :WORK     Double Precision Z(N).
C DZ     :WORK     Double Precision DZ(N).
C RWORK  :WORK     Double Precision RWORK(USER DEFINABLE).
C         Double Precision array that can be used by  MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINABLE).
C         Integer array that can be used by  MSOLVE.
C
C *Description:
C       The basic algorithm for iterative refinement (also known as
C       iterative improvement) is:
C
C            n+1    n    -1       n
C           X    = X  + M  (B - AX  ).
C
C           -1   -1
C       If M =  A then   this is  the standard iterative  refinement
C       algorithm and the "subtraction" in  the residual calculation
C       should be done in double precision (which it is  not in this
C       routine).  If M = DIAG(A), the diagonal of A, then iterative
C       refinement is known  as Jacobi's  method.   The SLAP routine
C       DSJAC  implements this iterative strategy.   If  M = L,  the
C       lower  triangle of A,  then iterative refinement is known as
C       Gauss-Seidel.   The    SLAP  routine  DSGS  implements  this
C       iterative strategy.
C
C       This routine does  not care  what matrix data   structure is
C       used for  A and M.  It simply   calls  the MATVEC and MSOLVE
C       routines, with  the arguments as  described above.  The user
C       could write any type of structure and the appropriate MATVEC
C       and MSOLVE routines.  It is assumed  that A is stored in the
C       IA, JA, A  arrays in some fashion and  that M (or INV(M)) is
C       stored  in  IWORK  and  RWORK)  in  some fashion.   The SLAP
C       routines DSJAC and DSGS are examples of this procedure.
C
C       Two  examples  of  matrix  data structures  are the: 1) SLAP
C       Triad  format and 2) SLAP Column format.
C
C       =================== S L A P Triad format ===================
C
C       In  this   format only the  non-zeros are  stored.  They may
C       appear  in *ANY* order.   The user  supplies three arrays of
C       length NELT, where  NELT  is the number  of non-zeros in the
C       matrix:  (IA(NELT), JA(NELT),  A(NELT)).  For each  non-zero
C       the  user puts   the row  and  column index   of that matrix
C       element in the IA and JA arrays.  The  value of the non-zero
C       matrix  element is  placed in  the corresponding location of
C       the A  array.  This is  an extremely easy data  structure to
C       generate.  On  the other hand it  is  not too  efficient  on
C       vector  computers   for the  iterative  solution  of  linear
C       systems.  Hence, SLAP  changes this input  data structure to
C       the SLAP   Column  format for the  iteration (but   does not
C       change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Examples:
C       See the SLAP routines DSJAC, DSGS
C
C *Precision:           Double Precision
C *See Also:
C       DSJAC, DSGS
C***REFERENCES  1. Gene Golub \& Charles Van Loan, "Matrix
C                 Computations", John Hopkins University Press; 3
C                 (1983) IBSN 0-8018-3010-9.
C***ROUTINES CALLED  MATVEC, MSOLVE, ISDIR.
C***END PROLOGUE  DIR
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM
      INTEGER ITOL, ITMAX, ITER, IERR, IUNIT, IWORK(*)
      DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N)
      DOUBLE PRECISION DZ(N), RWORK(*)
      EXTERNAL MSOLVE, MATVEC, ISDIR
C
C         Check some of the input data.
C***FIRST EXECUTABLE STATEMENT  DIR
      ITER = 0
      IERR = 0
      IF( N.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      TOLMIN = 500.0*D1MACH(3)
      IF( TOL.LT.TOLMIN ) THEN
         TOL = TOLMIN
         IERR = 4
      ENDIF
C
C         Calculate initial residual and pseudo-residual, and check
C         stopping criterion.
      CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM)
      DO 10 I = 1, N
         R(I) = B(I) - R(I)
 10   CONTINUE
      CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
      IF( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK,
     $     IWORK, BNRM, SOLNRM) .NE. 0 ) GO TO 200
      IF( IERR.NE.0 ) RETURN
C
C         ***** iteration loop *****
C
      DO 100 K=1,ITMAX
         ITER = K
C
C         Calculate new iterate x, new residual r, and new
C         pseudo-resid z.
         DO 20 I = 1, N
            X(I) = X(I) + Z(I)
 20      CONTINUE
         CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM)
         DO 30 I = 1, N
            R(I) = B(I) - R(I)
 30      CONTINUE
         CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C
C         check stopping criterion.
         IF( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL,
     $        ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK,
     $        IWORK, BNRM, SOLNRM) .NE. 0 ) GO TO 200
C
 100  CONTINUE
C
C         *****   end of loop  *****
C         Stopping criterion not satisfied.
      ITER = ITMAX + 1
      IERR = 2
C
 200  RETURN
C------------- LAST LINE OF DIR FOLLOWS -------------------------------
      END
*DECK DSJAC
      SUBROUTINE DSJAC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  DSJAC
C***DATE WRITTEN   890404   (YYMMDD)
C***REVISION DATE  890404   (YYMMDD)
C***CATEGORY NO.  D2A4, D2B4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(DSJAC-D),
C             Linear system, Sparse, Iterative Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Jacobi's method iterative sparse Ax = b solver.
C            Routine to solve a general linear system  Ax = b  using
C            Jacobi iteration.
C***DESCRIPTION
C *Usage:
C     INTEGER  N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER  ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW
C     DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW)
C
C     CALL DSJAC(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Integer A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Double Precision RWORK(LENW).
C         Double Precision array used for workspace.
C LENW   :IN       Integer.
C         Length of the double precision workspace, RWORK.  LENW >= 4*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Used to hold pointers into the double precision workspace,
C         RWORK. Upon return the following locations of IWORK hold
C         information which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Double Precision workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.  LENIW >= 10.
C
C *Description:
C       Jacobi's method solves the linear system Ax=b with the
C       basic iterative method (where A = L + D + U):
C
C            n+1    -1       n    n
C           X    = D  (B - LX - UX )
C
C                   n    -1       n
C                = X  + D  (B - AX )
C
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out which one
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Double Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA, A) is modified internally to be
C       the SLAP Column format.  See above.
C
C *See Also:
C       DSGS, DIR
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DS2Y, DDCHKW, DSDS, DIR, DSMV, DSDI
C***END PROLOGUE  DSJAC
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
      INTEGER ITER, IUNIT, LENW, IWORK(LENIW), LENIW
      DOUBLE PRECISION B(N), X(N), A(NELT), RWORK(LENW)
      EXTERNAL DSMV, DSDI
      PARAMETER(LOCRB=1,LOCIB=11)
C
C         Compute the inverse of the diagonal of the matrix.  This
C         will be used as the precontioner.
C***FIRST EXECUTABLE STATEMENT  DSJAC
      IERR = 0
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      LOCIW = LOCIB
      LOCD = LOCRB
      LOCR = LOCD + N
      LOCZ = LOCR + N
      LOCDZ = LOCZ + N
      LOCW = LOCDZ + N
C
C         Check the workspace allocations.
      CALL DCHKW( 'DSJAC', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(4) = LOCD
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
      CALL DS2Y(N, NELT, IA, JA, A, ISYM )
      CALL DSDS(N, NELT, IA, JA, A, ISYM, RWORK(LOCD))
C
C         Set up the work array and perform the iterative refinement.
      CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSDI, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR), RWORK(LOCZ),
     $     RWORK(LOCDZ), RWORK, IWORK )
      RETURN
C------------- LAST LINE OF DSJAC FOLLOWS -----------------------------
      END
*DECK DSGS
      SUBROUTINE DSGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  DSGS
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  881213   (YYMMDD)
C***CATEGORY NO.  D2A4, D2B4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(DSGS-S),
C             Linear system, Sparse, Iterative Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Gauss-Seidel method iterative sparse Ax = b solver.
C            Routine to solve a general linear system  Ax = b  using
C            Gauss-Seidel iteration.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER ITER, IERR, IUNIT, LENW, IWORK(NEL+2*N+1), LENIW
C     DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NEL+3*N)
C
C     CALL DSGS(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Integer A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the lower
C         lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Double Precision RWORK(LENW).
C         Double Precision array used for workspace.  NEL is the number
C         of non-zeros in the lower triangle of the matrix (including
C         the diagonal).
C LENW   :IN       Integer.
C         Length of the double precision workspace, RWORK.
C         LENW >= NEL+3*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Integer array used for workspace.  NEL is the number of non-
C         zeros in the lower triangle of the matrix (including the
C         diagonal).
C         Upon return the following locations of IWORK hold information
C         which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Double Precision workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.  LENIW >=
C         NEL+N+11.
C
C *Description
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out  which on
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Double Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA, A) is modified internally to be
C       the SLAP Column format.  See above.
C
C *See Also:
C       DSJAC, DIR
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DS2Y, DCHKW, DS2LT, SDIR, DSMV, DSLI
C***END PROLOGUE  DSGS
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
      INTEGER ITER, IUNIT, IWORK(10)
      DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, RWORK(1)
      EXTERNAL DSMV, DSLI
      PARAMETER(LOCRB=1,LOCIB=11)
C
C         Modify the SLAP matrix data structure to YSMP-Column.
C***FIRST EXECUTABLE STATEMENT  DSGS
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      CALL DS2Y( N, NELT, IA, JA, A, ISYM )
C
C         Count number of elements in lower triangle of the matrix.
      IF( ISYM.EQ.0 ) THEN
         NEL = 0
         DO 20 ICOL = 1, N
            JBGN = JA(ICOL)
            JEND = JA(ICOL+1)-1
            DO 10 J = JBGN, JEND
               IF( IA(J).GE.ICOL ) NEL = NEL + 1
 10         CONTINUE
 20      CONTINUE
      ELSE
         NEL = JA(N+1)-1
      ENDIF
C
C         Set up the work arrays.  Then store the lower triangle of
C         the matrix.
C
      LOCJEL = LOCIB
      LOCIEL = LOCJEL + N+1
      LOCIW = LOCIEL + NEL
C
      LOCEL = LOCRB
      LOCR = LOCEL + NEL
      LOCZ = LOCR + N
      LOCDZ = LOCZ + N
      LOCW = LOCDZ + N
C
C         Check the workspace allocations.
      CALL DCHKW( 'DSGS', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(1) = NEL
      IWORK(2) = LOCIEL
      IWORK(3) = LOCJEL
      IWORK(4) = LOCEL
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
      CALL DS2LT( N, NELT, IA, JA, A, ISYM, NEL, IWORK(LOCIEL),
     $     IWORK(LOCJEL), RWORK(LOCEL) )
C
C         Call iterative refinement routine.
      CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLI,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR),
     $     RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK )
C
C         Set the amount of Integer and Double Precision Workspace used.
      IWORK(9) = LOCIW+N+NELT
      IWORK(10) = LOCW+NELT
      RETURN
C------------- LAST LINE OF DSGS FOLLOWS ------------------------------
      END
*DECK DSILUR
      SUBROUTINE DSILUR(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  DSILUR
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  881213   (YYMMDD)
C***CATEGORY NO.  D2A4, D2B4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(DSILUR-S),
C             Linear system, Sparse, Iterative Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Incomplete LU Iterative Refinement sparse Ax = b solver.
C            Routine to solve a general linear system  Ax = b  using
C            the incomplete LU decomposition with iterative refinement.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER ITER, IERR, IUNIT, LENW, IWORK(NEL+NU+4*N+2), LENIW
C     DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(NEL+NU+4*N)
C
C     CALL DSILUR(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW)
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :INOUT    Double Precision X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Integer A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*D1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C           IERR = 7 => Incomplete factorization broke down
C                       and was fudged.  Resulting preconditioning may
C                       be less than the best.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Double Precision RWORK(LENW).
C         Double Precision array used for workspace.  NEL is the number
C         of non-zeros in the lower triangle of the matrix (including
C         the diagonal).  NU is the number of nonzeros in the upper
C         triangle of the matrix (including the diagonal).
C LENW   :IN       Integer.
C         Length of the double precision workspace, RWORK.
C         LENW >= NEL+NU+4*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Integer array used for workspace.  NEL is the number of non-
C         zeros in the lower triangle of the matrix (including the
C         diagonal).  NU is the number of nonzeros in the upper
C         triangle of the matrix (including the diagonal).
C         Upon return the following locations of IWORK hold information
C         which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Double Precision workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.  LENIW >=
C         NEL+NU+4*N+10.
C
C *Description
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out  which on
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C       This routine requires  that the  matrix  A be  stored in the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except for  the diagonal entry, which
C       must appear first in each  "column")  and are stored  in the
C       double precision array A.   In other words,  for each column
C       in the matrix put the diagonal entry in  A.  Then put in the
C       other non-zero  elements going down  the column (except  the
C       diagonal) in order.   The  IA array holds the  row index for
C       each non-zero.  The JA array holds the offsets  into the IA,
C       A arrays  for  the  beginning  of each   column.   That  is,
C       IA(JA(ICOL)),  A(JA(ICOL)) points   to the beginning  of the
C       ICOL-th   column    in    IA and   A.      IA(JA(ICOL+1)-1),
C       A(JA(ICOL+1)-1) points to  the  end of the   ICOL-th column.
C       Note that we always have  JA(N+1) = NELT+1,  where N is  the
C       number of columns in  the matrix and NELT  is the number  of
C       non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C       5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C       1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Double Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA, A) is modified internally to be
C       the SLAP Column format.  See above.
C
C *Portability:
C       DSJAC, DSGS, DIR
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DS2Y, DCHKW, DSILUS, DIR, DSMV, DSLUI
C***END PROLOGUE  DSILUR
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IERR, IUNIT, LENW, IWORK(LENIW), LENIW
      DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW)
      PARAMETER (LOCRB=1, LOCIB=11)
C
      EXTERNAL DSMV, DSLUI
C
C         Change the SLAP input matrix IA, JA, A to SLAP-Column format.
C***FIRST EXECUTABLE STATEMENT  DSILUR
      IERR = 0
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      CALL DS2Y( N, NELT, IA, JA, A, ISYM )
C
C         Count number of Non-Zero elements in preconditioner ILU
C         matrix.  Then set up the work arrays.
      NL = 0
      NU = 0
      DO 20 ICOL = 1, N
C         Don't count diagonal.
         JBGN = JA(ICOL)+1
         JEND = JA(ICOL+1)-1
         IF( JBGN.LE.JEND ) THEN
CVD$ NOVECTOR
            DO 10 J = JBGN, JEND
               IF( IA(J).GT.ICOL ) THEN
                  NL = NL + 1
                  IF( ISYM.NE.0 ) NU = NU + 1
               ELSE
                  NU = NU + 1
               ENDIF
 10         CONTINUE
         ENDIF
 20   CONTINUE
C
      LOCIL = LOCIB
      LOCJL = LOCIL + N+1
      LOCIU = LOCJL + NL
      LOCJU = LOCIU + NU
      LOCNR = LOCJU + N+1
      LOCNC = LOCNR + N
      LOCIW = LOCNC + N
C
      LOCL = LOCRB
      LOCDIN = LOCL + NL
      LOCU = LOCDIN + N
      LOCR = LOCU + NU
      LOCZ = LOCR + N
      LOCDZ = LOCZ + N
      LOCW = LOCDZ + N
C
C         Check the workspace allocations.
      CALL DCHKW( 'DSILUR', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(1) = LOCIL
      IWORK(2) = LOCJL
      IWORK(3) = LOCIU
      IWORK(4) = LOCJU
      IWORK(5) = LOCL
      IWORK(6) = LOCDIN
      IWORK(7) = LOCU
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
C         Compute the Incomplete LU decomposition.
      CALL DSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL),
     $     IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU),
     $     IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) )
C
C         Do the Preconditioned Iterative Refinement iteration.
      CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, DSMV, DSLUI,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR),
     $     RWORK(LOCZ), RWORK(LOCDZ), RWORK, IWORK)
      RETURN
C------------- LAST LINE OF DSILUR FOLLOWS ----------------------------
      END
*DECK ISDIR
      FUNCTION ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK,
     $     BNRM, SOLNRM)
C***BEGIN PROLOGUE  ISDIR
C***REFER TO  DIR, DSJAC, DSGS
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  880320   (YYMMDD)
C***CATEGORY NO.  D2A4, D2B4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=DOUBLE PRECISION(ISDIR-S),
C             Linear system, Sparse, Stop Test
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Preconditioned Iterative Refinement Stop Test.
C            This routine calculates the stop test for the iterative
C            refinement iteration scheme.  It returns a nonzero if the
C            error estimate (the type of which is determined by ITOL)
C            is less than the user specified tolerance TOL.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
C     INTEGER IERR, IUNIT, IWORK(USER DEFINED)
C     DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), DZ(N)
C     DOUBLE PRECISION RWORK(USER DEFINED), BNRM, SOLNRM
C     EXTERNAL MSOLVE
C
C     IF( ISDIR(N, B, X, NELT, IA, JA, A, ISYM, MSOLVE, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK,
C    $     BNRM, SOLNRM) .NE. 0 ) THEN ITERATION DONE
C
C *Arguments:
C N      :IN       Integer.
C         Order of the Matrix.
C B      :IN       Double Precision B(N).
C         Right-hand side vector.
C X      :IN       Double Precision X(N).
C         The current approximate solution vector.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Double Precision A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "C *Description" in the
C         DIR routine.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system Mz = r for
C         z given r with the preconditioning matrix M (M is supplied via
C         RWORK and IWORK arrays.  The name of the MSOLVE routine must
C         be declared external in the calling program.  The calling
C         sequence to MSOLVE is:
C             CALL MSOLVE(N, R, Z, RWORK, IWORK)
C         Where N is the number of unknowns, R is the right-hand side
C         vector, and z is the solution upon return.  RWORK is a double
C         precision array that can be used to pass necessary
C         preconditioning information and/or workspace to MSOLVE.
C         IWORK is an integer work array for the same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Double Precision.
C         Convergence criterion, as described above.
C ITER   :IN       Integer.
C         Current iteration count.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ERR    :OUT      Double Precision.
C         Error estimate of error in the X(N) approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Error flag.  IERR is set to 3 if ITOL is not on of the
C         acceptable values, see above.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :IN       Double Precision R(N).
C         The residual R = B-AX.
C Z      :WORK     Double Precision Z(N).
C         Workspace used to hold the pseudo-residual M z = r.
C DZ     :WORK     Double Precision DZ(N).
C         Workspace used to hold temporary vector(s).
C RWORK  :WORK     Double Precision RWORK(USER DEFINABLE).
C         Double Precision array that can be used by  MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINABLE).
C         Integer array that can be used by MSOLVE.
C BNRM   :INOUT    Double Precision.
C         Norm of the right hand side.  Type of norm depends on ITOL.
C         Calculated only on the first call.
C SOLNRM :INOUT    Double Precision.
C         2-Norm of the true solution, SOLN.  Only computed and used
C         if ITOL = 11.
C
C *Function Return Values:
C       0 : Error estimate (determined by ITOL) is *NOT* less than the
C           specified tolerance, TOL.  The iteration must continue.
C       1 : Error estimate (determined by ITOL) is less than the
C           specified tolerance, TOL.  The iteration can be considered
C           complete.
C
C *Precision:           Double Precision
C *See Also:
C       DIR, DSJAC, DSGS
C
C *Cautions:
C     This routine will attempt to write to the fortran logical output
C     unit IUNIT, if IUNIT .ne. 0.  Thus, the user must make sure that
C     this  logical  unit  must  be  attached  to  a  file or terminal
C     before calling this routine with a non-zero  value  for   IUNIT.
C     This routine does not check for the validity of a non-zero IUNIT
C     unit number.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  MSOLVE, DNRM2
C***COMMON BLOCKS    SOLBLK
C***END PROLOGUE  ISDIR
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IUNIT, IWORK(*)
      DOUBLE PRECISION B(N), X(N), A(NELT), R(N), Z(N), DZ(N), RWORK(*)
      EXTERNAL MSOLVE
      COMMON /SOLBLK/ SOLN(1)
C
C***FIRST EXECUTABLE STATEMENT  ISDIR
      ISDIR = 0
      IF( ITOL.EQ.1 ) THEN
C         err = ||Residual||/||RightHandSide|| (2-Norms).
         IF(ITER .EQ. 0) BNRM = DNRM2(N, B, 1)
         ERR = DNRM2(N, R, 1)/BNRM
      ELSE IF( ITOL.EQ.2 ) THEN
C                  -1              -1
C         err = ||M  Residual||/||M  RightHandSide|| (2-Norms).
         IF(ITER .EQ. 0) THEN
            CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK)
            BNRM = DNRM2(N, DZ, 1)
         ENDIF
         ERR = DNRM2(N, Z, 1)/BNRM
      ELSE IF( ITOL.EQ.11 ) THEN
C         err = ||x-TrueSolution||/||TrueSolution|| (2-Norms).
         IF( ITER.EQ.0 ) SOLNRM = DNRM2(N, SOLN, 1)
         DO 10 I = 1, N
            DZ(I) = X(I) - SOLN(I)
 10      CONTINUE
         ERR = DNRM2(N, DZ, 1)/SOLNRM
      ELSE
C
C         If we get here ITOL is not one of the acceptable values.
         ERR = 1.0E10
         IERR = 3
      ENDIF
C
      IF( IUNIT.NE.0 ) THEN
         WRITE(IUNIT,1000) ITER,ERR
      ENDIF
C
      IF( ERR.LE.TOL ) ISDIR = 1
C
      RETURN
 1000 FORMAT(5X,'ITER = ',I4,' Error Estimate = ',E16.7)
C------------- LAST LINE OF ISDIR FOLLOWS -----------------------------
      END


C++***************************************************************
C spec_wavecal
C Program to perform wavelength calibration of a spectrum.
C Fits a polynomial to the dispersion relation,
C and then compute the wavelengths from the pixel values.
C Input spectrum: image file
C       with flux in line #1, wavelengths/pixels in line #2
C
C Version of 21-12-98
C--**************************************************************
	PROGRAM SPEC_WAVECAL
        PARAMETER(MAX_NWAVE0=200,MAX_NLINES=100)
	CHARACTER IN_NAME*40,IN_COMMENTS*80,WAVE0_NAME(MAX_NWAVE0)*20
	CHARACTER OUT_NAME*40,OUT_COMMENTS*80
	CHARACTER CALIB_FILE*40,PLOTDEV*32,ANS*1
        INTEGER*4 ISTAT,NWAVE0,NLINES
	INTEGER*4 MADRID(1),PNTR_1,NX,NY
	INTEGER*4 PNTR_2,KK,IEMISSION
	REAL*8 XC(20),SDEV(20)
        REAL*4 WAVE0(MAX_NWAVE0)
        REAL*8 XX(MAX_NLINES),YY(MAX_NLINES)
	COMMON /VMR/MADRID

	CALL JLP_BEGIN
10	FORMAT(A)

	WRITE(6,22)
22      FORMAT(' Program spec_wavecal        JLP-Version of 21-12-98',/,
     1    ' to perform wavelength calibration of a spectrum')
        OPEN(UNIT=1,FILE='spec_wavecal.log',STATUS='UNKNOWN')
        WRITE(1,22)

C Inquires about the format of the files :
	CALL JLP_INQUIFMT

	WRITE(6,23)
23      FORMAT(' Graphic device? (for interactive plot)')
	READ(5,10) PLOTDEV

	WRITE(6,24)
24      FORMAT(' Input ASCII catalog with calibration lines?  (Format is',/,
     1      ' wavelength in column.#1, intensity in #2, name in #3)')
	READ(5,10) CALIB_FILE

C NWAVE0: in input, maximum size of WAVE0, in output, actual size of WAVE0
        NWAVE0=MAX_NWAVE0
        CALL READ_CALIB(CALIB_FILE,WAVE0,WAVE0_NAME,NWAVE0,ISTAT)
        IF(ISTAT.NE.0)THEN
           WRITE(6,35) CALIB_FILE
35         FORMAT(' Fatal error in READ_CALIB opening/reading calibration',
     1         ' file:',A)
           GOTO 999
        ENDIF

C************************************************************
C Loading input image file
C************************************************************
	WRITE(6,*) ' Input spectrum (image file) ?'
	READ(5,10) IN_NAME
	CALL JLP_VM_READIMAG(PNTR_1,NX,NY,IN_NAME,IN_COMMENTS)

C Get memory space for output file:
        ISIZE=NX*NY*4
	CALL JLP_GETVM(PNTR_2,ISIZE)

        WRITE(6,30)
30	FORMAT(' Emission lines ? [Y]')
        READ(5,10) ANS
        IEMISSION=1
	IF(ANS.NE.'N'.AND.ANS.NE.'n')IEMISSION=0

        WRITE(1,125) IN_NAME,CALIB_FILE
125      FORMAT(' Input spectrum with lines: ',A,/,
     1         ' Calibration file (from catalog): ',A)
        IF(IEMISSION.EQ.1)THEN
          WRITE(1,126)
126       FORMAT(' Calibration with emission lines')
        ELSE
          WRITE(1,127)
127       FORMAT(' Calibration with absorption lines')
        ENDIF

C************************************************************
C 1st step: plot the spectrum and identify the lines
C************************************************************
C Input:
C WAVE0(NWAVE0) array with calibration wavelengths
C MADRID(PNTR_1) input spectrum with emission/absorption lines
C Output: approximative X coordinates in XX array
C         calibration wavelengths in YY array
	CALL IDENTIFY_LINES(MADRID(PNTR_1),NX,
     1         WAVE0,WAVE0_NAME,NWAVE0,XX,YY,NLINES,PLOTDEV,ISTAT)

C************************************************************
C 2nd step: look for central wavelength of NLINES lines
C************************************************************
C Input: approximative X coordinates in XX array
C Output: precise X coordinates in XX array
        CALL SEARCH_LINES(MADRID(PNTR_1),NX,XX,NLINES,IEMISSION)

C************************************************************
C 3rd step: fit a polynomial to the wavelengh/pixel dispersion relation
C************************************************************
	CALL FIT_DISPERSION(XX,YY,NLINES,XC,SDEV,KK,PLOTDEV,ISTAT)

C************************************************************
C 4th step: apply this polynomial to compute the wavelengh values
C of the input spectrum.
C************************************************************
	CALL COMPUTE_WAVE(MADRID(PNTR_1),MADRID(PNTR_2),NX,
     1              XC,KK,ISTAT)

C**** Output file :
        IF(ISTAT.EQ.0)THEN
          WRITE(6,*) 'Output file (wavelength-calibrated spectrum): '
          READ(5,10) OUT_NAME
	  WRITE(OUT_COMMENTS,1003) IN_NAME(1:12)
1003      FORMAT('Wavelength_calibrated version of ',A)
 	  CALL JLP_WRITEIMAG(MADRID(PNTR_2),NX,NY,NX,
     1             OUT_NAME,OUT_COMMENTS)
        ENDIF
        WRITE(1,129)OUT_NAME
129     FORMAT(' Output calibrated file: ',A)

C End:
999	CALL JLP_END
        CLOSE(1)
	STOP
	END
C************************************************************************
	SUBROUTINE IDENTIFY_LINES(IMAGE1,NX,
     1         WAVE0,WAVE0_NAME,NWAVE0,XX,YY,NLINES,PLOTDEV,ISTAT)
	PARAMETER (IDIM=2000)
        REAL*4 IMAGE1(NX,*)
	REAL*8 XX(*),YY(*),YY1
	REAL*4 X1(IDIM,2),Y1(IDIM,2),XOUT,YOUT,WAVE0(*)
	INTEGER*4 NPTS(2),NOUT,ISTAT,NWAVE0,I,J,J1,J2
	CHARACTER ANS*1,PLOTDEV*32,WAVE0_NAME(*)*20,PCOLOR(2)*30
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,NCHAR(2)*4

C Common block for cursor:
	COMMON /STR_OUTPUT/XOUT(200),YOUT(200),NOUT

C Status:
        ISTAT=0

10	FORMAT(A)

C Transfer of the spectrum to X,Y array
        IF(NX.GT.IDIM)THEN
          WRITE(6,23) IDIM
23        FORMAT('BACK_SUBTRACT/Fatal error, nx max =',I5)
          ISTAT=-1
          STOP
        ENDIF

	NPTS(1)=NX
        DO I=1,NPTS(1)
C Loading arrays for display:
          X1(I,1)=IMAGE1(I,2)
          Y1(I,1)=IMAGE1(I,1)
	END DO

27	WRITE(6,28)
28	FORMAT(' Displaying the input spectrum')
	WRITE(6,29)
29	FORMAT('Use the cursor to select the lines',
     1           ' (approximately)')
C Graphic output
	CHAR1='Wavelength'
	CHAR2='Flux'
	NCHAR(1)='L0'
        PCOLOR(1)='Default'
	TITLE='Select the lines (approximately)'
62	CALL NEWPLOT(X1,Y1,NPTS,IDIM,1,CHAR1,CHAR2,TITLE,
     1	NCHAR,PCOLOR,PLOTDEV,' ',' ')

	PRINT *,' Do you want to display the curve again? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 62

        IF(NOUT.EQ.0)THEN
          WRITE(6,32) NOUT
32        FORMAT(' IDENTIFY_LINES/Error: no points entered')
          GOTO 27
        ENDIF

C Input of XX, YY arrays:
        NLINES=0
        DO I=1,NOUT
          J=NINT(XOUT(I))
34        WRITE(6,33) I,J,IMAGE1(J,1)
33        FORMAT(' Line #',I3,' IX = ',I4,' Intensity:',1PG10.3,/,
     1           ' Enter wavelength (0 for help, -1 to reject):')
          READ(5,*)YY1
          IF(YY1.EQ.0.)THEN
            WRITE(6,35) NWAVE0
35          FORMAT(' Displaying a subsample of the input catalog',
     1             ' of calibration lines',/,
     1             I5,' lines available. Enter first and last line number:')
            READ(5,*)J1,J2
            J1=MAX(1,J1)
            J2=MIN(NWAVE0,J2)
            DO J=J1,J2
              WRITE(6,36) J,WAVE0(J),WAVE0_NAME(J)
              WRITE(1,36) J,WAVE0(J),WAVE0_NAME(J)
36            FORMAT(' Line #',I4,' Wavelength :',1PG12.5,' Name: ',A20)
            ENDDO
            GOTO 34
          ELSE
            IF(YY1.NE.-1.)THEN
              NLINES=NLINES+1
              YY(NLINES)=YY1
              XX(NLINES)=XOUT(I)
            ENDIF
          ENDIF
        END DO

	WRITE(6,38)
38      FORMAT(' Is it OK ? (Y) ',/,
     1         '(Otherwise, possibility of displaying the spectrum again)')
	READ(5,10) ANS
	IF(ANS.EQ.'N'.OR.ANS.EQ.'n')GOTO 27

        RETURN
	END
C************************************************************************
C Fit the dispersion relation
C************************************************************************
	SUBROUTINE FIT_DISPERSION(XX,YY,NLINES,XC,SDEV,KK,PLOTDEV,ISTAT)
	PARAMETER (IDIM=2000)
	REAL*8 XX(*),YY(*),XX1,YY1
	REAL*8 XC(*),SDEV(*),ERR
	REAL*4 X1(IDIM,2),Y1(IDIM,2),DELTA,STEP
	REAL*4 XOUT,YOUT
	INTEGER*4 NPTS(2),NOUT,KK,NLINES
	INTEGER*4 ISTAT
	CHARACTER ANS*1,PLOTDEV*32,PCOLOR(2)*30
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,NCHAR(2)*4

C Common block for cursor:
	COMMON /STR_OUTPUT/XOUT(200),YOUT(200),NOUT

C Status:
        ISTAT=0

10	FORMAT(A)

C Loading arrays for display:
	NPTS(1)=NLINES
        DO I=1,NPTS(1)
         X1(I,1)=XX(I)
         Y1(I,1)=YY(I)
        ENDDO

C Graphic output
        WRITE(6,22)
22      FORMAT(' Displaying input data point for dispersion relation fit')
	CHAR1='Pixel'
	CHAR2='Wavelength'
	NCHAR(1)='550'
        PCOLOR(1)='Default'

	TITLE=' Dispersion input data points'
33	CALL NEWPLOT(X1,Y1,NPTS,IDIM,1,CHAR1,CHAR2,TITLE,
     1	NCHAR,PCOLOR,PLOTDEV,' ',' ')
	PRINT *,' Do you want to display the curve again? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 33

63	PRINT *,' Order of the polynomial for the dispersion relation fit?'
	READ(5,*) KK

C*****************************************************************
C Fitting a polynomial :
	PRINT *,' Fitting the polynomial now ...'
	CALL POLYFIT(XX,YY,NLINES,KK,XC,SDEV,ERR)

	WRITE(6,25) ERR
	WRITE(1,25) ERR
25	FORMAT(' Mean fitting error rms :',G10.3)
	  DO K=1,KK+1
	    WRITE(6,26) K-1,XC(K),SDEV(K)
	    WRITE(1,26) K-1,XC(K),SDEV(K)
26	    FORMAT(' Order: ',I3,' Coeff: ',G10.3,' Error: ',G12.5)
	  END DO

C Plotting the input data points and the fit:
        NPTS(2)=200
        DELTA=1.2*(XX(NLINES)-XX(1))
        STEP=DELTA/NPTS(2)
	DO I=1,NPTS(2)
          X1(I,2)=XX(1)-0.1*DELTA+FLOAT(I)*STEP
          XX1=X1(I,2)
	  CALL CALPOLY(XX1,YY1,XC,KK)
	  Y1(I,2)=YY1
	END DO

	NCHAR(2)='L2'
        PCOLOR(2)='Default'
	TITLE='Dispersion relation'
51	WRITE(6,40)
40	FORMAT(' Displaying the fit and the original data points')
	CALL NEWPLOT(X1,Y1,NPTS,IDIM,2,CHAR1,CHAR2,TITLE,
     1	NCHAR,PCOLOR,PLOTDEV,' ',' ')
	PRINT *,' Do you want to change the window parameters? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 51

	PRINT *,' Do you want to change the order of the polynomial? (N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GOTO 63

        RETURN
	END
C************************************************************************
C Compute the wavelengths using dispersion relation
C and transfer input spectrum to output
C************************************************************************
	SUBROUTINE COMPUTE_WAVE(IMAGE1,IMAGE2,NX,
     1              XC,KK,ISTAT)
        REAL*4 IMAGE1(NX,*),IMAGE2(NX,*)
	REAL*8 XX1,YY1,XC(*)
	INTEGER*4 NX,KK

        ISTAT=0

	DO I=1,NX
C Computing the wavelengths
          XX1=IMAGE1(I,2)
	  CALL CALPOLY(XX1,YY1,XC,KK)
          IMAGE2(I,2)=YY1
C Transfer of the array to output image:
          IMAGE2(I,1)=IMAGE1(I,1)
	END DO

        RETURN
	END
C**********************************************************************
C Routine to read calibration ASCII file
C
C NWAVE0: in input, maximum size of WAVE0, in output, actual size of WAVE0
C**********************************************************************
        SUBROUTINE READ_CALIB(CALIB_FILE,WAVE0,WAVE0_NAME,NWAVE0,ISTAT)
        REAL*4 WAVE0(*)
        INTEGER*4 NWAVE0,ISTAT
        CHARACTER CALIB_FILE*40,WAVE0_NAME(*)*20
C
C Opening input calibration file:
        OPEN(2,FILE=CALIB_FILE,STATUS='OLD',ERR=99)
        DO I=1,NWAVE0
          READ(2,*,END=21) WAVE0(I),XINTENSITY,WAVE0_NAME(I)
C          READ(2,20,END=21) WAVE0(I),XINTENSITY,WAVE0_NAME(I)
C20        FORMAT(G12.5,1X,G12.5,1X,A20)
        END DO
21      NWAVE0=I-1
        CLOSE(2)
        ISTAT=0
        RETURN
C
C Error case:
99      WRITE(6,34)CALIB_FILE
34      FORMAT(' Error opening input catalog :',A)
        ISTAT=-1
        RETURN
        END
C*****************************************************************
C Look for central wavelength of NLINES lines
C Input: approximative X coordinates in XX array
C Output: precise X coordinates in XX array
C************************************************************************
        SUBROUTINE SEARCH_LINES(IMAGE1,NX,XX,NLINES,IEMISSION)
        REAL*4 IMAGE1(NX,*),INTENS_MAX
        REAL*8 XX(*),XX1,SUM
        INTEGER*4 NLINES,IEMISSION,NLINES1,IX(3)

C IERROR set to NX/256 (i.e. 4 pixels if NX=1024)
        IERROR=NX/256
        IERROR=MAX(2,IERROR)

C Save previous value of NLINES:
        NLINES1=NLINES
        NLINES=0

C Loop on all the lines:
        DO ILINE=1,NLINES1
          IX(1)=NINT(XX(ILINE))
          IX(2)=MAX(1,IX(1)-IERROR)
          IX(3)=MIN(NX,IX(1)+IERROR)
C Look for nearest minimum/maximum:
           INTENS_MAX=IMAGE1(IX(1),1)
C Debug message:
           WRITE(6,28) ILINE,IX(1),INTENS_MAX
           WRITE(1,28) ILINE,IX(1),INTENS_MAX
28         FORMAT(' Line #',I4,' Approximation: IX=',I5,
     1            ' Intensity:',G12.5)
C Emission or absorption line:
           IF(IEMISSION.EQ.1)THEN
             DO I=IX(1),IX(2)
               IF(INTENS_MAX.LT.IMAGE1(I,1))THEN
                 IX(1)=I
                 INTENS_MAX=IMAGE1(I,1)
               ENDIF
             END DO
           ELSE
             DO I=IX(1),IX(2)
               IF(INTENS_MAX.GT.IMAGE1(I,1))THEN
                 IX(1)=I
                 INTENS_MAX=IMAGE1(I,1)
               ENDIF
             END DO
           ENDIF
C Debug message:
           WRITE(6,29) ILINE,IX(1),INTENS_MAX
           WRITE(1,29) ILINE,IX(1),INTENS_MAX
29         FORMAT(' Line #',I4,' Nearest extremum: IX=',I5,
     1            ' Intensity:',G12.5)
C
C Error if maximum on the edge:
           IF(IX(1).EQ.IX(3).OR.IX(1).EQ.IX(2))THEN
             WRITE(6,25) ILINE
             WRITE(1,25) ILINE
25           FORMAT('SEARCH_LINES/Error with line #',I4,
     1              ' (Extremum on the edge...)')
           ELSE
C Then look for barycenter (with 3 values)
             IX(2)=MAX(1,IX(1)-1)
             IX(3)=MIN(NX,IX(1)+1)
             XX1=0.
             SUM=0.
             DO I=1,3
               XX1=XX1+IX(I)*IMAGE1(IX(I),1)
               SUM=SUM+IMAGE1(IX(I),1)
             END DO
             IF(SUM.NE.0)THEN
               NLINES=NLINES+1
               XX(NLINES)=XX1/SUM
C Debug message:
               WRITE(6,30) NLINES,XX(NLINES)
               WRITE(1,30) NLINES,XX(NLINES)
30             FORMAT(' Final XX,YY line index #',I4,
     1            ' After interpolation: X=',G13.5)
             ENDIF
           ENDIF
        END DO

C Check that more than 0 lines have been found:
        IF(NLINES.EQ.0)THEN
          IF(IEMISSION.EQ.1)THEN
            WRITE(6,31)
            WRITE(1,31)
31          FORMAT(' Fatal error when searching emission lines')
          ELSE
            WRITE(6,32)
            WRITE(1,32)
32          FORMAT(' Fatal error when searching absorption lines')
          ENDIF
          STOP
        ENDIF

        RETURN
        END
C************************************************************************
	include 'jlpsub:polyfit.for'


module zscore

  use types, only: dp
  use permutations, only: permutation, permuteColumns
  implicit none

contains

  !function computeZ(chrom1, exp1, chrom2, exp2) result(z)
  !  integer, dimension(:, :), intent(in) :: chrom1
  !  real(dp), dimension(size(chrom1, 1), size(chrom1, 2)), intent(in) :: exp1
  !  integer, dimension(:, :), intent(in) :: chrom2
  !  real(dp), dimension(size(chrom2, 1), size(chrom2, 2)), intent(in) :: exp2
  !
  !  real(dp), dimension(size(chrom1, 1), size(chrom2, 1)) :: z
  !
  !  !integer, dimension(size(z, 1), size(z, 2)) :: observed
  !  !real(dp), dimension(size(z, 1), size(z, 2)) :: expected
  !  integer, dimension(size(chrom1, 1), size(chrom2, 1)) :: observed
  !  real(dp), dimension(size(chrom1, 1), size(chrom2, 1)) :: expected
  !
  !  observed = matmul(chrom1, transpose(chrom2))
  !  expected = matmul(exp1, transpose(exp2))
  !
  !  z = (observed - expected) / sqrt(expected * (1.0d0 - expected / dble(size(chrom1, 2))))
  !end function computeZ

  function computeZ(chrom1, p1, chrom2, p2) result(z)
    integer, dimension(:, :), intent(in) :: chrom1
    real(dp), dimension(size(chrom1, 1), size(chrom1, 2)), intent(in) :: p1
    integer, dimension(:, :), intent(in) :: chrom2
    real(dp), dimension(size(chrom2, 1), size(chrom2, 2)), intent(in) :: p2

    real(dp), dimension(size(chrom1, 1), size(chrom2, 1)) :: z

    integer, dimension(size(chrom1, 1), size(chrom2, 1)) :: observed
    real(dp), dimension(size(chrom1, 1), size(chrom2, 1)) :: expected, stdev

    expected = matmul(p1, transpose(p2))
    stdev = sqrt(expected - matmul(p1**2, transpose(p2)**2))
    observed = matmul(chrom1, transpose(chrom2))

    z = (observed - expected) / stdev
  end function computeZ

  function sampleFromNull(chrom1, exp1, chrom2, exp2, numSamples) result (nullSamples)
    integer, dimension(:, :), intent(in) :: chrom1
    real(dp), dimension(size(chrom1, 1), size(chrom1, 2)), intent(in) :: exp1
    integer, dimension(:, :), intent(in) :: chrom2
    real(dp), dimension(size(chrom2, 1), size(chrom2, 2)), intent(in) :: exp2
    integer, intent(in) :: numSamples

    real(dp), dimension(numSamples) :: nullSamples

    integer :: i
    integer, dimension(size(chrom1, 2)) :: perm
    integer, dimension(size(chrom2, 1), size(chrom2, 2)) :: permutedChrom2
    real(dp), dimension(size(chrom2, 1), size(chrom2, 2)) :: permutedExp2

    call setSeed()

    do i = 1, numSamples
       perm = permutation(size(perm))
       permutedChrom2 = permuteColumns(chrom2, perm)
       permutedExp2 = permuteColumns(exp2, perm)
       nullSamples(i) = maxval(computeZ(chrom1, exp1, permutedChrom2, permutedExp2))
    end do
  end function sampleFromNull

  subroutine setSeed()
    integer :: size, i
    integer, allocatable, dimension(:) :: seed

    call random_seed(size=size)
    allocate(seed(size))

    do i = 1, size
       seed(i) = 1234 * i
    end do

    call random_seed(put=seed)
    deallocate(seed)
  end subroutine setSeed

end module zscore


program calc_predicted_dtrad

integer, parameter :: dx=3750, dy=3750
integer :: i, j
real, parameter :: c1=-9.6463
real, parameter :: c1x1=-0.183506 ! DAY-NIGHT
real, parameter :: c1x2=1.04281    ! DAY
real, parameter :: c1x3=-0.0529513

character(len=400) :: nightfile, laifile, dayfile, outfile
logical :: exists1, exists2, exists3
real :: lai(dx,dy), day(dx,dy)
real :: night(dx,dy), model(dx,dy)

call getarg(1,nightfile)
call getarg(2,dayfile)
call getarg(3,laifile)
call getarg(4,outfile)

inquire(file=dayfile,exist=exists1)
inquire(file=nightfile,exist=exists2)
inquire(file=laifile,exist=exists3)

 write(6,*) exists1, exists2, exists3
 if (exists1.eqv..TRUE..and.exists2.eqv..TRUE..and.exists3.eqv..TRUE.) then
  open(10,file=nightfile,form='unformatted',access='direct',recl=dx*dy*4)
  open(11,file=dayfile,form='unformatted',access='direct',recl=dx*dy*4)
  open(12,file=laifile,form='unformatted',access='direct',recl=dx*dy*4)
  read(10,rec=1) night
  read(11,rec=1) day
  read(12,rec=1) lai
  close(10)
  close(11)
  close(12)
 endif
 if (exists1.eqv..FALSE..or.exists2.eqv..FALSE..or.exists3.eqv..FALSE.) then
  day(:,:) = -9999.
  night(:,:) = -9999.
 endif

 write(6,*) day(251,251), night(251,251), lai(251,251)
 model(:,:) = -9999.
 do j = 1, dy
 do i = 1, dx
  if (day(i,j)-night(i,j).gt.0.and.day(i,j).gt.0.and.night(i,j).gt.0.and.lai(i,j).ge.0) then
    model(i,j) = c1+(c1x1*(day(i,j)-night(i,j)))+(c1x2*day(i,j))+(c1x3*(lai(i,j)))
  endif
 enddo
 enddo

 write(6,*) model(251,251)
 open(50,file=outfile,form='unformatted',access='direct',recl=dx*dy*4)
 write(50,rec=1) model
 close(50)

end program


C Copyright(C) 2011 Sandia Corporation.  Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C * Redistributions of source code must retain the above copyright
C    notice, this list of conditions and the following disclaimer.
C
C * Redistributions in binary form must reproduce the above
C   copyright notice, this list of conditions and the following
C   disclaimer in the documentation and/or other materials provided
C   with the distribution.
C
C * Neither the name of Sandia Corporation nor the names of its
C   contributors may be used to endorse or promote products derived
C   from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C
      SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2,  U)
      DIMENSION X(N),Y(N),Y2(N),U(N)
      IF (YP1.GT..99E30) THEN
        Y2(1)=0.
        U(1)=0.
      ELSE
        Y2(1)=-0.5
        U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
      ENDIF
      DO 11 I=2,N-1
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        P=SIG*Y2(I-1)+2.
        Y2(I)=(SIG-1.)/P
        U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
11    CONTINUE
      IF (YPN.GT..99E30) THEN
        QN=0.
        UN=0.
      ELSE
        QN=0.5
        UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
      ENDIF
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)
      DO 12 K=N-1,1,-1
        Y2(K)=Y2(K)*Y2(K+1)+U(K)
12    CONTINUE
      RETURN
      END


!=============================================================================!
        subroutine smoother(rl, vl)
!
!       Fourth order explicit smoother for the NS equations.
!       From: Computational Fluid Mechanics and Heat Transfer
!             D.A. Anderson, J. C. Tannehill, Rl H. Pletcher
!             Page:  450, 495
!
!       Note this routine can also do sixth-order and second-order smoothers
!       but that are currently disabled.
!
!       Written: 6-9-95
!
!       Revised: 7-9-96
!
!       Notes:   Need to account for periodicity in the smoothed fields.
!
!       Revised: 11-20-99 Switched indices
!=============================================================================!
        use global
        use buffer
        use stencil
        implicit none

        real :: rl(ndof,nx,ny), vl(ndof,nx,ny)
        !$sgi distribute rl(*,*,block), vl(*,*,block)

        real :: isign
        integer :: idof, i, j

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

        if (eps_e .eq. zero) return

!===========================================================================
!     F O U R T H   O R D E R   T E R M
!===========================================================================

!.... \eta direction

        !$omp parallel do private(idof, j)
        do i = 1, nx
          do idof = 1, ndof

            j = 2
            rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                           -1.0 * vl(idof,i,j-1) + &
                                            2.0 * vl(idof,i,j  ) - &
                                            1.0 * vl(idof,i,j+1) )

            j = 3
            rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                vl(idof,i,j-2) - &
                                          4.0 * vl(idof,i,j-1) + &
                                          6.0 * vl(idof,i,j  ) - &
                                          4.0 * vl(idof,i,j+1) + &
                                          1.0 * vl(idof,i,j+2) )

            do j = 4, ny-3
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            fa1 * vl(idof,i,j-3) + &
                                            fa2 * vl(idof,i,j-2) + &
                                            fa3 * vl(idof,i,j-1) + &
                                            fa4 * vl(idof,i,j  ) + &
                                            fa5 * vl(idof,i,j+1) + &
                                            fa6 * vl(idof,i,j+2) + &
                                            fa7 * vl(idof,i,j+3) )
            end do

            j = ny-2
            rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                vl(idof,i,j-2) - &
                                          4.0 * vl(idof,i,j-1) + &
                                          6.0 * vl(idof,i,j  ) - &
                                          4.0 * vl(idof,i,j+1) + &
                                          1.0 * vl(idof,i,j+2) )

            j = ny-1
            rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                           -1.0 * vl(idof,i,j-1) + &
                                            2.0 * vl(idof,i,j  ) - &
                                            1.0 * vl(idof,i,j+1) )

          end do
        end do

!.... \xi direction

        if (lsym) then
          !$omp parallel do private(idof, isign, i)
          do j = 1, ny
            do idof = 1, ndof
              if (idof .eq. 3) then
                isign = -one
              else
                isign = one
              end if

              i = 1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            isign * fa1 * vl(idof,4,j) + &
                                            isign * fa2 * vl(idof,3,j) + &
                                            isign * fa3 * vl(idof,2,j) + &
                                            fa4 * vl(idof,1,j) + &
                                            fa5 * vl(idof,2,j) + &
                                            fa6 * vl(idof,3,j) + &
                                            fa7 * vl(idof,4,j) )

              i = 2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            isign * fa1 * vl(idof,3,j) + &
                                            isign * fa2 * vl(idof,2,j) + &
                                            fa3 * vl(idof,1,j) + &
                                            fa4 * vl(idof,2,j) + &
                                            fa5 * vl(idof,3,j) + &
                                            fa6 * vl(idof,4,j) + &
                                            fa7 * vl(idof,5,j) )

              i = 3
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            isign * fa1 * vl(idof,2,j) + &
                                            fa2 * vl(idof,1,j) + &
                                            fa3 * vl(idof,2,j) + &
                                            fa4 * vl(idof,3,j) + &
                                            fa5 * vl(idof,4,j) + &
                                            fa6 * vl(idof,5,j) + &
                                            fa7 * vl(idof,6,j) )
            end do
          end do
        else
          !$omp parallel do private(idof, i)
          do j = 1, ny
            do idof = 1, ndof
              i = 2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                           -1.0 * vl(idof,i-1,j) + &
                                            2.0 * vl(idof,i,j  ) - &
                                            1.0 * vl(idof,i+1,j) )

              i = 3
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                  vl(idof,i-2,j) - &
                                            4.0 * vl(idof,i-1,j) + &
                                            6.0 * vl(idof,i,j  ) - &
                                            4.0 * vl(idof,i+1,j) + &
                                            1.0 * vl(idof,i+2,j) )
            end do
          end do
        end if

!.... Interior

        !$omp parallel do private(i, idof)
        do j = 1, ny
          do i = 4, nx-3
            do idof = 1, ndof
              rl(idof,i,j) = rl(idof,i,j) + &
                                  eps_e * buff(i,j) * ( &
                                  fa1 * vl(idof,i-3,j) + &
                                  fa2 * vl(idof,i-2,j) + &
                                  fa3 * vl(idof,i-1,j) + &
                                  fa4 * vl(idof,i,j  ) + &
                                  fa5 * vl(idof,i+1,j) + &
                                  fa6 * vl(idof,i+2,j) + &
                                  fa7 * vl(idof,i+3,j) )
            end do
          end do
        end do

        if (rsym) then
          !$omp parallel do private(idof, isign, i)
          do j = 1, ny
            do idof = 1, ndof
              if (idof .eq. 3) then
                isign = -one
              else
                isign = one
              end if
              i = nx-2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            fa1 * vl(idof,nx-5,j) + &
                                            fa2 * vl(idof,nx-4,j) + &
                                            fa3 * vl(idof,nx-3,j) + &
                                            fa4 * vl(idof,nx-2,j) + &
                                            fa5 * vl(idof,nx-1,j) + &
                                            fa6 * vl(idof,nx,j  ) + &
                                            isign * fa7 * vl(idof,nx-1,j) )

              i = nx-1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            fa1 * vl(idof,nx-4,j) + &
                                            fa2 * vl(idof,nx-3,j) + &
                                            fa3 * vl(idof,nx-2,j) + &
                                            fa4 * vl(idof,nx-1,j) + &
                                            fa5 * vl(idof,nx,j  ) + &
                                            isign * fa6 * vl(idof,nx-1,j) + &
                                            isign * fa7 * vl(idof,nx-2,j) )

              i = nx
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            fa1 * vl(idof,nx-3,j) + &
                                            fa2 * vl(idof,nx-2,j) + &
                                            fa3 * vl(idof,nx-1,j) + &
                                            fa4 * vl(idof,nx,j) + &
                                            isign * fa5 * vl(idof,nx-1,j) + &
                                            isign * fa6 * vl(idof,nx-2,j) + &
                                            isign * fa7 * vl(idof,nx-3,j) )
            end do
          end do
        else
          !$omp parallel do private(idof, i)
          do j = 1, ny
            do idof = 1, ndof
              i = nx-2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                  vl(idof,i-2,j) - &
                                            4.0 * vl(idof,i-1,j) + &
                                            6.0 * vl(idof,i,j  ) - &
                                            4.0 * vl(idof,i+1,j) + &
                                            1.0 * vl(idof,i+2,j) )

              i = nx-1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                           -1.0 * vl(idof,i-1,j) + &
                                            2.0 * vl(idof,i,j  ) - &
                                            1.0 * vl(idof,i+1,j) )
            end do
          end do
        end if

!===========================================================================
!     S I X T H   O R D E R   T E R M
!===========================================================================

        if (.false.) then

          do idof = 1, ndof
            do i = 1, nx

              j = 2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                -1.0 * vl(idof,i,j-1) + &
                                                 2.0 * vl(idof,i,j  ) - &
                                                 1.0 * vl(idof,i,j+1) )

              do j = 3, 4
                rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                        vl(idof,i,j-2) - &
                                                  4.0 * vl(idof,i,j-1) + &
                                                  6.0 * vl(idof,i,j  ) - &
                                                  4.0 * vl(idof,i,j+1) + &
                                                  1.0 * vl(idof,i,j+2) )
              end do

              do j = 5, ny-4
                rl(idof,i,j) = rl(idof,i,j) + &
                                    eps_e * buff(i,j) * ( &
                                              fc1 * vl(idof,i,j-4) + &
                                              fc2 * vl(idof,i,j-3) + &
                                              fc3 * vl(idof,i,j-2) + &
                                              fc4 * vl(idof,i,j-1) + &
                                              fc5 * vl(idof,i,j  ) + &
                                              fc6 * vl(idof,i,j+1) + &
                                              fc7 * vl(idof,i,j+2) + &
                                              fc8 * vl(idof,i,j+3) + &
                                              fc9 * vl(idof,i,j+4) )
              end do

              do j = ny-3, ny-2
                rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                        vl(idof,i,j-2) - &
                                                  4.0 * vl(idof,i,j-1) + &
                                                  6.0 * vl(idof,i,j  ) - &
                                                  4.0 * vl(idof,i,j+1) + &
                                                  1.0 * vl(idof,i,j+2) )
              end do

              j = ny-1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            -1.0 * vl(idof,i,j-1) + &
                                             2.0 * vl(idof,i,j  ) - &
                                             1.0 * vl(idof,i,j+1) )

            end do
          end do

          do idof = 1, ndof
            do j = 1, ny

              i = 2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                -1.0 * vl(idof,i-1,j) + &
                                                 2.0 * vl(idof,i,j  ) - &
                                                 1.0 * vl(idof,i+1,j) )

              do i = 3, 4
                rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                        vl(idof,i-2,j) - &
                                                  4.0 * vl(idof,i-1,j) + &
                                                  6.0 * vl(idof,i,j  ) - &
                                                  4.0 * vl(idof,i+1,j) + &
                                                  1.0 * vl(idof,i+2,j) )
              end do

              do i = 5, nx-4
                rl(idof,i,j) = rl(idof,i,j) + &
                                    eps_e * buff(i,j) * ( &
                                              fc1 * vl(idof,i-4,j) + &
                                              fc2 * vl(idof,i-3,j) + &
                                              fc3 * vl(idof,i-2,j) + &
                                              fc4 * vl(idof,i-1,j) + &
                                              fc5 * vl(idof,i,j  ) + &
                                              fc6 * vl(idof,i+1,j) + &
                                              fc7 * vl(idof,i+2,j) + &
                                              fc8 * vl(idof,i+3,j) + &
                                              fc9 * vl(idof,i+4,j) )
              end do

              do i = nx-3, nx-2
                rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                        vl(idof,i-2,j) - &
                                                  4.0 * vl(idof,i-1,j) + &
                                                  6.0 * vl(idof,i,j  ) - &
                                                  4.0 * vl(idof,i+1,j) + &
                                                  1.0 * vl(idof,i+2,j) )
              end do

              i = nx-1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            -1.0 * vl(idof,i-1,j) + &
                                             2.0 * vl(idof,i,j  ) - &
                                             1.0 * vl(idof,i+1,j) )
            end do
          end do

        endif

!.... second order dissipation

        if (.false.) then

          do idof = 1, ndof
            do i = 1, nx

              j = 2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                -1.0 * vl(idof,i,j-1) + &
                                                 2.0 * vl(idof,i,j  ) - &
                                                 1.0 * vl(idof,i,j+1) )

              do j = 3, ny-2
                rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                        vl(idof,i,j-2) - &
                                                  4.0 * vl(idof,i,j-1) + &
                                                  6.0 * vl(idof,i,j  ) - &
                                                  4.0 * vl(idof,i,j+1) + &
                                                  1.0 * vl(idof,i,j+2) )
              end do

              j = ny-1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            -1.0 * vl(idof,i,j-1) + &
                                             2.0 * vl(idof,i,j  ) - &
                                             1.0 * vl(idof,i,j+1) )

            end do
          end do

          do idof = 1, ndof
            do j = 1, ny

              i = 2
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                -1.0 * vl(idof,i-1,j) + &
                                                 2.0 * vl(idof,i,j  ) - &
                                                 1.0 * vl(idof,i+1,j) )

              do i = 3, nx-2
                rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                                        vl(idof,i-2,j) - &
                                                  4.0 * vl(idof,i-1,j) + &
                                                  6.0 * vl(idof,i,j  ) - &
                                                  4.0 * vl(idof,i+1,j) + &
                                                  1.0 * vl(idof,i+2,j) )
              end do

              i = nx-1
              rl(idof,i,j) = rl(idof,i,j) + eps_e * buff(i,j) * ( &
                                            -1.0 * vl(idof,i-1,j) + &
                                             2.0 * vl(idof,i,j  ) - &
                                             1.0 * vl(idof,i+1,j) )

            end do
          end do

        end if

        return
        end