*  -*- fortran -*-
      SUBROUTINE sGMRESREVCOM(N, B, X, RESTRT, WORK, LDW, WORK2,
     $                  LDW2, ITER, RESID, INFO, NDX1, NDX2, SCLR1,
     $                  SCLR2, IJOB)
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     EiITERkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, RESTRT, LDW, LDW2, ITER, INFO
      real  RESID
      INTEGER            NDX1, NDX2
      real   SCLR1, SCLR2
      INTEGER            IJOB
*     ..
*     .. Array Arguments ..
      real   B( * ), X( * ), WORK( LDW,* ), WORK2( LDW2,* )
*     ..
*
*  Purpose
*  =======
*
*  GMRES solves the linear system Ax = b using the
*  Generalized Minimal Residual iterative method with preconditioning.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER.
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N.
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess; on exit, the iterated solution.
*
*  RESTRT  (input) INTEGER
*          Restart parameter, .ls. = N. This parameter controls the amount
*          of memory required for matrix WORK2.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDW,6+restrt).
*          Note that if the initial guess is the zero vector, then
*          storing the initial residual is not necessary.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW .gt. = max(1,N).
*
*  WORK2   (workspace) DOUBLE PRECISION array, dimension (LDW2,2*RESTRT+2).
*          This workspace is used for constructing and storing the
*          upper Hessenberg matrix. The two extra columns are used to
*          store the Givens rotation matrices.
*
*  LDW2    (input) INTEGER
*          The leading dimension of the array WORK2.
*          LDW2 .gt. = max(2,RESTRT+1).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable error tolerance.
*          On ouput, the norm of the residual vector if solution
*          approximated to tolerance, otherwise reset to input
*          tolerance.
*
*  INFO    (output) INTEGER
*          =  0:  successful exit
*          =  1:  maximum number of iterations performed;
*                 convergence not achieved.
*            -5: Erroneous NDX1/NDX2 in INIT call.
*            -6: Erroneous RLBL.
*
*  NDX1    (input/output) INTEGER.
*  NDX2    On entry in INIT call contain indices required by interface
*          level for stopping test.
*          All other times, used as output, to indicate indices into
*          WORK[] for the MATVEC, PSOLVE done by the interface level.
*
*  SCLR1   (output) DOUBLE PRECISION.
*  SCLR2   Used to pass the scalars used in MATVEC. Scalars are reqd because
*          original routines use dgemv.
*
*  IJOB    (input/output) INTEGER.
*          Used to communicate job code between the two levels.
*
*  ============================================================
*
*     .. Parameters ..
      real    ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      INTEGER             OFSET
      PARAMETER         ( OFSET = 1000 )
*     ..
*     .. Local Scalars ..
      INTEGER             I, MAXIT, AV, GIV, H, R, S, V, W, Y,
     $                    NEED1, NEED2
      real  wsdot
      real  toz
      real    TMPVAL
      real    BNRM2, RNORM, TOL,
     $     wsNRM2,
     $     wsAPPROXRES

*
*     indicates where to resume from. Only valid when IJOB = 2!
      INTEGER RLBL
*
*     saving all.
      SAVE
*
*     ..
*     .. External Routines ..
      EXTERNAL     sAXPY, sCOPY, wsdot, wsNRM2, sSCAL
*     ..
*     .. Executable Statements ..
*
* Entry point, so test IJOB
      IF (IJOB .eq. 1) THEN
         GOTO 1
      ELSEIF (IJOB .eq. 2) THEN
*        here we do resumption handling
         IF (RLBL .eq. 2) GOTO 2
         IF (RLBL .eq. 3) GOTO 3
         IF (RLBL .eq. 4) GOTO 4
         IF (RLBL .eq. 5) GOTO 5
         IF (RLBL .eq. 6) GOTO 6
         IF (RLBL .eq. 7) GOTO 7
*        if neither of these, then error
         INFO = -6
         GOTO 200
      ENDIF
*
* init.
*****************
 1    CONTINUE
*****************
*
      INFO = 0
      MAXIT = ITER
      TOL   = RESID
*
*     Alias workspace columns.
*
      R   = 1
      S   = 2
      W   = 3
      Y   = 4
      AV  = 5
      V   = 6
*
      H   = 1
      GIV = H + RESTRT
*
*     Check if caller will need indexing info.
*
      IF( NDX1.NE.-1 ) THEN
         IF( NDX1.EQ.1 ) THEN
            NEED1 = ((R - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.2 ) THEN
            NEED1 = ((S - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.3 ) THEN
            NEED1 = ((W - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.4 ) THEN
            NEED1 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.5 ) THEN
            NEED1 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.6 ) THEN
            NEED1 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.V*OFSET ) .AND.
     $           ( NDX1.LE.V*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.GIV*OFSET ) .AND.
     $           ( NDX1.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED1 = NDX1
      ENDIF
*
      IF( NDX2.NE.-1 ) THEN
         IF( NDX2.EQ.1 ) THEN
            NEED2 = ((R - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.2 ) THEN
            NEED2 = ((S - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.3 ) THEN
            NEED2 = ((W - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.4 ) THEN
            NEED2 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.5 ) THEN
            NEED2 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.6 ) THEN
            NEED2 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.V*OFSET ) .AND.
     $           ( NDX2.LE.V*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.GIV*OFSET ) .AND.
     $           ( NDX2.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED2 = NDX2
      ENDIF
*
*     Set initial residual.
*
      CALL sCOPY( N, B, 1, WORK(1,R), 1 )
      IF ( wsNRM2( N, X, 1 ).NE.ZERO ) THEN
*********CALL MATVEC( -ONE, X, ONE, WORK(1,R) )
*        Note: using X directly
         SCLR1 = -ONE
         SCLR2 = ONE
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*
*        Prepare for resumption & return
         RLBL = 2
         IJOB = 1
         RETURN
      ENDIF
*
*****************
 2    CONTINUE
*****************
*
      IF ( wsNRM2( N, WORK(1,R), 1 ).LT.TOL ) GO TO 200
      BNRM2 = wsNRM2( N, B, 1 )
      IF ( BNRM2.EQ.ZERO ) BNRM2 = ONE
*
      ITER = 0
   10 CONTINUE
*
         ITER = ITER + 1
*
*        Construct the first column of V, and initialize S to the
*        elementary vector E1 scaled by RNORM.
*
*********CALL PSOLVE( WORK( 1,V ), WORK( 1,R ) )
*
         NDX1 = ((V - 1) * LDW) + 1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 3
         IJOB = 2
         RETURN
*
*****************
 3       CONTINUE
*****************
*
         RNORM = wsNRM2( N, WORK( 1,V ), 1 )
         toz = ONE/RNORM
         CALL sSCAL( N, toz, WORK( 1,V ), 1 )
         TMPVAL = RNORM
         CALL sELEMVEC( 1, N, TMPVAL, WORK( 1,S ) )
*
*         DO 50 I = 1, RESTRT
         i = 1
 49      if (i.gt.restrt) go to 50
************CALL MATVEC( ONE, WORK( 1,V+I-1 ), ZERO, WORK( 1,AV ) )
*
         NDX1 = ((V+I-1 - 1) * LDW) + 1
         NDX2 = ((AV    - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = ONE
         SCLR2 = ZERO
         RLBL = 4
         IJOB = 3
         RETURN
*
*****************
 4       CONTINUE
*****************
*
*********CALL PSOLVE( WORK( 1,W ), WORK( 1,AV ) )
*
         NDX1 = ((W  - 1) * LDW) + 1
         NDX2 = ((AV - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 5
         IJOB = 2
         RETURN
*
*****************
 5       CONTINUE
*****************
*
*           Construct I-th column of H so that it is orthnormal to
*           the previous I-1 columns.
*
            CALL sORTHOH( I, N, WORK2( 1,I+H-1 ), WORK( 1,V ), LDW,
     $                   WORK( 1,W ) )
*
            IF ( I.GT.0 )
*
*              Apply Givens rotations to the I-th column of H. This
*              effectively reduces the Hessenberg matrix to upper
*              triangular form during the RESTRT iterations.
*
     $         CALL sAPPLYGIVENS(I, WORK2( 1,I+H-1 ), WORK2( 1,GIV ),
     $                           LDW2 )
*
*           Approxiyate residual norm. Check tolerance. If okay, compute
*           final approximation vector X and quit.
*
            RESID = wsAPPROXRES( I, WORK2( 1,I+H-1 ), WORK( 1,S ),
     $                         WORK2( 1,GIV ), LDW2 ) / BNRM2
            IF ( RESID.LE.TOL ) THEN
               CALL sUPDATE(I, N, X, WORK2( 1,H ), LDW2,
     $                     WORK(1,Y), WORK(1,S), WORK( 1,V ), LDW)
               GO TO 200
            ENDIF
            i = i + 1
            go to 49
   50    CONTINUE
         i = restrt
*
*        Compute current solution vector X.
*
         CALL sUPDATE(RESTRT, N, X, WORK2( 1,H ), LDW2,
     $               WORK(1,Y), WORK( 1,S ), WORK( 1,V ), LDW )
*
*        Compute residual vector R, find norm,
*        then check for tolerance.
*
         CALL sCOPY( N, B, 1, WORK( 1,R ), 1 )
*********CALL MATVEC( -ONE, X, ONE, WORK( 1,R ) )
*
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = -ONE
         SCLR2 = ONE
         RLBL = 6
         IJOB = 1
         RETURN
*
*****************
 6       CONTINUE
*****************
*
         WORK( I+1,S ) = wsNRM2( N, WORK( 1,R ), 1 )
*
*********RESID = WORK( I+1,S ) / BNRM2
*********IF ( RESID.LE.TOL  ) GO TO 200
*
         NDX1 = NEED1
         NDX2 = NEED2
*        Prepare for resumption & return
         RLBL = 7
         IJOB = 4
         RETURN
*
*****************
 7       CONTINUE
*****************
         IF( INFO.EQ.1 ) GO TO 200
*
         IF ( ITER.EQ.MAXIT ) THEN
            INFO = 1
            GO TO 100
         ENDIF
*
         GO TO 10
*
  100 CONTINUE
*
*     Iteration fails.
*
      RLBL = -1
      IJOB = -1
      RETURN
*
  200 CONTINUE
*
*     Iteration successful; return.
*
      INFO = 0
      RLBL = -1
      IJOB = -1

      RETURN
*
*     End of GMRESREVCOM
*
      END
*     END SUBROUTINE sGMRESREVCOM
*
*     =========================================================
      SUBROUTINE sORTHOH( I, N, H, V, LDV, W )
*
      INTEGER            I, N, LDV
      real   H( * ), W( * ), V( LDV,* )
*
*     Construct the I-th column of the upper Hessenberg matrix H
*     using the Gram-Schmidt process on V and W.
*
      INTEGER            K
      real
     $     wsNRM2, ONE
      PARAMETER        ( ONE = 1.0D+0 )
      real    wsdot
      real    TMPVAL
      EXTERNAL         sAXPY, sCOPY, wsdot, wsNRM2, sSCAL
*
      DO 10 K = 1, I
         H( K ) = wsdot( N, V( 1,K ), 1, W, 1 )
         CALL sAXPY( N, -H( K ), V( 1,K ), 1, W, 1 )
   10 CONTINUE
      H( I+1 ) = wsNRM2( N, W, 1 )
      CALL sCOPY( N, W, 1, V( 1,I+1 ), 1 )
      TMPVAL = ONE / H( I+1 )
      CALL sSCAL( N, TMPVAL, V( 1,I+1 ), 1 )
*
      RETURN
*
      END
*     END SUBROUTINE sORTHOH
*     =========================================================
      SUBROUTINE sAPPLYGIVENS( I, H, GIVENS, LDG )
*
      INTEGER            I, LDG
      real   H( * ), GIVENS( LDG,* )
*
*     This routine applies a sequence of I-1 Givens rotations to
*     the I-th column of H. The Givens parameters are stored, so that
*     the first I-2 Givens rotation matrices are known. The I-1st
*     Givens rotation is computed using BLAS 1 routine DROTG. Each
*     rotation is applied to the 2x1 vector [H( J ), H( J+1 )]',
*     which results in H( J+1 ) = 0.
*
      INTEGER            J
*      DOUBLE PRECISION   TEMP
      EXTERNAL           sROTG
*
*     .. Executable Statements ..
*
*     Construct I-1st rotation matrix.
*
*     CALL sROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL sGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
*     Apply 1,...,I-1st rotation matrices to the I-th column of H.
*
      DO 10 J = 1, I-1
         CALL sROTVEC(H( J ), H( J+1 ), GIVENS( J,1 ), GIVENS( J,2 ))
*        TEMP     =  GIVENS( J,1 ) * H( J ) + GIVENS( J,2 ) * H( J+1 )
*        H( J+1 ) = -GIVENS( J,2 ) * H( J ) + GIVENS( J,1 ) * H( J+1 )
*        H( J ) = TEMP
 10   CONTINUE
      call sgetgiv( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      call srotvec( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      RETURN
*
      END
*     END SUBROUTINE sAPPLYGIVENS
*
*     ===============================================================
      real
     $     FUNCTION wsAPPROXRES( I, H, S, GIVENS, LDG )
*
      INTEGER            I, LDG
      real   H( * ), S( * ), GIVENS( LDG,* )
*
*     This func allows the user to approximate the residual
*     using an updating scheme involving Givens rotations. The
*     rotation matrix is formed using [H( I ),H( I+1 )]' with the
*     intent of zeroing H( I+1 ), but here is applied to the 2x1
*     vector [S(I), S(I+1)]'.
*
      INTRINSIC          ABS
      EXTERNAL           sROTG
*
*     .. Executable Statements ..
*
*     CALL sROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL sGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      CALL sROTVEC( S( I ), S( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      wsAPPROXRES = ABS( S( I+1 ) )
*
      RETURN
*
      END
*     END FUNCTION wsAPPROXRES
*     ===============================================================
      SUBROUTINE sUPDATE( I, N, X, H, LDH, Y, S, V, LDV )
*
      INTEGER            N, I, J, LDH, LDV
      real   X( * ), Y( * ), S( * ), H( LDH,* ), V( LDV,* )
      EXTERNAL           sAXPY, sCOPY, sTRSV
*
*     Solve H*y = s for upper triangualar H.
*
      CALL sCOPY( I, S, 1, Y, 1 )
      CALL sTRSV( 'UPPER', 'NOTRANS', 'NONUNIT', I, H, LDH, Y, 1 )
*
*     Compute current solution vector X.
*
      DO 10 J = 1, I
         CALL sAXPY( N, Y( J ), V( 1,J ), 1, X, 1 )
   10 CONTINUE
*
      RETURN
*
      END
*     END SUBROUTINE sUPDATE
*
*     ===============================================================
      SUBROUTINE sGETGIV( A, B, C, S )
*
      real   A, B, C, S, TEMP, ZERO, ONE
      PARAMETER  (
     $     ZERO = 0.0,
     $     ONE = 1.0 )
*
      IF ( ABS( B ).EQ.ZERO ) THEN
         C = ONE
         S = ZERO
      ELSE IF ( ABS( B ).GT.ABS( A ) ) THEN
         TEMP = -A / B
         S = ONE / SQRT( ONE + abs(TEMP)**2 )
         C = TEMP * S
*         S = b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = -a / SQRT( abs(a)**2 + abs(b)**2 )
      ELSE
         TEMP = -B / A
         C = ONE / SQRT( ONE + abs(TEMP)**2 )
         S = TEMP * C
*         S = -b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = a / SQRT( abs(a)**2 + abs(b)**2 )
      ENDIF
*
      RETURN
*
      END
*     END SUBROUTINE sGETGIV
*
*     ================================================================
      SUBROUTINE sROTVEC( X, Y, C, S )
*
      real   X, Y, C, S, TEMP

*
      TEMP = (C) * X - (S) * Y
      Y    = S * X + C * Y
      X    = TEMP
*
      RETURN
*
      END
*     END SUBROUTINE sROTVEC
*
*     ===============================================================
      SUBROUTINE sELEMVEC( I, N, ALPHA, E )
*
*     Construct the I-th elementary vector E, scaled by ALPHA.
*
      INTEGER            I, J, N
      real   ALPHA, E( * )
*
*     .. Parameters ..
      real   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*
      DO 10 J = 1, N
         E( J ) = ZERO
   10 CONTINUE
      E( I ) = ALPHA
*
      RETURN
*
      END
*     END SUBROUTINE sELEMVEC

      SUBROUTINE dGMRESREVCOM(N, B, X, RESTRT, WORK, LDW, WORK2,
     $                  LDW2, ITER, RESID, INFO, NDX1, NDX2, SCLR1,
     $                  SCLR2, IJOB)
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     EiITERkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, RESTRT, LDW, LDW2, ITER, INFO
      double precision  RESID
      INTEGER            NDX1, NDX2
      double precision   SCLR1, SCLR2
      INTEGER            IJOB
*     ..
*     .. Array Arguments ..
      double precision   B( * ), X( * ), WORK( LDW,* ), WORK2( LDW2,* )
*     ..
*
*  Purpose
*  =======
*
*  GMRES solves the linear system Ax = b using the
*  Generalized Minimal Residual iterative method with preconditioning.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER.
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N.
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess; on exit, the iterated solution.
*
*  RESTRT  (input) INTEGER
*          Restart parameter, .ls. = N. This parameter controls the amount
*          of memory required for matrix WORK2.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDW,6+restrt).
*          Note that if the initial guess is the zero vector, then
*          storing the initial residual is not necessary.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW .gt. = max(1,N).
*
*  WORK2   (workspace) DOUBLE PRECISION array, dimension (LDW2,2*RESTRT+2).
*          This workspace is used for constructing and storing the
*          upper Hessenberg matrix. The two extra columns are used to
*          store the Givens rotation matrices.
*
*  LDW2    (input) INTEGER
*          The leading dimension of the array WORK2.
*          LDW2 .gt. = max(2,RESTRT+1).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable error tolerance.
*          On ouput, the norm of the residual vector if solution
*          approximated to tolerance, otherwise reset to input
*          tolerance.
*
*  INFO    (output) INTEGER
*          =  0:  successful exit
*          =  1:  maximum number of iterations performed;
*                 convergence not achieved.
*            -5: Erroneous NDX1/NDX2 in INIT call.
*            -6: Erroneous RLBL.
*
*  NDX1    (input/output) INTEGER.
*  NDX2    On entry in INIT call contain indices required by interface
*          level for stopping test.
*          All other times, used as output, to indicate indices into
*          WORK[] for the MATVEC, PSOLVE done by the interface level.
*
*  SCLR1   (output) DOUBLE PRECISION.
*  SCLR2   Used to pass the scalars used in MATVEC. Scalars are reqd because
*          original routines use dgemv.
*
*  IJOB    (input/output) INTEGER.
*          Used to communicate job code between the two levels.
*
*  ============================================================
*
*     .. Parameters ..
      double precision    ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      INTEGER             OFSET
      PARAMETER         ( OFSET = 1000 )
*     ..
*     .. Local Scalars ..
      INTEGER             I, MAXIT, AV, GIV, H, R, S, V, W, Y,
     $                    NEED1, NEED2
      double precision  ddot
      double precision  toz
      double precision    TMPVAL
      double precision    BNRM2, RNORM, TOL,
     $     dNRM2,
     $     dAPPROXRES

*
*     indicates where to resume from. Only valid when IJOB = 2!
      INTEGER RLBL
*
*     saving all.
      SAVE
*
*     ..
*     .. External Routines ..
      EXTERNAL     dAXPY, dCOPY, ddot, dNRM2, dSCAL
*     ..
*     .. Executable Statements ..
*
* Entry point, so test IJOB
      IF (IJOB .eq. 1) THEN
         GOTO 1
      ELSEIF (IJOB .eq. 2) THEN
*        here we do resumption handling
         IF (RLBL .eq. 2) GOTO 2
         IF (RLBL .eq. 3) GOTO 3
         IF (RLBL .eq. 4) GOTO 4
         IF (RLBL .eq. 5) GOTO 5
         IF (RLBL .eq. 6) GOTO 6
         IF (RLBL .eq. 7) GOTO 7
*        if neither of these, then error
         INFO = -6
         GOTO 200
      ENDIF
*
* init.
*****************
 1    CONTINUE
*****************
*
      INFO = 0
      MAXIT = ITER
      TOL   = RESID
*
*     Alias workspace columns.
*
      R   = 1
      S   = 2
      W   = 3
      Y   = 4
      AV  = 5
      V   = 6
*
      H   = 1
      GIV = H + RESTRT
*
*     Check if caller will need indexing info.
*
      IF( NDX1.NE.-1 ) THEN
         IF( NDX1.EQ.1 ) THEN
            NEED1 = ((R - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.2 ) THEN
            NEED1 = ((S - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.3 ) THEN
            NEED1 = ((W - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.4 ) THEN
            NEED1 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.5 ) THEN
            NEED1 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.6 ) THEN
            NEED1 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.V*OFSET ) .AND.
     $           ( NDX1.LE.V*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.GIV*OFSET ) .AND.
     $           ( NDX1.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED1 = NDX1
      ENDIF
*
      IF( NDX2.NE.-1 ) THEN
         IF( NDX2.EQ.1 ) THEN
            NEED2 = ((R - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.2 ) THEN
            NEED2 = ((S - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.3 ) THEN
            NEED2 = ((W - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.4 ) THEN
            NEED2 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.5 ) THEN
            NEED2 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.6 ) THEN
            NEED2 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.V*OFSET ) .AND.
     $           ( NDX2.LE.V*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.GIV*OFSET ) .AND.
     $           ( NDX2.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED2 = NDX2
      ENDIF
*
*     Set initial residual.
*
      CALL dCOPY( N, B, 1, WORK(1,R), 1 )
      IF ( dNRM2( N, X, 1 ).NE.ZERO ) THEN
*********CALL MATVEC( -ONE, X, ONE, WORK(1,R) )
*        Note: using X directly
         SCLR1 = -ONE
         SCLR2 = ONE
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*
*        Prepare for resumption & return
         RLBL = 2
         IJOB = 1
         RETURN
      ENDIF
*
*****************
 2    CONTINUE
*****************
*
      IF ( dNRM2( N, WORK(1,R), 1 ).LT.TOL ) GO TO 200
      BNRM2 = dNRM2( N, B, 1 )
      IF ( BNRM2.EQ.ZERO ) BNRM2 = ONE
*
      ITER = 0
   10 CONTINUE
*
         ITER = ITER + 1
*
*        Construct the first column of V, and initialize S to the
*        elementary vector E1 scaled by RNORM.
*
*********CALL PSOLVE( WORK( 1,V ), WORK( 1,R ) )
*
         NDX1 = ((V - 1) * LDW) + 1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 3
         IJOB = 2
         RETURN
*
*****************
 3       CONTINUE
*****************
*
         RNORM = dNRM2( N, WORK( 1,V ), 1 )
         toz = ONE/RNORM
         CALL dSCAL( N, toz, WORK( 1,V ), 1 )
         TMPVAL = RNORM
         CALL dELEMVEC( 1, N, TMPVAL, WORK( 1,S ) )
*
*         DO 50 I = 1, RESTRT
         i = 1
 49      if (i.gt.restrt) go to 50
************CALL MATVEC( ONE, WORK( 1,V+I-1 ), ZERO, WORK( 1,AV ) )
*
         NDX1 = ((V+I-1 - 1) * LDW) + 1
         NDX2 = ((AV    - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = ONE
         SCLR2 = ZERO
         RLBL = 4
         IJOB = 3
         RETURN
*
*****************
 4       CONTINUE
*****************
*
*********CALL PSOLVE( WORK( 1,W ), WORK( 1,AV ) )
*
         NDX1 = ((W  - 1) * LDW) + 1
         NDX2 = ((AV - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 5
         IJOB = 2
         RETURN
*
*****************
 5       CONTINUE
*****************
*
*           Construct I-th column of H so that it is orthnormal to
*           the previous I-1 columns.
*
            CALL dORTHOH( I, N, WORK2( 1,I+H-1 ), WORK( 1,V ), LDW,
     $                   WORK( 1,W ) )
*
            IF ( I.GT.0 )
*
*              Apply Givens rotations to the I-th column of H. This
*              effectively reduces the Hessenberg matrix to upper
*              triangular form during the RESTRT iterations.
*
     $         CALL dAPPLYGIVENS(I, WORK2( 1,I+H-1 ), WORK2( 1,GIV ),
     $                           LDW2 )
*
*           Approxiyate residual norm. Check tolerance. If okay, compute
*           final approximation vector X and quit.
*
            RESID = dAPPROXRES( I, WORK2( 1,I+H-1 ), WORK( 1,S ),
     $                         WORK2( 1,GIV ), LDW2 ) / BNRM2
            IF ( RESID.LE.TOL ) THEN
               CALL dUPDATE(I, N, X, WORK2( 1,H ), LDW2,
     $                     WORK(1,Y), WORK(1,S), WORK( 1,V ), LDW)
               GO TO 200
            ENDIF
            i = i + 1
            go to 49
   50    CONTINUE
         i = restrt
*
*        Compute current solution vector X.
*
         CALL dUPDATE(RESTRT, N, X, WORK2( 1,H ), LDW2,
     $               WORK(1,Y), WORK( 1,S ), WORK( 1,V ), LDW )
*
*        Compute residual vector R, find norm,
*        then check for tolerance.
*
         CALL dCOPY( N, B, 1, WORK( 1,R ), 1 )
*********CALL MATVEC( -ONE, X, ONE, WORK( 1,R ) )
*
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = -ONE
         SCLR2 = ONE
         RLBL = 6
         IJOB = 1
         RETURN
*
*****************
 6       CONTINUE
*****************
*
         WORK( I+1,S ) = dNRM2( N, WORK( 1,R ), 1 )
*
*********RESID = WORK( I+1,S ) / BNRM2
*********IF ( RESID.LE.TOL  ) GO TO 200
*
         NDX1 = NEED1
         NDX2 = NEED2
*        Prepare for resumption & return
         RLBL = 7
         IJOB = 4
         RETURN
*
*****************
 7       CONTINUE
*****************
         IF( INFO.EQ.1 ) GO TO 200
*
         IF ( ITER.EQ.MAXIT ) THEN
            INFO = 1
            GO TO 100
         ENDIF
*
         GO TO 10
*
  100 CONTINUE
*
*     Iteration fails.
*
      RLBL = -1
      IJOB = -1
      RETURN
*
  200 CONTINUE
*
*     Iteration successful; return.
*
      INFO = 0
      RLBL = -1
      IJOB = -1

      RETURN
*
*     End of GMRESREVCOM
*
      END
*     END SUBROUTINE dGMRESREVCOM
*
*     =========================================================
      SUBROUTINE dORTHOH( I, N, H, V, LDV, W )
*
      INTEGER            I, N, LDV
      double precision   H( * ), W( * ), V( LDV,* )
*
*     Construct the I-th column of the upper Hessenberg matrix H
*     using the Gram-Schmidt process on V and W.
*
      INTEGER            K
      double precision
     $     dNRM2, ONE
      PARAMETER        ( ONE = 1.0D+0 )
      double precision    ddot
      double precision    TMPVAL
      EXTERNAL         dAXPY, dCOPY, ddot, dNRM2, dSCAL
*
      DO 10 K = 1, I
         H( K ) = ddot( N, V( 1,K ), 1, W, 1 )
         CALL dAXPY( N, -H( K ), V( 1,K ), 1, W, 1 )
   10 CONTINUE
      H( I+1 ) = dNRM2( N, W, 1 )
      CALL dCOPY( N, W, 1, V( 1,I+1 ), 1 )
      TMPVAL = ONE / H( I+1 )
      CALL dSCAL( N, TMPVAL, V( 1,I+1 ), 1 )
*
      RETURN
*
      END
*     END SUBROUTINE dORTHOH
*     =========================================================
      SUBROUTINE dAPPLYGIVENS( I, H, GIVENS, LDG )
*
      INTEGER            I, LDG
      double precision   H( * ), GIVENS( LDG,* )
*
*     This routine applies a sequence of I-1 Givens rotations to
*     the I-th column of H. The Givens parameters are stored, so that
*     the first I-2 Givens rotation matrices are known. The I-1st
*     Givens rotation is computed using BLAS 1 routine DROTG. Each
*     rotation is applied to the 2x1 vector [H( J ), H( J+1 )]',
*     which results in H( J+1 ) = 0.
*
      INTEGER            J
*      DOUBLE PRECISION   TEMP
      EXTERNAL           dROTG
*
*     .. Executable Statements ..
*
*     Construct I-1st rotation matrix.
*
*     CALL dROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL dGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
*     Apply 1,...,I-1st rotation matrices to the I-th column of H.
*
      DO 10 J = 1, I-1
         CALL dROTVEC(H( J ), H( J+1 ), GIVENS( J,1 ), GIVENS( J,2 ))
*        TEMP     =  GIVENS( J,1 ) * H( J ) + GIVENS( J,2 ) * H( J+1 )
*        H( J+1 ) = -GIVENS( J,2 ) * H( J ) + GIVENS( J,1 ) * H( J+1 )
*        H( J ) = TEMP
 10   CONTINUE
      call dgetgiv( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      call drotvec( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      RETURN
*
      END
*     END SUBROUTINE dAPPLYGIVENS
*
*     ===============================================================
      double precision
     $     FUNCTION dAPPROXRES( I, H, S, GIVENS, LDG )
*
      INTEGER            I, LDG
      double precision   H( * ), S( * ), GIVENS( LDG,* )
*
*     This func allows the user to approximate the residual
*     using an updating scheme involving Givens rotations. The
*     rotation matrix is formed using [H( I ),H( I+1 )]' with the
*     intent of zeroing H( I+1 ), but here is applied to the 2x1
*     vector [S(I), S(I+1)]'.
*
      INTRINSIC          ABS
      EXTERNAL           dROTG
*
*     .. Executable Statements ..
*
*     CALL dROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL dGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      CALL dROTVEC( S( I ), S( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      dAPPROXRES = ABS( S( I+1 ) )
*
      RETURN
*
      END
*     END FUNCTION dAPPROXRES
*     ===============================================================
      SUBROUTINE dUPDATE( I, N, X, H, LDH, Y, S, V, LDV )
*
      INTEGER            N, I, J, LDH, LDV
      double precision   X( * ), Y( * ), S( * ), H( LDH,* ), V( LDV,* )
      EXTERNAL           dAXPY, dCOPY, dTRSV
*
*     Solve H*y = s for upper triangualar H.
*
      CALL dCOPY( I, S, 1, Y, 1 )
      CALL dTRSV( 'UPPER', 'NOTRANS', 'NONUNIT', I, H, LDH, Y, 1 )
*
*     Compute current solution vector X.
*
      DO 10 J = 1, I
         CALL dAXPY( N, Y( J ), V( 1,J ), 1, X, 1 )
   10 CONTINUE
*
      RETURN
*
      END
*     END SUBROUTINE dUPDATE
*
*     ===============================================================
      SUBROUTINE dGETGIV( A, B, C, S )
*
      double precision   A, B, C, S, TEMP, ZERO, ONE
      PARAMETER  (
     $     ZERO = 0.0,
     $     ONE = 1.0 )
*
      IF ( ABS( B ).EQ.ZERO ) THEN
         C = ONE
         S = ZERO
      ELSE IF ( ABS( B ).GT.ABS( A ) ) THEN
         TEMP = -A / B
         S = ONE / SQRT( ONE + abs(TEMP)**2 )
         C = TEMP * S
*         S = b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = -a / SQRT( abs(a)**2 + abs(b)**2 )
      ELSE
         TEMP = -B / A
         C = ONE / SQRT( ONE + abs(TEMP)**2 )
         S = TEMP * C
*         S = -b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = a / SQRT( abs(a)**2 + abs(b)**2 )
      ENDIF
*
      RETURN
*
      END
*     END SUBROUTINE dGETGIV
*
*     ================================================================
      SUBROUTINE dROTVEC( X, Y, C, S )
*
      double precision   X, Y, C, S, TEMP

*
      TEMP = (C) * X - (S) * Y
      Y    = S * X + C * Y
      X    = TEMP
*
      RETURN
*
      END
*     END SUBROUTINE dROTVEC
*
*     ===============================================================
      SUBROUTINE dELEMVEC( I, N, ALPHA, E )
*
*     Construct the I-th elementary vector E, scaled by ALPHA.
*
      INTEGER            I, J, N
      double precision   ALPHA, E( * )
*
*     .. Parameters ..
      double precision   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*
      DO 10 J = 1, N
         E( J ) = ZERO
   10 CONTINUE
      E( I ) = ALPHA
*
      RETURN
*
      END
*     END SUBROUTINE dELEMVEC

      SUBROUTINE cGMRESREVCOM(N, B, X, RESTRT, WORK, LDW, WORK2,
     $                  LDW2, ITER, RESID, INFO, NDX1, NDX2, SCLR1,
     $                  SCLR2, IJOB)
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     EiITERkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, RESTRT, LDW, LDW2, ITER, INFO
      real  RESID
      INTEGER            NDX1, NDX2
      complex   SCLR1, SCLR2
      INTEGER            IJOB
*     ..
*     .. Array Arguments ..
      complex   B( * ), X( * ), WORK( LDW,* ), WORK2( LDW2,* )
*     ..
*
*  Purpose
*  =======
*
*  GMRES solves the linear system Ax = b using the
*  Generalized Minimal Residual iterative method with preconditioning.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER.
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N.
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess; on exit, the iterated solution.
*
*  RESTRT  (input) INTEGER
*          Restart parameter, .ls. = N. This parameter controls the amount
*          of memory required for matrix WORK2.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDW,6+restrt).
*          Note that if the initial guess is the zero vector, then
*          storing the initial residual is not necessary.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW .gt. = max(1,N).
*
*  WORK2   (workspace) DOUBLE PRECISION array, dimension (LDW2,2*RESTRT+2).
*          This workspace is used for constructing and storing the
*          upper Hessenberg matrix. The two extra columns are used to
*          store the Givens rotation matrices.
*
*  LDW2    (input) INTEGER
*          The leading dimension of the array WORK2.
*          LDW2 .gt. = max(2,RESTRT+1).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable error tolerance.
*          On ouput, the norm of the residual vector if solution
*          approximated to tolerance, otherwise reset to input
*          tolerance.
*
*  INFO    (output) INTEGER
*          =  0:  successful exit
*          =  1:  maximum number of iterations performed;
*                 convergence not achieved.
*            -5: Erroneous NDX1/NDX2 in INIT call.
*            -6: Erroneous RLBL.
*
*  NDX1    (input/output) INTEGER.
*  NDX2    On entry in INIT call contain indices required by interface
*          level for stopping test.
*          All other times, used as output, to indicate indices into
*          WORK[] for the MATVEC, PSOLVE done by the interface level.
*
*  SCLR1   (output) DOUBLE PRECISION.
*  SCLR2   Used to pass the scalars used in MATVEC. Scalars are reqd because
*          original routines use dgemv.
*
*  IJOB    (input/output) INTEGER.
*          Used to communicate job code between the two levels.
*
*  ============================================================
*
*     .. Parameters ..
      real    ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      INTEGER             OFSET
      PARAMETER         ( OFSET = 1000 )
*     ..
*     .. Local Scalars ..
      INTEGER             I, MAXIT, AV, GIV, H, R, S, V, W, Y,
     $                    NEED1, NEED2
      complex  wcdotc
      complex  toz
      complex    TMPVAL
      real    BNRM2, RNORM, TOL,
     $     wscNRM2,
     $     wscAPPROXRES

*
*     indicates where to resume from. Only valid when IJOB = 2!
      INTEGER RLBL
*
*     saving all.
      SAVE
*
*     ..
*     .. External Routines ..
      EXTERNAL     cAXPY, cCOPY, wcdotc, wscNRM2, cSCAL
*     ..
*     .. Executable Statements ..
*
* Entry point, so test IJOB
      IF (IJOB .eq. 1) THEN
         GOTO 1
      ELSEIF (IJOB .eq. 2) THEN
*        here we do resumption handling
         IF (RLBL .eq. 2) GOTO 2
         IF (RLBL .eq. 3) GOTO 3
         IF (RLBL .eq. 4) GOTO 4
         IF (RLBL .eq. 5) GOTO 5
         IF (RLBL .eq. 6) GOTO 6
         IF (RLBL .eq. 7) GOTO 7
*        if neither of these, then error
         INFO = -6
         GOTO 200
      ENDIF
*
* init.
*****************
 1    CONTINUE
*****************
*
      INFO = 0
      MAXIT = ITER
      TOL   = RESID
*
*     Alias workspace columns.
*
      R   = 1
      S   = 2
      W   = 3
      Y   = 4
      AV  = 5
      V   = 6
*
      H   = 1
      GIV = H + RESTRT
*
*     Check if caller will need indexing info.
*
      IF( NDX1.NE.-1 ) THEN
         IF( NDX1.EQ.1 ) THEN
            NEED1 = ((R - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.2 ) THEN
            NEED1 = ((S - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.3 ) THEN
            NEED1 = ((W - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.4 ) THEN
            NEED1 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.5 ) THEN
            NEED1 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.6 ) THEN
            NEED1 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.V*OFSET ) .AND.
     $           ( NDX1.LE.V*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.GIV*OFSET ) .AND.
     $           ( NDX1.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED1 = NDX1
      ENDIF
*
      IF( NDX2.NE.-1 ) THEN
         IF( NDX2.EQ.1 ) THEN
            NEED2 = ((R - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.2 ) THEN
            NEED2 = ((S - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.3 ) THEN
            NEED2 = ((W - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.4 ) THEN
            NEED2 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.5 ) THEN
            NEED2 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.6 ) THEN
            NEED2 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.V*OFSET ) .AND.
     $           ( NDX2.LE.V*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.GIV*OFSET ) .AND.
     $           ( NDX2.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED2 = NDX2
      ENDIF
*
*     Set initial residual.
*
      CALL cCOPY( N, B, 1, WORK(1,R), 1 )
      IF ( wscNRM2( N, X, 1 ).NE.ZERO ) THEN
*********CALL MATVEC( -ONE, X, ONE, WORK(1,R) )
*        Note: using X directly
         SCLR1 = -ONE
         SCLR2 = ONE
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*
*        Prepare for resumption & return
         RLBL = 2
         IJOB = 1
         RETURN
      ENDIF
*
*****************
 2    CONTINUE
*****************
*
      IF ( wscNRM2( N, WORK(1,R), 1 ).LT.TOL ) GO TO 200
      BNRM2 = wscNRM2( N, B, 1 )
      IF ( BNRM2.EQ.ZERO ) BNRM2 = ONE
*
      ITER = 0
   10 CONTINUE
*
         ITER = ITER + 1
*
*        Construct the first column of V, and initialize S to the
*        elementary vector E1 scaled by RNORM.
*
*********CALL PSOLVE( WORK( 1,V ), WORK( 1,R ) )
*
         NDX1 = ((V - 1) * LDW) + 1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 3
         IJOB = 2
         RETURN
*
*****************
 3       CONTINUE
*****************
*
         RNORM = wscNRM2( N, WORK( 1,V ), 1 )
         toz = ONE/RNORM
         CALL cSCAL( N, toz, WORK( 1,V ), 1 )
         TMPVAL = RNORM
         CALL cELEMVEC( 1, N, TMPVAL, WORK( 1,S ) )
*
*         DO 50 I = 1, RESTRT
         i = 1
 49      if (i.gt.restrt) go to 50
************CALL MATVEC( ONE, WORK( 1,V+I-1 ), ZERO, WORK( 1,AV ) )
*
         NDX1 = ((V+I-1 - 1) * LDW) + 1
         NDX2 = ((AV    - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = ONE
         SCLR2 = ZERO
         RLBL = 4
         IJOB = 3
         RETURN
*
*****************
 4       CONTINUE
*****************
*
*********CALL PSOLVE( WORK( 1,W ), WORK( 1,AV ) )
*
         NDX1 = ((W  - 1) * LDW) + 1
         NDX2 = ((AV - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 5
         IJOB = 2
         RETURN
*
*****************
 5       CONTINUE
*****************
*
*           Construct I-th column of H so that it is orthnormal to
*           the previous I-1 columns.
*
            CALL cORTHOH( I, N, WORK2( 1,I+H-1 ), WORK( 1,V ), LDW,
     $                   WORK( 1,W ) )
*
            IF ( I.GT.0 )
*
*              Apply Givens rotations to the I-th column of H. This
*              effectively reduces the Hessenberg matrix to upper
*              triangular form during the RESTRT iterations.
*
     $         CALL cAPPLYGIVENS(I, WORK2( 1,I+H-1 ), WORK2( 1,GIV ),
     $                           LDW2 )
*
*           Approxiyate residual norm. Check tolerance. If okay, compute
*           final approximation vector X and quit.
*
            RESID = wscAPPROXRES( I, WORK2( 1,I+H-1 ), WORK( 1,S ),
     $                         WORK2( 1,GIV ), LDW2 ) / BNRM2
            IF ( RESID.LE.TOL ) THEN
               CALL cUPDATE(I, N, X, WORK2( 1,H ), LDW2,
     $                     WORK(1,Y), WORK(1,S), WORK( 1,V ), LDW)
               GO TO 200
            ENDIF
            i = i + 1
            go to 49
   50    CONTINUE
         i = restrt
*
*        Compute current solution vector X.
*
         CALL cUPDATE(RESTRT, N, X, WORK2( 1,H ), LDW2,
     $               WORK(1,Y), WORK( 1,S ), WORK( 1,V ), LDW )
*
*        Compute residual vector R, find norm,
*        then check for tolerance.
*
         CALL cCOPY( N, B, 1, WORK( 1,R ), 1 )
*********CALL MATVEC( -ONE, X, ONE, WORK( 1,R ) )
*
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = -ONE
         SCLR2 = ONE
         RLBL = 6
         IJOB = 1
         RETURN
*
*****************
 6       CONTINUE
*****************
*
         WORK( I+1,S ) = wscNRM2( N, WORK( 1,R ), 1 )
*
*********RESID = WORK( I+1,S ) / BNRM2
*********IF ( RESID.LE.TOL  ) GO TO 200
*
         NDX1 = NEED1
         NDX2 = NEED2
*        Prepare for resumption & return
         RLBL = 7
         IJOB = 4
         RETURN
*
*****************
 7       CONTINUE
*****************
         IF( INFO.EQ.1 ) GO TO 200
*
         IF ( ITER.EQ.MAXIT ) THEN
            INFO = 1
            GO TO 100
         ENDIF
*
         GO TO 10
*
  100 CONTINUE
*
*     Iteration fails.
*
      RLBL = -1
      IJOB = -1
      RETURN
*
  200 CONTINUE
*
*     Iteration successful; return.
*
      INFO = 0
      RLBL = -1
      IJOB = -1

      RETURN
*
*     End of GMRESREVCOM
*
      END
*     END SUBROUTINE cGMRESREVCOM
*
*     =========================================================
      SUBROUTINE cORTHOH( I, N, H, V, LDV, W )
*
      INTEGER            I, N, LDV
      complex   H( * ), W( * ), V( LDV,* )
*
*     Construct the I-th column of the upper Hessenberg matrix H
*     using the Gram-Schmidt process on V and W.
*
      INTEGER            K
      real
     $     wscNRM2, ONE
      PARAMETER        ( ONE = 1.0D+0 )
      complex    wcdotc
      complex    TMPVAL
      EXTERNAL         cAXPY, cCOPY, wcdotc, wscNRM2, cSCAL
*
      DO 10 K = 1, I
         H( K ) = wcdotc( N, V( 1,K ), 1, W, 1 )
         CALL cAXPY( N, -H( K ), V( 1,K ), 1, W, 1 )
   10 CONTINUE
      H( I+1 ) = wscNRM2( N, W, 1 )
      CALL cCOPY( N, W, 1, V( 1,I+1 ), 1 )
      TMPVAL = ONE / H( I+1 )
      CALL cSCAL( N, TMPVAL, V( 1,I+1 ), 1 )
*
      RETURN
*
      END
*     END SUBROUTINE cORTHOH
*     =========================================================
      SUBROUTINE cAPPLYGIVENS( I, H, GIVENS, LDG )
*
      INTEGER            I, LDG
      complex   H( * ), GIVENS( LDG,* )
*
*     This routine applies a sequence of I-1 Givens rotations to
*     the I-th column of H. The Givens parameters are stored, so that
*     the first I-2 Givens rotation matrices are known. The I-1st
*     Givens rotation is computed using BLAS 1 routine DROTG. Each
*     rotation is applied to the 2x1 vector [H( J ), H( J+1 )]',
*     which results in H( J+1 ) = 0.
*
      INTEGER            J
*      DOUBLE PRECISION   TEMP
      EXTERNAL           cROTG
*
*     .. Executable Statements ..
*
*     Construct I-1st rotation matrix.
*
*     CALL cROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL cGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
*     Apply 1,...,I-1st rotation matrices to the I-th column of H.
*
      DO 10 J = 1, I-1
         CALL cROTVEC(H( J ), H( J+1 ), GIVENS( J,1 ), GIVENS( J,2 ))
*        TEMP     =  GIVENS( J,1 ) * H( J ) + GIVENS( J,2 ) * H( J+1 )
*        H( J+1 ) = -GIVENS( J,2 ) * H( J ) + GIVENS( J,1 ) * H( J+1 )
*        H( J ) = TEMP
 10   CONTINUE
      call cgetgiv( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      call crotvec( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      RETURN
*
      END
*     END SUBROUTINE cAPPLYGIVENS
*
*     ===============================================================
      real
     $     FUNCTION wscAPPROXRES( I, H, S, GIVENS, LDG )
*
      INTEGER            I, LDG
      complex   H( * ), S( * ), GIVENS( LDG,* )
*
*     This func allows the user to approximate the residual
*     using an updating scheme involving Givens rotations. The
*     rotation matrix is formed using [H( I ),H( I+1 )]' with the
*     intent of zeroing H( I+1 ), but here is applied to the 2x1
*     vector [S(I), S(I+1)]'.
*
      INTRINSIC          ABS
      EXTERNAL           cROTG
*
*     .. Executable Statements ..
*
*     CALL cROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL cGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      CALL cROTVEC( S( I ), S( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      wscAPPROXRES = ABS( S( I+1 ) )
*
      RETURN
*
      END
*     END FUNCTION wscAPPROXRES
*     ===============================================================
      SUBROUTINE cUPDATE( I, N, X, H, LDH, Y, S, V, LDV )
*
      INTEGER            N, I, J, LDH, LDV
      complex   X( * ), Y( * ), S( * ), H( LDH,* ), V( LDV,* )
      EXTERNAL           cAXPY, cCOPY, cTRSV
*
*     Solve H*y = s for upper triangualar H.
*
      CALL cCOPY( I, S, 1, Y, 1 )
      CALL cTRSV( 'UPPER', 'NOTRANS', 'NONUNIT', I, H, LDH, Y, 1 )
*
*     Compute current solution vector X.
*
      DO 10 J = 1, I
         CALL cAXPY( N, Y( J ), V( 1,J ), 1, X, 1 )
   10 CONTINUE
*
      RETURN
*
      END
*     END SUBROUTINE cUPDATE
*
*     ===============================================================
      SUBROUTINE cGETGIV( A, B, C, S )
*
      complex   A, B, C, S, TEMP, ZERO, ONE
      PARAMETER  (
     $     ZERO = 0.0,
     $     ONE = 1.0 )
*
      IF ( ABS( B ).EQ.ZERO ) THEN
         C = ONE
         S = ZERO
      ELSE IF ( ABS( B ).GT.ABS( A ) ) THEN
         TEMP = -A / B
         S = ONE / SQRT( ONE + abs(TEMP)**2 )
         C = TEMP * S
*         S = b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = -a / SQRT( abs(a)**2 + abs(b)**2 )
      ELSE
         TEMP = -B / A
         C = ONE / SQRT( ONE + abs(TEMP)**2 )
         S = TEMP * C
*         S = -b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = a / SQRT( abs(a)**2 + abs(b)**2 )
      ENDIF
*
      RETURN
*
      END
*     END SUBROUTINE cGETGIV
*
*     ================================================================
      SUBROUTINE cROTVEC( X, Y, C, S )
*
      complex   X, Y, C, S, TEMP

*
      TEMP = conjg(C) * X - conjg(S) * Y
      Y    = S * X + C * Y
      X    = TEMP
*
      RETURN
*
      END
*     END SUBROUTINE cROTVEC
*
*     ===============================================================
      SUBROUTINE cELEMVEC( I, N, ALPHA, E )
*
*     Construct the I-th elementary vector E, scaled by ALPHA.
*
      INTEGER            I, J, N
      complex   ALPHA, E( * )
*
*     .. Parameters ..
      real   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*
      DO 10 J = 1, N
         E( J ) = ZERO
   10 CONTINUE
      E( I ) = ALPHA
*
      RETURN
*
      END
*     END SUBROUTINE cELEMVEC

      SUBROUTINE zGMRESREVCOM(N, B, X, RESTRT, WORK, LDW, WORK2,
     $                  LDW2, ITER, RESID, INFO, NDX1, NDX2, SCLR1,
     $                  SCLR2, IJOB)
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     EiITERkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, RESTRT, LDW, LDW2, ITER, INFO
      double precision  RESID
      INTEGER            NDX1, NDX2
      double complex   SCLR1, SCLR2
      INTEGER            IJOB
*     ..
*     .. Array Arguments ..
      double complex   B( * ), X( * ), WORK( LDW,* ), WORK2( LDW2,* )
*     ..
*
*  Purpose
*  =======
*
*  GMRES solves the linear system Ax = b using the
*  Generalized Minimal Residual iterative method with preconditioning.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER.
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N.
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess; on exit, the iterated solution.
*
*  RESTRT  (input) INTEGER
*          Restart parameter, .ls. = N. This parameter controls the amount
*          of memory required for matrix WORK2.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDW,6+restrt).
*          Note that if the initial guess is the zero vector, then
*          storing the initial residual is not necessary.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW .gt. = max(1,N).
*
*  WORK2   (workspace) DOUBLE PRECISION array, dimension (LDW2,2*RESTRT+2).
*          This workspace is used for constructing and storing the
*          upper Hessenberg matrix. The two extra columns are used to
*          store the Givens rotation matrices.
*
*  LDW2    (input) INTEGER
*          The leading dimension of the array WORK2.
*          LDW2 .gt. = max(2,RESTRT+1).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable error tolerance.
*          On ouput, the norm of the residual vector if solution
*          approximated to tolerance, otherwise reset to input
*          tolerance.
*
*  INFO    (output) INTEGER
*          =  0:  successful exit
*          =  1:  maximum number of iterations performed;
*                 convergence not achieved.
*            -5: Erroneous NDX1/NDX2 in INIT call.
*            -6: Erroneous RLBL.
*
*  NDX1    (input/output) INTEGER.
*  NDX2    On entry in INIT call contain indices required by interface
*          level for stopping test.
*          All other times, used as output, to indicate indices into
*          WORK[] for the MATVEC, PSOLVE done by the interface level.
*
*  SCLR1   (output) DOUBLE PRECISION.
*  SCLR2   Used to pass the scalars used in MATVEC. Scalars are reqd because
*          original routines use dgemv.
*
*  IJOB    (input/output) INTEGER.
*          Used to communicate job code between the two levels.
*
*  ============================================================
*
*     .. Parameters ..
      double precision    ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      INTEGER             OFSET
      PARAMETER         ( OFSET = 1000 )
*     ..
*     .. Local Scalars ..
      INTEGER             I, MAXIT, AV, GIV, H, R, S, V, W, Y,
     $                    NEED1, NEED2
      double complex  wzdotc
      double complex  toz
      double complex    TMPVAL
      double precision    BNRM2, RNORM, TOL,
     $     dzNRM2,
     $     dzAPPROXRES

*
*     indicates where to resume from. Only valid when IJOB = 2!
      INTEGER RLBL
*
*     saving all.
      SAVE
*
*     ..
*     .. External Routines ..
      EXTERNAL     zAXPY, zCOPY, wzdotc, dzNRM2, zSCAL
*     ..
*     .. Executable Statements ..
*
* Entry point, so test IJOB
      IF (IJOB .eq. 1) THEN
         GOTO 1
      ELSEIF (IJOB .eq. 2) THEN
*        here we do resumption handling
         IF (RLBL .eq. 2) GOTO 2
         IF (RLBL .eq. 3) GOTO 3
         IF (RLBL .eq. 4) GOTO 4
         IF (RLBL .eq. 5) GOTO 5
         IF (RLBL .eq. 6) GOTO 6
         IF (RLBL .eq. 7) GOTO 7
*        if neither of these, then error
         INFO = -6
         GOTO 200
      ENDIF
*
* init.
*****************
 1    CONTINUE
*****************
*
      INFO = 0
      MAXIT = ITER
      TOL   = RESID
*
*     Alias workspace columns.
*
      R   = 1
      S   = 2
      W   = 3
      Y   = 4
      AV  = 5
      V   = 6
*
      H   = 1
      GIV = H + RESTRT
*
*     Check if caller will need indexing info.
*
      IF( NDX1.NE.-1 ) THEN
         IF( NDX1.EQ.1 ) THEN
            NEED1 = ((R - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.2 ) THEN
            NEED1 = ((S - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.3 ) THEN
            NEED1 = ((W - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.4 ) THEN
            NEED1 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.5 ) THEN
            NEED1 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX1.EQ.6 ) THEN
            NEED1 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.V*OFSET ) .AND.
     $           ( NDX1.LE.V*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX1.GT.GIV*OFSET ) .AND.
     $           ( NDX1.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED1 = ((NDX1-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED1 = NDX1
      ENDIF
*
      IF( NDX2.NE.-1 ) THEN
         IF( NDX2.EQ.1 ) THEN
            NEED2 = ((R - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.2 ) THEN
            NEED2 = ((S - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.3 ) THEN
            NEED2 = ((W - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.4 ) THEN
            NEED2 = ((Y - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.5 ) THEN
            NEED2 = ((AV - 1) * LDW) + 1
         ELSEIF( NDX2.EQ.6 ) THEN
            NEED2 = ((V - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.V*OFSET ) .AND.
     $           ( NDX2.LE.V*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-V*OFSET - 1) * LDW) + 1
         ELSEIF( ( NDX2.GT.GIV*OFSET ) .AND.
     $           ( NDX2.LE.GIV*OFSET+RESTRT ) ) THEN
            NEED2 = ((NDX2-GIV*OFSET - 1) * LDW) + 1
         ELSE
*           report error
            INFO = -5
            GO TO 100
         ENDIF
      ELSE
         NEED2 = NDX2
      ENDIF
*
*     Set initial residual.
*
      CALL zCOPY( N, B, 1, WORK(1,R), 1 )
      IF ( dzNRM2( N, X, 1 ).NE.ZERO ) THEN
*********CALL MATVEC( -ONE, X, ONE, WORK(1,R) )
*        Note: using X directly
         SCLR1 = -ONE
         SCLR2 = ONE
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*
*        Prepare for resumption & return
         RLBL = 2
         IJOB = 1
         RETURN
      ENDIF
*
*****************
 2    CONTINUE
*****************
*
      IF ( dzNRM2( N, WORK(1,R), 1 ).LT.TOL ) GO TO 200
      BNRM2 = dzNRM2( N, B, 1 )
      IF ( BNRM2.EQ.ZERO ) BNRM2 = ONE
*
      ITER = 0
   10 CONTINUE
*
         ITER = ITER + 1
*
*        Construct the first column of V, and initialize S to the
*        elementary vector E1 scaled by RNORM.
*
*********CALL PSOLVE( WORK( 1,V ), WORK( 1,R ) )
*
         NDX1 = ((V - 1) * LDW) + 1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 3
         IJOB = 2
         RETURN
*
*****************
 3       CONTINUE
*****************
*
         RNORM = dzNRM2( N, WORK( 1,V ), 1 )
         toz = ONE/RNORM
         CALL zSCAL( N, toz, WORK( 1,V ), 1 )
         TMPVAL = RNORM
         CALL zELEMVEC( 1, N, TMPVAL, WORK( 1,S ) )
*
*         DO 50 I = 1, RESTRT
         i = 1
 49      if (i.gt.restrt) go to 50
************CALL MATVEC( ONE, WORK( 1,V+I-1 ), ZERO, WORK( 1,AV ) )
*
         NDX1 = ((V+I-1 - 1) * LDW) + 1
         NDX2 = ((AV    - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = ONE
         SCLR2 = ZERO
         RLBL = 4
         IJOB = 3
         RETURN
*
*****************
 4       CONTINUE
*****************
*
*********CALL PSOLVE( WORK( 1,W ), WORK( 1,AV ) )
*
         NDX1 = ((W  - 1) * LDW) + 1
         NDX2 = ((AV - 1) * LDW) + 1
*        Prepare for return & return
         RLBL = 5
         IJOB = 2
         RETURN
*
*****************
 5       CONTINUE
*****************
*
*           Construct I-th column of H so that it is orthnormal to
*           the previous I-1 columns.
*
            CALL zORTHOH( I, N, WORK2( 1,I+H-1 ), WORK( 1,V ), LDW,
     $                   WORK( 1,W ) )
*
            IF ( I.GT.0 )
*
*              Apply Givens rotations to the I-th column of H. This
*              effectively reduces the Hessenberg matrix to upper
*              triangular form during the RESTRT iterations.
*
     $         CALL zAPPLYGIVENS(I, WORK2( 1,I+H-1 ), WORK2( 1,GIV ),
     $                           LDW2 )
*
*           Approxiyate residual norm. Check tolerance. If okay, compute
*           final approximation vector X and quit.
*
            RESID = dzAPPROXRES( I, WORK2( 1,I+H-1 ), WORK( 1,S ),
     $                         WORK2( 1,GIV ), LDW2 ) / BNRM2
            IF ( RESID.LE.TOL ) THEN
               CALL zUPDATE(I, N, X, WORK2( 1,H ), LDW2,
     $                     WORK(1,Y), WORK(1,S), WORK( 1,V ), LDW)
               GO TO 200
            ENDIF
            i = i + 1
            go to 49
   50    CONTINUE
         i = restrt
*
*        Compute current solution vector X.
*
         CALL zUPDATE(RESTRT, N, X, WORK2( 1,H ), LDW2,
     $               WORK(1,Y), WORK( 1,S ), WORK( 1,V ), LDW )
*
*        Compute residual vector R, find norm,
*        then check for tolerance.
*
         CALL zCOPY( N, B, 1, WORK( 1,R ), 1 )
*********CALL MATVEC( -ONE, X, ONE, WORK( 1,R ) )
*
         NDX1 = -1
         NDX2 = ((R - 1) * LDW) + 1
*        Prepare for return & return
         SCLR1 = -ONE
         SCLR2 = ONE
         RLBL = 6
         IJOB = 1
         RETURN
*
*****************
 6       CONTINUE
*****************
*
         WORK( I+1,S ) = dzNRM2( N, WORK( 1,R ), 1 )
*
*********RESID = WORK( I+1,S ) / BNRM2
*********IF ( RESID.LE.TOL  ) GO TO 200
*
         NDX1 = NEED1
         NDX2 = NEED2
*        Prepare for resumption & return
         RLBL = 7
         IJOB = 4
         RETURN
*
*****************
 7       CONTINUE
*****************
         IF( INFO.EQ.1 ) GO TO 200
*
         IF ( ITER.EQ.MAXIT ) THEN
            INFO = 1
            GO TO 100
         ENDIF
*
         GO TO 10
*
  100 CONTINUE
*
*     Iteration fails.
*
      RLBL = -1
      IJOB = -1
      RETURN
*
  200 CONTINUE
*
*     Iteration successful; return.
*
      INFO = 0
      RLBL = -1
      IJOB = -1

      RETURN
*
*     End of GMRESREVCOM
*
      END
*     END SUBROUTINE zGMRESREVCOM
*
*     =========================================================
      SUBROUTINE zORTHOH( I, N, H, V, LDV, W )
*
      INTEGER            I, N, LDV
      double complex   H( * ), W( * ), V( LDV,* )
*
*     Construct the I-th column of the upper Hessenberg matrix H
*     using the Gram-Schmidt process on V and W.
*
      INTEGER            K
      double precision
     $     dzNRM2, ONE
      PARAMETER        ( ONE = 1.0D+0 )
      double complex    wzdotc
      double complex    TMPVAL
      EXTERNAL         zAXPY, zCOPY, wzdotc, dzNRM2, zSCAL
*
      DO 10 K = 1, I
         H( K ) = wzdotc( N, V( 1,K ), 1, W, 1 )
         CALL zAXPY( N, -H( K ), V( 1,K ), 1, W, 1 )
   10 CONTINUE
      H( I+1 ) = dzNRM2( N, W, 1 )
      CALL zCOPY( N, W, 1, V( 1,I+1 ), 1 )
      TMPVAL = ONE / H( I+1 )
      CALL zSCAL( N, TMPVAL, V( 1,I+1 ), 1 )
*
      RETURN
*
      END
*     END SUBROUTINE zORTHOH
*     =========================================================
      SUBROUTINE zAPPLYGIVENS( I, H, GIVENS, LDG )
*
      INTEGER            I, LDG
      double complex   H( * ), GIVENS( LDG,* )
*
*     This routine applies a sequence of I-1 Givens rotations to
*     the I-th column of H. The Givens parameters are stored, so that
*     the first I-2 Givens rotation matrices are known. The I-1st
*     Givens rotation is computed using BLAS 1 routine DROTG. Each
*     rotation is applied to the 2x1 vector [H( J ), H( J+1 )]',
*     which results in H( J+1 ) = 0.
*
      INTEGER            J
*      DOUBLE PRECISION   TEMP
      EXTERNAL           zROTG
*
*     .. Executable Statements ..
*
*     Construct I-1st rotation matrix.
*
*     CALL zROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL zGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
*     Apply 1,...,I-1st rotation matrices to the I-th column of H.
*
      DO 10 J = 1, I-1
         CALL zROTVEC(H( J ), H( J+1 ), GIVENS( J,1 ), GIVENS( J,2 ))
*        TEMP     =  GIVENS( J,1 ) * H( J ) + GIVENS( J,2 ) * H( J+1 )
*        H( J+1 ) = -GIVENS( J,2 ) * H( J ) + GIVENS( J,1 ) * H( J+1 )
*        H( J ) = TEMP
 10   CONTINUE
      call zgetgiv( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      call zrotvec( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      RETURN
*
      END
*     END SUBROUTINE zAPPLYGIVENS
*
*     ===============================================================
      double precision
     $     FUNCTION dzAPPROXRES( I, H, S, GIVENS, LDG )
*
      INTEGER            I, LDG
      double complex   H( * ), S( * ), GIVENS( LDG,* )
*
*     This func allows the user to approximate the residual
*     using an updating scheme involving Givens rotations. The
*     rotation matrix is formed using [H( I ),H( I+1 )]' with the
*     intent of zeroing H( I+1 ), but here is applied to the 2x1
*     vector [S(I), S(I+1)]'.
*
      INTRINSIC          ABS
      EXTERNAL           zROTG
*
*     .. Executable Statements ..
*
*     CALL zROTG( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*      CALL zGETGIV( H( I ), H( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
      CALL zROTVEC( S( I ), S( I+1 ), GIVENS( I,1 ), GIVENS( I,2 ) )
*
      dzAPPROXRES = ABS( S( I+1 ) )
*
      RETURN
*
      END
*     END FUNCTION dzAPPROXRES
*     ===============================================================
      SUBROUTINE zUPDATE( I, N, X, H, LDH, Y, S, V, LDV )
*
      INTEGER            N, I, J, LDH, LDV
      double complex   X( * ), Y( * ), S( * ), H( LDH,* ), V( LDV,* )
      EXTERNAL           zAXPY, zCOPY, zTRSV
*
*     Solve H*y = s for upper triangualar H.
*
      CALL zCOPY( I, S, 1, Y, 1 )
      CALL zTRSV( 'UPPER', 'NOTRANS', 'NONUNIT', I, H, LDH, Y, 1 )
*
*     Compute current solution vector X.
*
      DO 10 J = 1, I
         CALL zAXPY( N, Y( J ), V( 1,J ), 1, X, 1 )
   10 CONTINUE
*
      RETURN
*
      END
*     END SUBROUTINE zUPDATE
*
*     ===============================================================
      SUBROUTINE zGETGIV( A, B, C, S )
*
      double complex   A, B, C, S, TEMP, ZERO, ONE
      PARAMETER  (
     $     ZERO = 0.0,
     $     ONE = 1.0 )
*
      IF ( ABS( B ).EQ.ZERO ) THEN
         C = ONE
         S = ZERO
      ELSE IF ( ABS( B ).GT.ABS( A ) ) THEN
         TEMP = -A / B
         S = ONE / SQRT( ONE + abs(TEMP)**2 )
         C = TEMP * S
*         S = b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = -a / SQRT( abs(a)**2 + abs(b)**2 )
      ELSE
         TEMP = -B / A
         C = ONE / SQRT( ONE + abs(TEMP)**2 )
         S = TEMP * C
*         S = -b / SQRT( abs(a)**2 + abs(b)**2 )
*         C = a / SQRT( abs(a)**2 + abs(b)**2 )
      ENDIF
*
      RETURN
*
      END
*     END SUBROUTINE zGETGIV
*
*     ================================================================
      SUBROUTINE zROTVEC( X, Y, C, S )
*
      double complex   X, Y, C, S, TEMP

*
      TEMP = conjg(C) * X - conjg(S) * Y
      Y    = S * X + C * Y
      X    = TEMP
*
      RETURN
*
      END
*     END SUBROUTINE zROTVEC
*
*     ===============================================================
      SUBROUTINE zELEMVEC( I, N, ALPHA, E )
*
*     Construct the I-th elementary vector E, scaled by ALPHA.
*
      INTEGER            I, J, N
      double complex   ALPHA, E( * )
*
*     .. Parameters ..
      double precision   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
*
      DO 10 J = 1, N
         E( J ) = ZERO
   10 CONTINUE
      E( I ) = ALPHA
*
      RETURN
*
      END
*     END SUBROUTINE zELEMVEC


!-----subroutine---------------------------------------------g.guidati--
!
      subroutine INICON
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             initialise constants
!
!.......................................................................
!               declarations
!.......................................................................
      USE TINoiseGeneric
      USE TINoiseGeo

!.......................................................................
!     initialise the whole stuff
!.......................................................................

      kappa  = 1.4
      !csound = 340.0d0    !!!!!!!!!!!!!

! ng     = 4
      pi2    = 2.0d0 * dacos(-1.0d0)
      pi     = dacos(-1.0d0)
      pi2i   = 1.0d0 / (2.0d0 * dacos(-1.0d0))

      imag   = (0.0d0,1.0d0)

      td(1,1) = 0.0
      td(1,2) = -dsqrt(1.0d0/3.0d0)
      td(2,2) = +dsqrt(1.0d0/3.0d0)
      td(1,3) = -dsqrt(3.0d0/5.0d0)
      td(2,3) = 0.0
      td(3,3) = +dsqrt(3.0d0/5.0d0)
      td(1,4) = -dsqrt((15.0d0+2.0d0*dsqrt(30.0d0))/35.0d0)
      td(2,4) = -dsqrt((15.0d0-2.0d0*dsqrt(30.0d0))/35.0d0)
      td(3,4) = +dsqrt((15.0d0-2.0d0*dsqrt(30.0d0))/35.0d0)
      td(4,4) = +dsqrt((15.0d0+2.0d0*dsqrt(30.0d0))/35.0d0)
      Ad(1,1) = 2.0
      Ad(1,2) = 1.0
      Ad(2,2) = 1.0
      Ad(1,3) = 5./9.
      Ad(2,3) = 8./9.
      Ad(3,3) = 5./9.
      Ad(2,4) = (1./3.*td(1,4)**2.-0.2)/(td(2,4)**2.*td(1,4)**2. &
                -td(2,4)**4.)
      Ad(1,4) = (1./3.-Ad(2,4)*td(2,4)**2.)/td(1,4)**2.
      Ad(3,4) = Ad(2,4)
      Ad(4,4) = Ad(1,4)

!jo   Rueckwaertsdifferenz
      dst(-2,-2) =   3.0d0 / 12.0d0
      dst(-1,-2) = -16.0d0 / 12.0d0
      dst( 0,-2) =  36.0d0 / 12.0d0
      dst( 1,-2) = -48.0d0 / 12.0d0
      dst( 2,-2) =  25.0d0 / 12.0d0

!jo   gemischte Rueckwaertsdifferenz
      dst(-2,-1) =  -1.0d0 / 12.0d0
      dst(-1,-1) =   6.0d0 / 12.0d0
      dst( 0,-1) = -18.0d0 / 12.0d0
      dst( 1,-1) =  10.0d0 / 12.0d0
      dst( 2,-1) =   3.0d0 / 12.0d0

!jo   zentrale Differenz
      dst(-2, 0) =   1.0d0 / 12.0d0
      dst(-1, 0) =  -8.0d0 / 12.0d0
      dst( 0, 0) =   0.0d0 / 12.0d0
      dst( 1, 0) =   8.0d0 / 12.0d0
      dst( 2, 0) =  -1.0d0 / 12.0d0

!jo   gemischte Vorwaertsdifferenz
      dst(-2, 1) =  -3.0d0 / 12.0d0
      dst(-1, 1) = -10.0d0 / 12.0d0
      dst( 0, 1) =  18.0d0 / 12.0d0
      dst( 1, 1) =  -6.0d0 / 12.0d0
      dst( 2, 1) =   1.0d0 / 12.0d0

!jo   Vorwaertsdifferenz
      dst(-2, 2) = -25.0d0 / 12.0d0
      dst(-1, 2) =  48.0d0 / 12.0d0
      dst( 0, 2) = -36.0d0 / 12.0d0
      dst( 1, 2) =  16.0d0 / 12.0d0
      dst( 2, 2) =  -3.0d0 / 12.0d0

!.......................................................................
!               end of program
!.......................................................................
      return
!***********************************************************************
      end


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_od_vvacis
CONTAINS
  SUBROUTINE od_vvacis(&
       &     n2d_1,input,vacuum,nq2_1,&
       &     kv2_1,cell,MM,stars,&
       &     nstr2_1,&
       &     oneD,&
       &     rht,rhtxy,psq,vz,sym,&
       &     vxy,vpw)

    !     generates m^2+gz^2.neq.0 coefficients of the vacuum potential
    !     and fourier coefficients of the interstitial potential
    !     in the case of 1-dimensional calculations
    !     based on the using of the green's function for the
    !     radial equation for the potential:
    !     [1/r(d/dr(r*d/dr))-m^2/r^2-gz^2]V(r) = 4pi*rho(r)
    !     when gz.neq.0 green's function is represented in
    !     the following way:
    !          gf = 4pi*I_m(gz*r<)*K_m(gz*r>)
    !     where I and K are modified bessel funcions
    !     in the case of gz.eq.0 the green's function is:
    !            gf = 2pi*((r</r>)^m)/m
    !                 Y.Mokrousov, autumn 2002

    !     Fully symmetrized version, Mai 2003

    USE m_constants
    USE m_od_cylbes
    USE m_modcyli
    USE m_modcylk
    USE m_vacp5_0
    USE m_vacp5_z
    USE m_visp5_0
    USE m_visp5_z
    USE m_angle
    USE m_qsf
    USE m_fft2d

    USE m_types
    IMPLICIT NONE

    TYPE(t_input),INTENT(IN)   :: INPUT

    TYPE(t_oneD),INTENT(IN)   :: oneD

    TYPE(t_vacuum),INTENT(IN)   :: vacuum

    TYPE(t_sym),INTENT(IN)   :: sym

    TYPE(t_stars),INTENT(IN)   :: stars

    TYPE(t_cell),INTENT(IN)   :: cell

    INTEGER, INTENT (IN) :: n2d_1  ,MM
    INTEGER, INTENT (IN) :: nq2_1
    INTEGER, INTENT (IN) :: nstr2_1(n2d_1)
    INTEGER, INTENT (IN) :: kv2_1(2,n2d_1)
    COMPLEX, INTENT (INOUT) :: psq(stars%ng3)
    REAL,    INTENT (IN) :: vz(vacuum%nmzd,2)
    REAL,    INTENT (IN) :: rht(vacuum%nmzd,2)
    COMPLEX, INTENT (IN) :: rhtxy(vacuum%nmzxyd,n2d_1-1,2)
    COMPLEX, INTENT (OUT):: vxy(vacuum%nmzxyd,n2d_1-1,2)
    COMPLEX, INTENT (OUT):: vpw(stars%ng3)

    !     local
    INTEGER :: m
    !------> reciprocal vectors staff

    INTEGER irec2,irec3,k1,k2,gzi,gzi1,k3,gzmin
    REAL    gz,gx,gy,g,g2

    !------> different garbage

    REAL, PARAMETER :: tol_21 = 1.0e-21
    INTEGER  imz,imz1,i,ivac,iirec1,m1,j,irc1,im,irc
    INTEGER ix,iy,iz,s,n
    REAL    x,y,r,z,b,q,zf
    REAL    mult
    REAL    ani1,ani2,rhti
    INTEGER ivfft1,ivfft2,ivfft2d
    COMPLEX ic

    !------> different staff with special functions

    REAL  IR(1:stars%mx3,0:MM)
    REAL, ALLOCATABLE :: II(:),KK(:)
    REAL  fJ,fJ2,fJ1,iJ2,IIIR,fJ3
    REAL, ALLOCATABLE :: III(:),IIII(:,:,:)
    REAL, ALLOCATABLE :: fJJ(:,:),iJJ(:,:)

    !------> used for the optimization

    INTEGER irec1(4),l,lmin ,l1

    !------> some factors used for the construction of the ch. density

    REAL, ALLOCATABLE :: fact(:)
    COMPLEX aa,a

    !------> values of the potential on the vacuum boundary

    COMPLEX val_help
    COMPLEX, ALLOCATABLE :: val(:),val_m(:,:)

    !------> Charge density

    COMPLEX, ALLOCATABLE :: rxy(:)

    !---------------> POTENTIALS

    !-> interstitial potential by its gz,m - components and total on the
    !-> real grid

    COMPLEX, ALLOCATABLE :: vis(:,:,:),vis_tot(:,:)

    !-> potential in the vacuum caused by the vacuum charge density

    COMPLEX, ALLOCATABLE :: pvac(:)

    !-> potential in the vacuum caused by the interst. density

    COMPLEX, ALLOCATABLE :: pint(:)

    !-> radial components of the potential caused by the vacuum
    !-> density on the real grid

    COMPLEX, ALLOCATABLE :: vis_help(:,:),vpw_help(:)

    !-> real grid vis_z,vis_0 for the fft2d

    REAL,ALLOCATABLE :: af2(:),bf2(:)

    !-> radial grids

    INTEGER, ALLOCATABLE :: rmap(:,:)
    REAL   , ALLOCATABLE :: rr(:)
    INTEGER nrd

    !--> time

    REAL    gxy0,fxy0,phi
    COMPLEX gxy(stars%ng2-1)
    COMPLEX fxy(stars%ng2-1)

    INTRINSIC REAL,aimag

    !--------- preparations ---------->

    ALLOCATE ( KK(vacuum%nmzxyd),II(vacuum%nmzxyd),III(9*stars%mx1*stars%mx2),&
         &     IIII(9*stars%mx1*stars%mx3,1:stars%mx3,0:MM),&
         &     rmap(0:3*stars%mx1-1,0:3*stars%mx2-1),rr(1:9*stars%mx1*stars%mx2),&
         &     fact(vacuum%nmzxyd),val(n2d_1),fJJ(0:MM+1,stars%ng2),&
         &     val_m(-stars%mx3:stars%mx3,-MM:MM),rxy(vacuum%nmzxyd),iJJ(0:MM+1,1:stars%mx3),&
         &     vis(0:3*stars%mx1-1,0:3*stars%mx2-1,n2d_1),&
         &     vis_tot(0:3*stars%mx1-1,0:3*stars%mx2-1),pvac(vacuum%nmzxyd),&
         &     pint(vacuum%nmzxyd),vis_help(0:3*stars%mx1-1,0:3*stars%mx2-1),&
         &     af2(0:9*stars%mx1*stars%mx2-1),bf2(0:9*stars%mx1*stars%mx2-1),vpw_help(stars%ng3) )

    ivfft2d = 9*stars%mx1*stars%mx2
    ic = CMPLX(0.,1.)
    ivfft1 = 3*stars%mx1
    ivfft2 = 3*stars%mx2
    ani1 = 1./REAL(ivfft1)
    ani2 = 1./REAL(ivfft2)

    !--------- initializations -------->

    !----> vpw in the '1st aproximation' (V - tilde)

    vpw(1) = CMPLX(0.,0.)

    DO irec3 = 2,stars%ng3

       g = stars%sk3(irec3)

       vpw(irec3) = fpi_const*psq(irec3)/(g*g)

    ENDDO

    DO irc1 = 2,nq2_1
       DO i = 1,vacuum%nmzxy
          vxy(i,irc1-1,1) = CMPLX(0.,0.)
       END DO
    END DO

    !----> values of the potential in the 1st approximation on the boundary
    !----> if nstr2.ne.1 then it should be changed!!!

    DO m = 0,MM+1
       DO k3 = 1,stars%mx3
          CALL modcyli(m,cell%bmat(3,3)*k3*cell%z1,iJJ(m,k3))
       END DO
       DO irec2 = 1,stars%ng2
          g2 = stars%sk2(irec2)
          IF (irec2.NE.0) THEN
             CALL od_cylbes(m,g2*cell%z1,fJJ(m,irec2))
          END IF
       END DO
    END DO

    DO irc1 = 1,nq2_1
       val(irc1) = CMPLX(0.,0.)
       m = kv2_1(2,irc1)
       IF (m.LT.0) THEN
          mult = REAL((-1)**m)
       ELSE
          mult = 1.
       END IF
       k3 = kv2_1(1,irc1)
       DO irec2 = 1,stars%ng2
          phi = stars%phi2(irec2)
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),k3)
          IF (irec3.NE.0) THEN
             val(irc1) = val(irc1) +&
                  &              (ic**m)*vpw(irec3)*EXP(-ic*&
                  &              m*phi)*fJJ(iabs(m),irec2)*&
                  &              stars%nstr2(irec2)*mult
          END IF
       END DO
    END DO

    !-----> preparing arrays for radial grids:selecting from
    !-----> x & y only the radius

    nrd = 0

    DO ix = 0,ivfft1 - 1
       iy_loop: DO  iy = 0,ivfft2 - 1
          x = ix*ani1
          IF (x.GT.0.5) x = x - 1.
          y = iy*ani2
          IF (y.GT.0.5) y = y - 1.
          r = SQRT((x*cell%amat(1,1) + y*cell%amat(1,2))**2 +&
               &               (x*cell%amat(2,1) + y*cell%amat(2,2))**2)
          DO i = 1,nrd
             IF (ABS(r-rr(i)).LE.1.e-6) THEN
                rmap(ix,iy) = i
                CYCLE iy_loop
             END IF
          END DO
          nrd = nrd + 1
          rmap(ix,iy) = nrd
          rr(nrd) = r
       ENDDO iy_loop
    END DO

    DO gzi = -stars%mx3,stars%mx3
       DO m = -MM,MM
          IF (m.LT.0) THEN
             mult = REAL((-1)**m)
          ELSE
             mult = 1.
          END IF
          val_m(gzi,m) = CMPLX(0.,0.)
          irc1 = oneD%ig1(gzi,m)
          IF (irc1.NE.0) THEN
             val_m(gzi,m) = val(irc1)
          ELSE
             DO irec2 = 1,stars%ng2
                phi = stars%phi2(irec2)
                irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),gzi)
                IF (irec3.NE.0) THEN
                   val_m(gzi,m) = val_m(gzi,m) +&
                        &                    (ic**m)*vpw(irec3)*EXP(-ic*&
                        &                    m*phi)*fJJ(iabs(m),irec2)*&
                        &                    stars%nstr2(irec2)*mult
                END IF
             END DO
          END IF
       END DO
    END DO

    !-------  During the following staff we miss the m=0,gz=0 -> irec1 = 1
    !-------  component of the potential which should be also added
    !-------  in order to get the total potential for the FFT's

    DO ix = 0,ivfft1 - 1
       DO iy = 0,ivfft2 - 1
          irc = rmap(ix,iy)
          r = rr(irc)
          IF (r.GT.cell%z1) THEN
             zf = (r-cell%z1)/vacuum%delz + 1.0
             im = zf
             q = zf - im
             vis(ix,iy,1) = 0.5*(q-1.)*&
                  &              (q-2.)*vz(im,1) -&
                  &              q*(q-2.)*vz(im+1,1) +&
                  &              0.5*q*(q-1.)*vz(im+2,1)
          ELSE
             vis(ix,iy,1) = &
                  &              vz(1,1) - val(1) + tpi_const*&
                  &              psq(1)*(cell%z1*cell%z1 - r*r)/2.
          END IF
          DO irc1 = 2,nq2_1
             vis(ix,iy,irc1) = CMPLX(0.,0.)
          END DO
       END DO
    END DO

    DO m = 0,MM
       DO k3 = 1,stars%mx3
          CALL modcyli(m,cell%bmat(3,3)*k3*cell%z1,IR(k3,m))
       END DO
    END DO

    DO i = 1,nrd
       DO m = 0,MM
          DO k3 = 1,stars%mx3
             CALL modcyli(m,cell%bmat(3,3)*k3*rr(i),IIII(i,k3,m))
          END DO
       END DO
    END DO

    !------- cycle by positive gz---------->

    DO gzi = 0,stars%mx3                        ! gz

       !------- cycle by positive m ---------->

       m_loop: DO m = 0,MM

          !-------------------------------------->

          IF (m.NE.0 .OR. gzi.NE.0) THEN ! m^2 + gz^2.ne.0

             irec1(1) = oneD%ig1(gzi,m)
             irec1(2) = oneD%ig1(gzi,-m)
             irec1(3) = oneD%ig1(-gzi,m)
             irec1(4) = oneD%ig1(-gzi,-m)

             DO l = 1,3
                DO l1 = l+1,4
                   IF (irec1(l).EQ.irec1(l1)) irec1(l1) = 0
                END DO
             END DO

             !---> if all the irec1 not equal to zero

             s = 0

             DO l = 1,4
                s = s + irec1(l)*irec1(l)
             END DO

             !---> preparing special functions which depend only on the
             !---> absolute value of m and gz

             IF (s.NE.0 .AND. gzi.NE.0) THEN
                gz = cell%bmat(3,3)*gzi
                DO  imz = 1,vacuum%nmzxy
                   z = cell%z1 + vacuum%delz*(imz-1)
                   CALL modcylk(m,gz*z,KK(imz))
                   CALL modcyli(m,gz*z,II(imz))
                END DO
                IIIR = II(1)
                DO irc = 1,nrd
                   III(irc) = IIII(irc,gzi,m)
                END DO
             ELSEIF (s.EQ.0) THEN
                CYCLE m_loop
             ELSEIF (s.NE.0 .AND. gzi.EQ.0) THEN
                gz = 0.
             END IF

             !---> now we start the cycle by +-m,gz

             DO  l = 1,4

                IF (irec1(l).NE.0) THEN

                   !--------------------------------------->

                   DO ix = 0,ivfft1-1
                      DO iy = 0,ivfft2-1
                         vis_help(ix,iy) = CMPLX(0.,0.)
                      END DO
                   END DO

                   DO i = 1,vacuum%nmzxy
                      fact(i) = 0.
                      rxy(i) = CMPLX(0.,0.)
                      pvac(i) = CMPLX(0.,0.)
                      pint(i) = CMPLX(0.,0.)
                   END DO

                   !-------------- gz = 0 ------------------------------------->
                   !----------------------------------------------------------->

                   IF (gzi.EQ.0) THEN

                      !----- this form of the density is just more easy to use

                      DO imz = 1,vacuum%nmzxy
                         rxy(imz) = rhtxy(imz,irec1(l)-1,1)
                      END DO

                      !----- vacuum potential caused by the vacuum density

                      CALL vacp5_0(&
                           &        vacuum%nmzxyd,vacuum%nmzxy,cell%z1,tpi_const,rxy,m,vacuum%delz,&
                           &        pvac,fact)

                      !----- vacuum potential caused by the interstitial density

                      aa = CMPLX(0.,0.)
                      m1 = kv2_1(2,irec1(l))
                      gzi1 = kv2_1(1,irec1(l))

                      IF (m1.LT.0) THEN
                         mult = REAL((-1)**m)
                      ELSE
                         mult = 1.
                      END IF

                      DO irec2 = 1,stars%ng2
                         irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),0)
                         IF (irec3.NE.0 .AND. irec2.NE.1) THEN
                            phi = stars%phi2(irec2)
                            g2 = stars%sk2(irec2)
                            aa = aa +    &
                                 &              (ic**m1)*psq(irec3)*&
                                 &              EXP(CMPLX(0.,-m1*phi))*&
                                 &              CMPLX(mult*fJJ(m+1,irec2)/g2,0.)*stars%nstr2(irec2)
                         END IF
                      END DO

                      !----- total vacuum potential

                      pint(:vacuum%nmzxy) =  fact(:vacuum%nmzxy)*aa

                      vxy(:vacuum%nmzxy,irec1(l)-1,1) = pvac(:vacuum%nmzxy) + pint(:vacuum%nmzxy)

                      !----- array val further is a boundary values of the
                      !----- potential V- \tilde \tilde which is created to compensate
                      !----- the influence of the outer 'noice' charge density - which
                      !----- is just a periodical continuation of the interstitial charge
                      !----- density, V - \tilde and V - \tilde\tilde are then added in
                      !----- order to obtain the real interstitial potential

                      val_help = vxy(1,irec1(l)-1,1) - val(irec1(l))

                      !----- potential \tilde\tilde{V} is a solution of the Laplase equation
                      !----- in the interstitial with the boundary conditions val_0 and val_z
                      !----- further, it is generated on the uniform grid in the unit cell
                      !----- \tilde{\Omega}, in the space between the cylindrical
                      !----- interstitial boundary and the squre boundaries it is put to
                      !----- the vacuum potential

                      CALL visp5_0(&
                           &        vacuum%nmzxyd,vacuum%nmzxy,vacuum%delz,m,ivfft1,ivfft2,l,&
                           &        rxy,ani1,ani2,cell%z1,cell%amat,&
                           &        pvac,pint,tpi_const,input%jspins,val_help,&
                           &        vis_help)

                      DO ix = 0,ivfft1 - 1
                         DO iy = 0,ivfft2 - 1
                            vis(ix,iy,irec1(l)) = vis_help(ix,iy)
                         END DO
                      END DO

                      !------- gz.NEQ.0--------------------------------------------->
                   ELSE
                      !------------------------------------------------------------->

                      DO  imz = 1,vacuum%nmzxy
                         rxy(imz) = rhtxy(imz,irec1(l)-1,1)
                      END DO

                      !----- vacuum potential caused by the vacuum density

                      CALL vacp5_z(&
                           &        vacuum%nmzxyd,vacuum%nmzxyd,cell%z1,vacuum%delz,fpi_const,II,KK,rxy,m,&
                           &        pvac)

                      !----- vacuum potential caused by the intst. density

                      a = CMPLX(0.,0.)
                      m1 = kv2_1(2,irec1(l))
                      gzi1 = kv2_1(1,irec1(l))

                      IF (m1.LT.0) THEN
                         mult = REAL((-1)**m)
                      ELSE
                         mult = 1.
                      END IF

                      DO irec2 = 1,stars%ng2
                         irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),gzi1)
                         IF (irec3.NE.0) THEN
                            g = stars%sk3(irec3)
                            g2 = stars%sk2(irec2)
                            phi = stars%phi2(irec2)
                            b = cell%z1*( gz*iJJ(m+1,gzi)*fJJ(m,irec2) + &
                                 &              g2*II(1)*fJJ(m+1,irec2))/(g*g)
                            a = a +    &
                                 &              (ic**m1)*mult*EXP(-ic*m1*phi)&
                                 &              *psq(irec3)*b*stars%nstr2(irec2)
                         END IF
                      END DO

                      !----- total vacuum potential ---------------

                      DO imz = 1,vacuum%nmzxy
                         pint(imz) = fpi_const*a*KK(imz)
                         vxy(imz,irec1(l)-1,1) =  pint(imz) + pvac(imz)
                      END DO

                      val_help = vxy(1,irec1(l)-1,1) - val(irec1(l))

                      CALL visp5_z(&
                           &        vacuum%nmzxyd,vacuum%nmzxyd,vacuum%delz,m,ivfft1,ivfft2,IIIR,&
                           &        rxy,ani1,ani2,cell%z1,cell%amat,pvac,pint,tpi_const,l,&
                           &        fpi_const,val_help,III,m1,gz,rmap,rr,&
                           &        vis_help)

                      DO ix = 0,ivfft1 - 1
                         DO iy = 0,ivfft2 - 1
                            vis(ix,iy,irec1(l)) = vis_help(ix,iy)
                         END DO
                      END DO

                      !---  end of vacuum contibution to vis ---------------------->

                   END IF                    ! gz.atoms%neq.0

                   !---- > finishing the cycle by +-m,gz

                END IF

             ENDDO
          END IF                    ! m^2+gz^2.atoms%neq.0

       ENDDO m_loop                  ! m

    ENDDO                  ! gz

    !*************************************************************
    !-------> finding the Fourier coefficients of the potential
    !-------  in the interstitial
    !-------  the scheme (making the potential continuous) is as follows:
    !-------  1. transforming the \tilde{V} from pw-representation
    !-------     to the real grid, putting to zero outside the
    !-------     cylindrical interstitial
    !-------  2. Adding the \tilde\tilde{V} on the real grid
    !-------  3. Transforming back to the pw-representation
    !-------  Everything is done in \tilda {\Omega}

    gzmin = -stars%mx3

    IF (sym%zrfs.OR.sym%invs) gzmin = 0

    DO k3 = gzmin,stars%mx3          ! collect the Fourier components

       fxy0 = 0.

       rhti = 0.

       DO irec2 = 1,stars%ng2 - 1
          fxy(irec2) = CMPLX(0.,0.)
       END DO

       DO irec2 = 1,stars%ng2
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),k3)
          IF (irec3.NE.0) THEN
             IF (irec2.EQ.1) THEN
                fxy0 = REAL(vpw(irec3))
                rhti = AIMAG(vpw(irec3))
             ELSE
                fxy(irec2-1) = vpw(irec3)
             END IF
          END IF
       END DO

       af2=0.0
       bf2=0.0

       CALL fft2d(&
            &        stars,&
            &        af2(0),bf2,&
            &        fxy0,rhti,fxy,&
            &        1,+1)

       !--> although some harmonics of the vacuum potential are equal to zero
       !--> the same harmonics of the interstitial potential \Tilde{V} are not,
       !--> because this potential is determined from pw coefficients of the
       !--> charge density, which has the periodicity of the rectangular
       !--> unit cell, hence, these harmonics should be extracted from the
       !--> final interstitial potential

       i = 0

       DO iy = 0,3*stars%mx2-1
          DO ix = 0,3*stars%mx1-1
             x = ix*ani1
             IF (x.GT.0.5) x = x - 1.
             y = iy*ani2
             IF (y.GT.0.5) y = y - 1.
             r = SQRT((x*cell%amat(1,1) + y*cell%amat(1,2))**2 +&
                  &                  (x*cell%amat(2,1) + y*cell%amat(2,2))**2)
             phi = angle(x*cell%amat(1,1) + y*cell%amat(1,2),&
                  &                     x*cell%amat(2,1) + y*cell%amat(2,2))
             vis_tot(ix,iy) = CMPLX(0.,0.)
             j = rmap(ix,iy)
             DO m = -MM,MM
                irc1 = oneD%ig1(k3,m)
                IF (irc1.NE.0) THEN
                   vis_tot(ix,iy) = vis_tot(ix,iy) +&
                        &                    vis(ix,iy,irc1)
                ELSE
                   IF (k3.EQ.0) THEN
                      IF (r.LE.cell%z1) THEN
                         vis_tot(ix,iy) = vis_tot(ix,iy) - &
                              &                          val_m(k3,m)*&
                              &                          EXP(CMPLX(0.,m*phi))*&
                              &                          (r**(iabs(m)))/(cell%z1**(iabs(m)))
                      END IF
                   ELSE
                      IF (r.LE.cell%z1) THEN
                         vis_tot(ix,iy) = vis_tot(ix,iy) -&
                              &                    val_m(k3,m)*IIII(j,iabs(k3),iabs(m))*&
                              &                    EXP(CMPLX(0.,m*phi))/IR(iabs(k3),iabs(m))
                      END IF
                   END IF
                END IF
             END DO

             IF (r.LE.cell%z1) THEN
                af2(i) = af2(i) + REAL(vis_tot(ix,iy))
                bf2(i) = bf2(i) + AIMAG(vis_tot(ix,iy))
                !$$$                 af2(i) = real(vis_tot(ix,iy))
                !$$$                 bf2(i) = aimag(vis_tot(ix,iy))
             ELSE
                af2(i) = REAL(vis_tot(ix,iy))
                bf2(i) = AIMAG(vis_tot(ix,iy))
             END IF
             i = i+1
          END DO
       END DO

       rhti = 0.

       CALL fft2d(&
            &        stars,&
            &        af2(0),bf2,&
            &        gxy0,rhti,gxy,&
            &        1,-1)

       DO irec2 = 1,stars%ng2
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),k3)
          IF (irec3.NE.0) THEN
             IF (irec2.EQ.1) THEN
                vpw_help(irec3) = CMPLX(gxy0,rhti)
             ELSE
                vpw_help(irec3) = gxy(irec2-1)
             END IF
          END IF
       END DO

    END DO                    ! gz -> Vpw(.,.,gz)

    DO irec3 = 1,stars%ng3
       vpw(irec3) = vpw_help(irec3)
       !$$$         vpw(irec3,1) = vpw(irec3,1) + vpw_help(irec3)
    END DO

    DO irc1 = 2,nq2_1
       DO imz = 1,vacuum%nmzxy
          IF (ABS(vxy(imz,irc1-1,1)).LE.tol_21)&
               &          vxy(imz,irc1-1,1) = CMPLX(0.,0.)
       END DO
    END DO

    DEALLOCATE ( KK,II,III,IIII,fact,val,val_m,rxy,&
         &     vis,vis_tot,pvac,pint,vis_help,rmap,rr,&
         &     af2,bf2,vpw_help,fJJ,iJJ )

    RETURN
  END SUBROUTINE od_vvacis
END MODULE m_od_vvacis


      SUBROUTINE VEC1 (VX,VY,VZ, VX1,VY1,VZ1)

C  This subroutine accepts an arbitrary 3D vector and returns a
C  parallel vector normalized to unit size.

      REAL  VX,VY,VZ, VX1,VY1,VZ1, D, VECL

      D = VECL(VX,VY,VZ)
      VX1 = VX/D
      VY1 = VY/D
      VZ1 = VZ/D

      END