SUBROUTINE CSYSVX_F95(A, B, X, UPLO, AF, IPIV, FACT, &
                      FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: SYSVX_F77 => LA_SYSVX, ILAENV_F77 => ILAENV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO, FACT
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(IN) :: A(:,:), B(:,:)
   COMPLEX(WP), INTENT(OUT) :: X(:,:)
   INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: IPIV(:)
   COMPLEX(WP), INTENT(INOUT), OPTIONAL, TARGET :: AF(:,:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!      LA_SYSVX computes the solution to a linear system of equations
! A*X = B, where A is a real or complex symmetric matrix and X and B are
! rectangular matrices or vectors.
!      LA_HESVX computes the solution to a linear system of equations
! A*X = B, where A is a complex Hermitian matrix and X and B are
! rectangular matrices or vectors.
!      LA_SYSVX and LA_HESVX can also optionally estimate the condition
! number of A and compute error bounds.
!
! =========
!
!         SUBROUTINE LA_SYSVX / LA HESVX( A, B, X, UPLO=uplo, AF=af, &
!                        IPIV=ipiv, FACT=fact, FERR=ferr, BERR=berr, &
!                        RCOND=rcond, INFO=info )
!              <type>(<wp>), INTENT(IN) :: A(:,:), <rhs>
!              <type>(<wp>), INTENT(OUT) :: <sol>
!              CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!              <type>(<wp>), INTENT(INOUT), OPTIONAL :: AF(:,:)
!              INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:)
!              CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
!              REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>, RCOND
!              INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!              <type> ::= REAL | COMPLEX
!              <wp>   ::= KIND(1.0) | KIND(1.0D0)
!              <rhs>  ::= B(:,:) | B(:)
!              <sol>  ::= X(:,:) | X(:)
!              <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! A       (input) REAL or COMPLEX square array, shape (:,:).
!         The symmetric or Hermitian matrix A.
!         If UPLO = 'U', the upper triangular part of A contains the
! 	  upper triangular part of the matrix A, and the strictly lower
! 	  triangular part of A is not referenced. If UPLO = 'L', the
! 	  lower triangular part of A contains the lower triangular part
! 	  of the matrix A, and the strictly upper triangular part of A is
! 	  not referenced.
! B       (input) REAL or COMPLEX array, shape (:,:) with size(B,1) =
!         size(A,1) or shape (:) with size(B) = size(A,1).
!         The matrix B.
! X       (output) REAL or COMPLEX array, shape (:,:) with size(X,1) =
!         size(A,1) and size(X,2) = size(B,2), or shape (:) with size(X)
! 	  = size(A,1).
!         The solution matrix X.
! UPLO    Optional (input) CHARACTER(LEN=1).
!            = 'U': Upper triangle of A is stored;
!            = 'L': Lower triangle of A is stored.
!         Default value: 'U'.
! AF      Optional (input or output) REAL or COMPLEX array, shape (:,:)
!         with the same size as A.
!         If FACT = 'F', then AF is an input argument that contains the
! 	  block diagonal matrix D and the multipliers used to obtain the
! 	  factor L or U from the factorization of A, returned by a
!         previous call to LA_SYSVX or LA_HESVX.
!         If FACT = 'N', then AF is an output argument that contains the
! 	  block diagonal matrix D and the multipliers used to obtain the
! 	  factor L or U from the factorization of A.
! IPIV    Optional (input or output) INTEGER array, shape (:) with
!         size(IPIV) = size(A,1).
!         If FACT = 'F', then IPIV is an input argument that contains
! 	  details of the row and column interchanges and the block
! 	  structure of D.
!         If IPIV(k) > 0 , then rows and columns k and IPIV(k) were
! 	  interchanged and D(k,k) is a 1 by 1 diagonal block.
!         If IPIV(k) < 0 , then there are two cases:
!           1. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
! 	     columns k-1 and -IPIV(k) were interchanged and
! 	     D(k-1:k,k-1:k) is a 2 by 2 diagonal block.
!           2. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, then rows and
! 	     columns k+1 and -IPIV(k) were interchanged and
! 	     D(k:k+1,k:k+1) is a 2 by 2 diagonal block.
!         If FACT = 'N', then IPIV is an output argument that contains
! 	  details of the row and column interchanges and the block
! 	  structure of D; as described above.
! FACT    Optional (input) CHARACTER(LEN=1).
!         Specifies whether the factored form of the matrix A has been
! 	  supplied on entry.
!           = 'N': The matrix A will be copied to AF and factored.
!           = 'F': AF and IPIV contain the factored form of A.
!         Default value: 'N'.
! FERR    Optional (output) REAL array of shape (:), with
!         size(FERR) = size(X,2), or REAL scalar.
!         The estimated forward error bound for each solution vector
! 	  X(j) (the j-th column of the solution matrix X). If XTRUE is
! 	  the true solution corresponding to X(j), FERR(j) is an
!         estimated upper bound for the magnitude of the largest element
! 	  in (X(j)-XTRUE) divided by the magnitude of the largest element
! 	  in X(j). The estimate is as reliable as the estimate for RCOND,
! 	  and is almost always a slight overestimate of the true error.
! BERR    Optional (output) REAL array of shape (:), with size(BERR) =
!         size(X,2), or REAL scalar.
!         The componentwise relative backward error of each solution
! 	  vector X(j) (i.e., the smallest relative change in any element
! 	  of A or B that makes X(j) an exact solution).
! RCOND   Optional (output) REAL
!         The estimate of the reciprocal condition number of A. If RCOND
! 	  is less than the machine
!         precision, the matrix is singular to working precision. This
! 	  condition is indicated by a return code of INFO > 0.
! INFO    (output) INTEGER
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, and i is
!             <= n: D(i,i) = 0. The factorization has been completed, but
! 	         the block diagonal matrix D is singular, so the
! 		 solution could not be computed.
!             = n+1: D is nonsingular, but RCOND is less than machine
! 	         precision, so the matrix is singular to working
! 		 precision. Nevertheless, the solution and error bounds
! 		 are computed because the computed solution can be more
! 		 accurate than the value of RCOND would suggest.
!             n is the order of A.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!------------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SYSVX'
   CHARACTER(LEN=6), PARAMETER :: BSNAME = 'CSYTRF'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LUPLO
   INTEGER :: LINFO, NRHS, N, NB, LWORK, ISTAT, ISTAT1, SIPIV, S1AF, S2AF, SFERR, SBERR
   REAL(WP) :: LRCOND
!  .. LOCAL POINTERS ..
   INTEGER, POINTER :: LPIV(:)
   REAL(WP),  POINTER :: RWORK(:), LFERR(:), LBERR(:)
   COMPLEX(WP),  POINTER :: WORK(:), LAF(:, :)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE, MAX
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A, 1); NRHS = SIZE(B, 2)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; END IF
   IF( PRESENT(AF) )THEN; S1AF = SIZE(AF,1); S2AF = SIZE(AF,2)
   ELSE; S1AF = N; S2AF = N; END IF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
!  .. TEST THE ARGUMENTS
   IF( SIZE(A, 2) /= N .OR. N < 0 )THEN; LINFO = -1
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -2
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
   ELSE IF( S1AF /= N .OR. S2AF /= N ) THEN; LINFO = -5
   ELSE IF( SIPIV /= N )THEN; LINFO = -6
   ELSE IF( ( .NOT. LSAME(LFACT,'F') .AND. .NOT. LSAME(LFACT,'N') ) .OR. &
     ( LSAME(LFACT,'F') .AND. .NOT.( PRESENT(AF) .AND. PRESENT(IPIV) ) ) )THEN; LINFO = -7
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -8
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -9
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(AF) ) THEN; ALLOCATE( LAF(N,N), STAT=ISTAT )
      ELSE; LAF => AF; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(IPIV) )THEN; ALLOCATE( LPIV(N), STAT=ISTAT )
         ELSE; LPIV => IPIV; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         NB = ILAENV_F77( 1, BSNAME, LUPLO, N, -1, -1, -1 )
         IF( NB <= 1 .OR. NB >= N ) NB = 1; LWORK = MAX(1,2*N,N*NB)
         ALLOCATE(WORK(LWORK), RWORK(N), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN
            DEALLOCATE(WORK, RWORK, STAT=ISTAT1); LWORK = MAX(1,3*N)
            ALLOCATE(WORK(LWORK), RWORK(N), STAT=ISTAT)
            IF( ISTAT /= 0 ) THEN; LINFO = - 100
            ELSE; CALL ERINFO( -200, SRNAME, LINFO ); ENDIF
         ENDIF
      END IF
      IF( ISTAT == 0 )THEN
!        .. CALL LAPACK77 ROUTINE
         CALL SYSVX_F77( LFACT, LUPLO, N, NRHS, A, N, LAF, N, LPIV, B, N, X, N, &
                         LRCOND, LFERR, LBERR, WORK, LWORK, RWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(AF) ) DEALLOCATE( LAF, STAT=ISTAT1 )
      IF( .NOT.PRESENT(IPIV) ) DEALLOCATE( LPIV, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      DEALLOCATE( WORK, RWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE CSYSVX_F95


      SUBROUTINE ZGGEV_F95( A, B, ALPHA, BETA, VL, VR, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => DP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: GGEV_F77 => LA_GGEV
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
       COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
      COMPLEX(WP), INTENT(OUT) :: ALPHA(:), BETA(:)
      COMPLEX(WP), INTENT(OUT), OPTIONAL, TARGET :: VL(:,:), VR(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
! LA_GGEV computes for a pair of n by n real or complex matrices (A,B)
! the generalized eigenvalues in the form of scalar pairs (alpha, beta)
! and, optionally, the left and/or right generalized eigenvectors.
!       A generalized eigenvalue of the pair (A,B) is, roughly
! speaking, a scalar of the form  lambda=alpha/beta such that the matrix
! A-lambda*B is singular. It is usually represented as the pair
! (alpha; beta), as there is a reasonable interpretation of the case
! beta = 0 (even if alpha = 0).
!       A right generalized eigenvector corresponding to a generalized
! eigenvalue lambda is a vector v such that (A-lambda*B)*v=0. A left
! generalized eigenvector is a vector u such that u^H*(A-lambda*B)=0,
! where u^H is the conjugate-transpose of u.
!       The computation is based on the (generalized) real or complex
! Schur form of (A,B). (See LA_GGES for details of this form.)
!
! =========
!
!     SUBROUTINE LA_GGEV( A, B, <alpha>, BETA, VL=vl, &
!                 VR=vr, INFO=info )
!         <type>(<wp>), INTENT(INOUT) :: A(:,:), B(:,:)
! 	  <type>(<wp>), INTENT(OUT) :: <alpha(:)>, BETA(:)
! 	  <type>(<wp>), INTENT(OUT), OPTIONAL :: VL(:,:), VR(:,:)
! 	  INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     where
! 	  <type>     ::= REAL | COMPLEX
! 	  <wp>       ::= KIND(1.0) | KIND(1.0D0)
! 	  <alpha>    ::= ALPHAR, ALPHAI | ALPHA
! 	  <alpha(:)> ::= ALPHAR(:), ALPHAI(:) | ALPHA(:)
!
! Arguments
! =========
!
! A       (input/output) REAL or COMPLEX square array, shape (:,:).
!         On entry, the matrix A.
! 	  On exit, A has been destroyed.
! B       (input/output) REAL or COMPLEX square array, shape (:,:) with
!         size(B,1) = size(A,1).
!   	  On entry, the matrix B.
! 	  On exit, B has been destroyed.
! <alpha> (output) REAL or COMPLEX array, shape (:) with size(alpha) =
!         size(A,1).
! 	  The values of alpha.
!         alpha(:) ::= ALPHAR(:), ALPHAI(:) | ALPHA(:),
! 	  where
! 	  ALPHAR(:), ALPHAI(:) are of REAL type (for the real and
! 	  imaginary parts) and ALPHA(:) is of COMPLEX type.
! BETA    (output) REAL or COMPLEX array, shape (:) with size(BETA) =
!         size(A,1).
! 	  The values of beta.
! 	  Note: The generalized eigenvalues of the pair (A,B) are the
! 	  scalars lambda(j)=alpha(j)/beta(j). These quotients may easily
! 	  over- or underflow, and beta(j) may even be zero. Thus, the
! 	  user should avoid computing them naively.
!         Note: If A and B are real then complex eigenvalues occur in
! 	  complex conjugate pairs. Each pair is stored consecutively.
! 	  Thus a complex conjugate pair is given by
!             lambda(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
!    	      lambda(j+1) = (ALPHAR(j+1) + i*ALPHAI(j+1))/BETA(j+1)
!   	  where
!     	      ALPHAI(j)/BETA(j) = -(ALPHAI(j+1)/BETA(j+1))
! VL      Optional (output) REAL or COMPLEX square array, shape (:,:)
!         with size(VL,1) = size(A,1).
! 	  The left generalized eigenvectors u(j) are stored in the
! 	  columns of VL in the order of their eigenvalues. Each
! 	  eigenvector is scaled so the largest component has
! 	      |realpart| + |imag.part| = 1,
! 	  except that for eigenvalues with alpha = beta = 0, a zero
!     	  vector is returned as the corresponding eigenvector.
! 	  Note: If A and B are real then complex eigenvectors, like
! 	  their eigenvalues, occur in complex conjugate pairs. The real
! 	  and imaginary parts of the first eigenvector of the pair are
! 	  stored in VL(:,j) and VL(:,j+1) . Thus a complex conjugate
! 	  pair is given by
! 	  u(j) = VL(:,j) + i*VL(:,j+1), u(j+1) = VL(:,j) - i*VL(:,j+1)
! VR      Optional (output) REAL or COMPLEX square array, shape (:,:)
!         with size(VR,1) = size(A,1).
! 	  The right generalized eigenvectors v(j) are stored in the
! 	  columns of VR in the order of their eigenvalues. Each
! 	  eigenvector is scaled so the largest component has
! 	      |realpart| + |imag:part| = 1,
! 	  except that for eigenvalues with alpha = beta = 0, a zero
!  	  vector is returned as the corresponding eigenvector.
! 	  Note: If A and B are real then complex eigenvectors, like
! 	  their eigenvalues, occur in complex conjugate pairs. The real
! 	  and imaginary parts of the first eigenvector of the pair are
! 	  stored in VR(:,j) and VR(:,j+1) . Thus a complex conjugate
!    	  pair is given by
! 	  v(j) = VR(:,j) + i*VR(:,j+1), v(j+1) = VR(:,j) - i*VR(:,j+1)
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
! 	  < 0: if INFO = -i, the i-th argument had an illegal value.
! 	  > 0: if INFO = i, and i is
! 	     <= n: The QZ iteration failed. No eigenvectors have been
! 	           calculated, but (alpha(j), BETA(j)) should be
! 		   correct for j = INFO+1, ..., n.
! 	     = n+1: another part of the algorithm failed.
! 	     = n+2: a failure occurred during the computation of the
! 	           generalized eigenvectors.
! 	   If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!-----------------------------------------------------------------------

!  .. LOCAL PARAMETERS ..
      CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GGEV'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBVL, LJOBVR
      INTEGER, SAVE :: LWORK = 0
      INTEGER :: N, LINFO, LD, ISTAT, S1VL, S2VL, S1VR, S2VR, &
     &  SALPHA, SBETA
!  .. LOCAL ARRAYS ..
      COMPLEX(WP), TARGET :: LLVL(1,1), LLVR(1,1), WORKMIN(1)
      COMPLEX(WP), POINTER :: WORK(:)
     REAL(WP), POINTER :: RWORK(:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A,1); LD = MAX(1,N)
   SALPHA = SIZE(ALPHA)
   SBETA = SIZE(BETA)
   IF( PRESENT(VL) )THEN; S1VL = SIZE(VL,1); S2VL = SIZE(VL,2); LJOBVL = 'V'
   ELSE; S1VL = 1; S2VL = 1; LJOBVL = 'N'; END IF
   IF( PRESENT(VR) )THEN; S1VR = SIZE(VR,1); S2VR = SIZE(VR,2); LJOBVR = 'V'
   ELSE; S1VR = 1; S2VR = 1; LJOBVR = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 .OR. SIZE(A,2) /= N )THEN; LINFO = -1
   ELSE IF( SIZE(B,1) /= N .OR. SIZE(B,2) /= N )THEN; LINFO = -2

       ELSE IF( SALPHA /= N )THEN; LINFO = -3
       ELSE IF( SBETA /= N )THEN; LINFO = -4
       ELSE IF( PRESENT(VL) .AND. ( S1VL /= N .OR. S2VL /= N ) )THEN; LINFO = -5
       ELSE IF( PRESENT(VR) .AND. ( S1VR /= N .OR. S2VR /= N ) )THEN; LINFO = -6
       ELSE IF( N > 0 )THEN

       ALLOCATE(RWORK(8*N),STAT=ISTAT)
       IF (ISTAT /= 0) THEN; LINFO=-100; GOTO 200; ENDIF

! .. DETERMINE THE WORKSPACE ..
! .. QUERING THE SIZE OF WORKSPACE ..
      LWORK = -1
      IF (PRESENT (VL)) THEN
         IF (PRESENT (VR)) THEN
              CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&               BETA, VL, S1VL, VR, S1VR, WORKMIN, LWORK, RWORK,  LINFO )
         ELSE
	      CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&               BETA, VL, S1VL, LLVR, S1VR, WORKMIN, LWORK, RWORK,  LINFO )
         ENDIF
       ELSE
         IF (PRESENT (VR)) THEN
              CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&               BETA, LLVL, S1VL, VR, S1VR, WORKMIN, LWORK, RWORK,  LINFO )
         ELSE
	      CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&               BETA, LLVL, S1VL, LLVR, S1VR, WORKMIN, LWORK, RWORK,  LINFO )
         ENDIF
       ENDIF
      LWORK = WORKMIN(1)
      ALLOCATE(WORK(LWORK), STAT=ISTAT)
      IF (ISTAT /= 0) THEN; LINFO=-100; GOTO 100; ENDIF
      IF (PRESENT (VL)) THEN
         IF (PRESENT (VR)) THEN
             CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&                BETA, VL, S1VL, VR, S1VR, WORK, LWORK, &
&                RWORK, LINFO )
         ELSE
	     CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&                BETA, VL, S1VL, LLVR, S1VR, WORK, LWORK, &
&                RWORK, LINFO )
         ENDIF
      ELSE
         IF (PRESENT (VR)) THEN
             CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&                BETA, LLVL, S1VL, VR, S1VR, WORK, LWORK, &
&                RWORK, LINFO )
         ELSE
	     CALL GGEV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, ALPHA, &
&                BETA, LLVL, S1VL, LLVR, S1VR, WORK, LWORK, &
&                RWORK, LINFO )
         ENDIF
       ENDIF
      IF( LINFO == 0 ) LWORK = INT(WORK(1)+1)

      DEALLOCATE(WORK)
200  DEALLOCATE(RWORK)
     ENDIF
100  CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE ZGGEV_F95


*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT,
*                          WORK, RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDU, LDVT, N, NS
*       REAL               RESID
*       ..
*       .. Array Arguments ..
*       REAL               D( * ), E( * ), S( * ), U( LDU, * ),
*      $                   VT( LDVT, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SBDT04 reconstructs a bidiagonal matrix B from its (partial) SVD:
*>    S = U' * B * V
*> where U and V are orthogonal matrices and S is diagonal.
*>
*> The test ratio to test the singular value decomposition is
*>    RESID = norm( S - U' * B * V ) / ( n * norm(B) * EPS )
*> where VT = V' and EPS is the machine precision.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the matrix B is upper or lower bidiagonal.
*>          = 'U':  Upper bidiagonal
*>          = 'L':  Lower bidiagonal
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix B.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is REAL array, dimension (N)
*>          The n diagonal elements of the bidiagonal matrix B.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is REAL array, dimension (N-1)
*>          The (n-1) superdiagonal elements of the bidiagonal matrix B
*>          if UPLO = 'U', or the (n-1) subdiagonal elements of B if
*>          UPLO = 'L'.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is REAL array, dimension (NS)
*>          The singular values from the (partial) SVD of B, sorted in
*>          decreasing order.
*> \endverbatim
*>
*> \param[in] NS
*> \verbatim
*>          NS is INTEGER
*>          The number of singular values/vectors from the (partial)
*>          SVD of B.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is REAL array, dimension (LDU,NS)
*>          The n by ns orthogonal matrix U in S = U' * B * V.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= max(1,N)
*> \endverbatim
*>
*> \param[in] VT
*> \verbatim
*>          VT is REAL array, dimension (LDVT,N)
*>          The n by ns orthogonal matrix V in S = U' * B * V.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*>          LDVT is INTEGER
*>          The leading dimension of the array VT.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          The test ratio:  norm(S - U' * B * V) / ( n * norm(B) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE SBDT04( UPLO, N, D, E, S, NS, U, LDU, VT, LDVT, WORK,
     $                   RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDU, LDVT, N, NS
      REAL               RESID
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * ), S( * ), U( LDU, * ),
     $                   VT( LDVT, * ), WORK( * )
*     ..
*
* ======================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, K
      REAL               BNORM, EPS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ISAMAX
      REAL               SASUM, SLAMCH
      EXTERNAL           LSAME, ISAMAX, SASUM, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, REAL, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible.
*
      RESID = ZERO
      IF( N.LE.0 .OR. NS.LE.0 )
     $   RETURN
*
      EPS = SLAMCH( 'Precision' )
*
*     Compute S - U' * B * V.
*
      BNORM = ZERO
*
      IF( LSAME( UPLO, 'U' ) ) THEN
*
*        B is upper bidiagonal.
*
         K = 0
         DO 20 I = 1, NS
            DO 10 J = 1, N-1
               K = K + 1
               WORK( K ) = D( J )*VT( I, J ) + E( J )*VT( I, J+1 )
   10       CONTINUE
            K = K + 1
            WORK( K ) = D( N )*VT( I, N )
   20    CONTINUE
         BNORM = ABS( D( 1 ) )
         DO 30 I = 2, N
            BNORM = MAX( BNORM, ABS( D( I ) )+ABS( E( I-1 ) ) )
   30    CONTINUE
      ELSE
*
*        B is lower bidiagonal.
*
         K = 0
         DO 50 I = 1, NS
            K = K + 1
            WORK( K ) = D( 1 )*VT( I, 1 )
            DO 40 J = 1, N-1
               K = K + 1
               WORK( K ) = E( J )*VT( I, J ) + D( J+1 )*VT( I, J+1 )
   40       CONTINUE
   50    CONTINUE
         BNORM = ABS( D( N ) )
         DO 60 I = 1, N-1
            BNORM = MAX( BNORM, ABS( D( I ) )+ABS( E( I ) ) )
   60    CONTINUE
      END IF
*
      CALL SGEMM( 'T', 'N', NS, NS, N, -ONE, U, LDU, WORK( 1 ),
     $            N, ZERO, WORK( 1+N*NS ), NS )
*
*     norm(S - U' * B * V)
*
      K = N*NS
      DO 70 I = 1, NS
         WORK( K+I ) =  WORK( K+I ) + S( I )
         RESID = MAX( RESID, SASUM( NS, WORK( K+1 ), 1 ) )
         K = K + NS
   70 CONTINUE
*
      IF( BNORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         IF( BNORM.GE.RESID ) THEN
            RESID = ( RESID / BNORM ) / ( REAL( N )*EPS )
         ELSE
            IF( BNORM.LT.ONE ) THEN
               RESID = ( MIN( RESID, REAL( N )*BNORM ) / BNORM ) /
     $                 ( REAL( N )*EPS )
            ELSE
               RESID = MIN( RESID / BNORM, REAL( N ) ) /
     $                 ( REAL( N )*EPS )
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of SBDT04
*
      END


      subroutine evspline(xget,x,nx,ilinx,f,ict,fval,ier)
C
C  use mkspline to set up spline coefficients...
C
C  evaluate a 1d cubic Spline interpolant -- this is C2
C
C  this subroutine calls two subroutines:
C     herm1x  -- find cell containing (xget)
C     fvspline  -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
      integer nx                        ! grid size
      real xget                         ! target of this interpolation
      real x(nx)                        ! ordered x grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
C
      real f(0:1,nx)                    ! function data
C
C  f(0,i) = f @ x(i)
C  f(1,i) = d2f/dx2 @ x(i)
C
C      (these are spline coefficients selected for continuous 2-
C      diffentiability, see mkspline.for)
C
      integer ict(3)                    ! code specifying output desired
C
C  ict(1)=1 -- return f  (0, don't)
C  ict(2)=1 -- return df/dx  (0, don't)
C  ict(3)=1 -- return d2f/dx2  (0, don't)
c
c        set ict(1)=3 to get d3f/dx3 (only)
C
C output arguments:
C =================
C
      real fval(*)                      ! output data
      integer ier                       ! error code =0 ==> no error
C
C  fval(1) receives the first output (depends on ict(...) spec)
C  fval(2) receives the second output (depends on ict(...) spec)
C  fval(3) receives the third output (depends on ict(...) spec)
C
C  examples:
C    on input ict = [1,1,1]
C   on output fval= [f,df/dx,d2f/dx2]
C
C    on input ict = [1,0,0]
C   on output fval= [f] ... elements 2 -- 3 never referenced.
C
C    on input ict = [0,0,1]
C   on output fval= [d2f/dx2] ... elements 2 -- 3 never referenced.
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer i(1)                         ! cell indices
C
C  normalized displacement from x(i) grid point.
C    xparam=0 @x(i)  xparam=1 @x(i+1)
C
      real xparam(1)
C
C  cell dimensions and
C  inverse cell dimensions hxi = 1/(x(i+1)-x(i))
C
      real hx(1)
      real hxi(1)
C
C  0 .le. xparam .le. 1
C
C  ** the interface is very similar to herm2ev.for; can use herm2xy **
C---------------------------------------------------------------------
C
      i(1)=0
C
      call herm1x(xget,x,nx,ilinx,i(1),xparam(1),hx(1),hxi(1),ier)
      if(ier.ne.0) return
c
      call fvspline(ict,1,1,fval,i,xparam,hx,hxi,f,nx)
C
      return
      end
C---------------------------------------------------------------------
C  evaluate C1 cubic Hermite function interpolation -- 2d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine fvspline(ict,ivec,ivecd,
     >   fval,ii,xparam,hx,hxi,fin,nx)
C
C  use mkspline to set up spline coefficients...
C
      integer ict(3)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec)                  ! target cells (i)
      real xparam(ivec)
                          ! normalized displacements from (i) corners
C
      real hx(ivec)                     ! grid spacing, and
      real hxi(ivec)                    ! inverse grid spacing 1/(x(i+1)-x(i))
C
      real fin(0:1,nx)                  ! interpolant data (cf "evspline")
C
      real fval(ivecd,*)                ! output returned
C
C  for detailed description of fin, ict and fval see subroutine
C  evspline comments.  Note ict is not vectorized; the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii and parameter inputs
C     xparam,hx,hxi, are vectorized, and the
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C  Spline evaluation consists of a "mixing" of the interpolant
C  data using the linear functionals xparam, xpi = 1-xparam,
C  xparam**3-xparam, xpi**3-xpi ...
C  and their derivatives as needed.
C
      integer v
C
      real sum
      real sixth
C
      data sixth/0.166666666666666667/
C
C---------------
C   ...in x direction
C
      iadr=0
C
      if(ict(1).le.2) then
C
C  normal call
C
         if(ict(1).eq.1) then
C
C  get desired values:
C
            iadr = iadr + 1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cx=xp*(xp2-1.0)
               cxi=xpi*(xpi2-1.0)
               hx2=hx(v)*hx(v)
C
C  function value:
C
               sum=xpi*fin(0,i) +xp*fin(0,i+1)
               sum=sum+sixth*hx2*(cxi*fin(1,i) +cx*fin(1,i+1))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0-xp
               xp2=xp*xp
               xpi2=xpi*xpi
C
               cxd=3.0*xp2-1.0
               cxdi=-3.0*xpi2+1.0

               sum=hxi(v)*(fin(0,i+1)-fin(0,i))
               sum=sum+sixth*hx(v)*(cxdi*fin(1,i) +cxd*fin(1,i+1))
C
               fval(v,iadr)=sum
            enddo
         endif
C
         if(ict(3).eq.1) then
C
C  d2f/dx2:
C
            iadr=iadr+1
            do v=1,ivec
               i=ii(v)
C
               xp=xparam(v)
               xpi=1.0-xp
C
               sum=xpi*fin(1,i) +xp*fin(1,i+1)
               fval(v,iadr)=sum
            enddo
         endif
C
      else
C
C  return fxxx = d3f/dx3
C
         iadr=1
         do v=1,ivec
            i=ii(v)
            fval(v,iadr)=hxi(v)*(fin(1,i+1)-fin(1,i))
         enddo
C
      endif
C
      return
      end


*> \brief \b zladivquad performs complex division in real arithmetic, avoiding unnecessary overflow.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download zladivquad + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       complex*32     FUNCTION zladivquad( X, Y )
*
*       .. Scalar Arguments ..
*       complex*32         X, Y
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> zladivquad := X / Y, where X and Y are complex.  The computation of X / Y
*> will not overflow on an intermediary step unless the results
*> overflows.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is complex*32
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is complex*32
*>          The complex scalars X and Y.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*  =====================================================================
      complex*32     FUNCTION zladivquad( X, Y )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      complex*32         X, Y
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      real*16   ZI, ZR
*     ..
*     .. External Subroutines ..
      EXTERNAL           dladivquad
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          real, CMPLX, AIMAG
*     ..
*     .. Executable Statements ..
*
      CALL dladivquad( real( X ), AIMAG( X ), real( Y ), AIMAG( Y ),
     $             ZR,ZI )
      zladivquad = CMPLX( ZR, ZI,16 )
*
      RETURN
*
*     End of zladivquad
*
      END


program matmul_test
  use iso_fortran_env, only : real64
  implicit none

  integer, parameter :: n = 3000
  real(real64),allocatable :: a(:,:),b(:,:),c(:,:)
  integer :: i,j

  allocate(a(n,n),b(n,n),c(n,n))

  do i = 1, n
     do j = 1, n
        a(i,j) = (i+j) * 0.5
        b(i,j) = (i+j) * 0.25
     end do
  end do

  !c = matmul(a,b)

  call dgemm('n','n',n,n,n,1.d0,a,n,b,n,0.d0,c,n)

  write(*,*) c(100,100)

end program matmul_test


program deletetest
  use flips

  ! Reads the riometer data and makes a fit iteratively.
  ! Outliers are deleted in every step.

  ! Writes the result as a file rio_res_<prec>.dat

  implicit none

  type(flips_d) :: h

  integer, parameter :: xlen = 40
  real(dp), parameter :: limit = 2.9
  real(dp), parameter :: pi = 3.14159265358979

  real(dp), dimension(2048) :: riodata, xax, fit,tmpx,tmpr
  real(dp), dimension(2048,xlen) :: model,tmpm
  real(dp), dimension(xlen) :: ntmp, sol, tmpsol
  real(dp) :: khi
  integer :: i,idx,currentProblemSize, auxidx,pidx
  integer, dimension(2048) :: oliers,modelmask
  logical, dimension(2048) :: olmask
  real(dp), dimension(:), allocatable :: delmod,deld

  ! Read riometer data
  open(123,FILE="rio_d.data",FORM='unformatted',access='stream')
  read(123,pos=1) riodata
  close(123)

  !write(*,*) riodata(1:10)
  !write(*,*) riodata(2048)

  ! Construct model matrix (sinusoidal model)
  xax_const: do i = 1,2048
     xax(i) = real(i)
  end do xax_const
  xax = (xax - 1.0)/2048.0

  ntmp_const: do i = 1,xlen
     ntmp(i) = real(i)
  end do ntmp_const

  model_const: do i = 1,2048
     model(i,:) = sin(pi * xax(i) * ntmp)
  end do model_const

  ! First FLIPS solution

  currentProblemSize = 2048

  call flips_init(h,xlen,1,buffersize=50)
  fadd: do i = 1,currentProblemSize
     call flips_add(h,1,model(i,:),(/ riodata(i) /))
  end do fadd

  !sol = 0.0

  ! Iteration starts here!
  main_iteration: do

     call flips_solve(h)
     !tmpsol = sol
     call flips_get('solu',h,sol)

     !write(*,*) sol

     fit = 0.0

     fit(1:currentProblemSize) = matmul(model(1:currentProblemSize,:),sol)

     khi = sqrt(sum((riodata(1:currentProblemSize)-fit(1:currentProblemSize))**2)/currentProblemSize)

     write(*,*) 'khi:',khi

!!$     ! Find outliers
!!$     idx = 0
!!$     oliers = 0
!!$     ol_search: do i = 1,currentProblemSize
!!$        if(abs(riodata(i) - fit(i)) > khi * limit) then
!!$           idx = idx + 1
!!$           oliers(idx) = i
!!$        end if
!!$     end do ol_search
!!$
!!$     write(*,*) oliers(1:idx)
!!$
!!$     !currentProblemSize = currentProblemSize - idx

     olmask = .FALSE.
     where(abs(riodata(1:currentProblemSize) - fit(1:currentProblemSize)) > khi * limit)
        olmask(1:currentProblemSize) = .TRUE.
     end where

     idx = count(olmask)

     write(*,*) 'Number of accepted data points:',currentProblemSize - idx,'rejected:',idx

     if (idx == 0) then
        exit main_iteration
     end if

     ! Construct deletion matrices
     allocate(delmod(idx*xlen),deld(idx))

     auxidx = 1
     do i = 1,currentProblemSize
        if (olmask(i)) then
           delmod(yind(auxidx,1,xlen):yind(auxidx,xlen,xlen)) = model(i,:)
           deld(auxidx) = riodata(i)
           auxidx = auxidx + 1
        end if
     end do

!write(*,*) delmod

     ! Delete rejected points
     !deletion: do i = 1,currentProblemSize
     !   if (olmask(i)) then
           call flipsdelete_d(h,idx,delmod,deld)
     !   end if
     !end do deletion

                deallocate(delmod,deld)

!write(*,*) 'hoo!'

!!$     ! Reformat data and model
!!$     auxidx = 1
!!$     pidx = 0
!!$     tmpx = 0.0
!!$     tmpr = 0.0
!!$     tmpm = 0.0
!!$     reformat: do i = 1,currentProblemSize
!!$        if (i == oliers(auxidx)) then
!!$           auxidx = auxidx + 1
!!$           !if (auxidx == idx + 1) then
!!$           !   exit reformat
!!$           !else
!!$           cycle reformat
!!$           !end if
!!$        else
!!$           pidx = pidx + 1
!!$           tmpx(pidx) = xax(i)
!!$           tmpr(pidx) = riodata(i)
!!$           tmpm(pidx,:) = model(i,:)
!!$        end if
!!$     end do reformat
!!$     !write(*,*) 'auxidx:',auxidx,'idx:',idx,'pidx:',pidx
!!$

!!$
!!$     xax = 0.0
!!$     riodata = 0.0
!!$     model = 0.0
!!$
!!$     xax = tmpx
!!$     riodata = tmpr
!!$     model = tmpm

     riodata(1:currentProblemSize-idx) = pack(riodata(1:currentProblemSize),.NOT.olmask(1:currentProblemSize))

     oliers(1:currentProblemSize) = (/ (i,i=1,currentProblemSize ) /)

     modelmask(1:currentProblemSize-idx) = pack(oliers(1:currentProblemSize),.NOT.olmask(1:currentProblemSize))

     model(1:currentProblemSize-idx,:) = model(modelmask,:)

     currentProblemSize = currentProblemSize - idx

     !write(*,*) riodata(1:10)

  end do main_iteration

  call flips_kill(h)

  ! Write solution
  open(123,FILE="rio_sol.data",access='stream',form='unformatted')
  write(123,pos=1) fit(1:currentProblemSize)
  close(123)

end program deletetest


!> IMPACT
!! \author Rolf Henniger, Institute of Fluid Dynamics, ETH Zurich (henniger@ifd.mavt.ethz.ch)
!! \date Mai 2005 - Dec 2011

!> \brief module providing functions to initiliaze and apply RestrictionOp
module cmod_InterpolationOp

  use iso_c_binding
  use mpi

  implicit none

contains

  subroutine MG_getCIS( &
      Nc,               &
      Nf,               &
      bL,               &
      bU,               &
      xf,               &
      dd,               &
      cI ) bind(c,name='MG_getCIS')

    implicit none

    integer(c_int), intent(in)  :: Nc
    integer(c_int), intent(in)  :: Nf
    integer(c_int), intent(in)  :: bL, bU

    real(c_double), intent(in)  :: xf(bL:(Nf+bU))

    integer(c_int), intent(in)  :: dd

    real(c_double), intent(out) :: cI(1:2,1:Nc)

    integer(c_int)              :: i,ic
    real(c_double)              :: Dx12

    cI = 0.

    !====================================================================================
    !=== Interpolation, linienweise, 1d =================================================
    !====================================================================================
    ! coarse
    !      ic                             ic+1
    !  ----o------------------------------o------------------------------o---------------
    !      |------Dx10----|
    !      |------------Dx12--------------|
    !  ----o--------------o---------------o-----------o-----
    !     xf(i-1)        xf(i)           xf(i+1)
    ! fine

    !------------------------------------------------------------------------------------
    do ic = 1, Nc

      i = dd * ic
      Dx12 = xf(i+1)-xf(i-1)

      cI(1,ic) = ( xf(i+1)-xf(i  ) )/Dx12
      cI(2,ic) = ( xf(i  )-xf(i-1) )/Dx12

    end do
    !------------------------------------------------------------------------------------

  end subroutine MG_getCIS

  !> \brief gets coefficents for interpolation of velocity points
  !!
  !! \param[in] Nc grid size on coarse grid
  !! \param[in] bLc lower ghost width on coarse grid
  !! \param[in] bUc upper ghost width on coarse grid
  !! \param[in] SSc start index on coarse grid
  !! \param[in] NNc end index on coarse grid
  !! \param[in] BC_L lower boundary conditions
  !! \param[in] BC_U upper boundary conditions
  !! \param[in] Nf grid size on fine grid
  !! \param[in] bLf lower ghost width on fine grid
  !! \param[in] bUf upper ghost width on fine grid
  !! \param[in] offset offset
  !! \param[in] xc coarse coordinates of velocity
  !! \param[in] xf fine coordinates of velocity
  !! \param[in] dd coarsening factor
  !! \param[out] cIV interpolation coefficients
  subroutine MG_getCIV( &
      Nc,               &
      bLc,              &
      bUc,              &
      !SSc,              &
      !NNc,              &
      BC_L,             &
      BC_U,             &
      Nf,               &
      bLf,              &
      bUf,              &
      offset,           &
      xc,               &
      xf,               &
      dd,               &
      cIV ) bind(c,name='MG_getCIV')

    implicit none

    integer(c_int), intent(in)    :: Nc

    integer(c_int), intent(in)    :: bLc, bUc

    !integer(c_int), intent(in)    :: SSc
    !integer(c_int), intent(in)    :: NNc

    integer(c_int), intent(in)    :: BC_L,BC_U

    integer(c_int), intent(in)    :: Nf

    integer(c_int), intent(in)    :: bLf, bUf

    integer(c_int), intent(in)    :: offset

    real(c_double), intent(in)    :: xc( bLc:(Nc+bUc) )

    real(c_double), intent(in)    :: xf( bLf:(Nf+bUf) )

    integer(c_int), intent(in)    :: dd

    real(c_double), intent(inout) :: cIV( 1:2, 0:Nf )

    integer(c_int)                ::  i, ic
    !real(c_double)                ::  Dx1a
    real(c_double)                ::  Dx12

    !====================================================================================
    !=== Interpolation, linienweise, 1d =================================================
    !====================================================================================
    ! fine
    !    xf(i-1)        xf(i)         xf(i+1)       xf(i+1)      xf(i+2)
    !  ---->-------------->--------------->----------->----------->------------
    !             |-----------Dx12--------------|
    !  ----------->----------------------------->----------------------------->----------
    !          xc(ic)                      xc(ic+1)                        xc(ic+1)
    ! coarse

    cIV = 0.

    do i = 0, Nf
      ic = ( i )/dd + offset

      !Dx1a = xc(ic)-xf(i   )
      !Dx12 = xc(ic)-xc(ic+1)

      !cIV(1,i) = 1-Dx1a/Dx12
      !cIV(2,i) =   Dx1a/Dx12

      Dx12 = xc(ic+1) - xc(ic)

      cIV(1,i) = ( xc(ic+1) - xf(i ) )/Dx12
      cIV(2,i) = ( xf(i   ) - xc(ic) )/Dx12

    end do

    ! a little bit shaky, please verify this when IO is ready
    !if (BC_L > 0) then
    !cIV( 1,0) = 0.
    !cIV( 2,0) = 1.
    !end if

    !maybe false
    if( BC_L == -2 )then
      cIV(1:2,0) = 0.
    end if

    !if (BC_U > 0) then
    !cIV(1,Nf) = 1.
    !cIV(2,Nf) = 0.
    !end if
    if( BC_U == -2 )then
      cIV(1:2,Nf) = 0.
    end if

  end subroutine MG_getCIV

  !> \brief corrects values at corners through extrapolation
  !!
  !! \param[in] n
  !! \param[in] bL
  !! \param[in] bU
  !! \param[in] BCL
  !! \param[in] BCU
  !! \param[in] x1
  !! \param[in] x2
  !! \param[in] x3
  !! \param[inout] phi \f$\phi\f$
  !!
  !! \f[ \phi[2] = \frac{ \phi[4]-\phi[3] }{x[4]-x[3]} ( x[2]-x[3] )\f]
  !! \f[ \phi[n-1] = \frac{ \phi[n-2]-\phi[n-3] }{x[n-2]-x[n-3]} ( x[n-1]-x[n-2] )\f]
  subroutine MG_InterpolateCornersPost( &
      n,                                &
      bL,                               &
      bU,                               &
      BCL,                              &
      BCU,                              &
      x1,                               &
      x2,                               &
      x3,                               &
      phi ) bind(c,name='MG_InterpolateCornersPost')

    implicit none

    integer(c_int), intent(in)    :: n(3)

    integer(c_int), intent(in)    :: bL(3)
    integer(c_int), intent(in)    :: bU(3)

    integer(c_int), intent(in)    :: BCL(3)
    integer(c_int), intent(in)    :: BCU(3)

    real(c_double), intent(in)    :: x1( bL(1):(n(1)+bU(1)) )
    real(c_double), intent(in)    :: x2( bL(2):(n(2)+bU(2)) )
    real(c_double), intent(in)    :: x3( bL(3):(n(3)+bU(3)) )

    real(c_double), intent(inout) :: phi( bL(1):(n(1)+bU(1)), bL(2):(n(2)+bU(2)), bL(3):(n(3)+bU(3)) )

    integer(c_int) :: s(3), e(3), i

    do i = 1, 3

      if( BCL(i)>0 ) then
        s(i) = 2
      else
        s(i) = 1
      end if

      if( BCU(i)>0 ) then
        e(i) = n(i)-1
      else
        e(i) = n(i)
      end if

    end do

    if( BCL(1)>0 .and. BCL(2)>0 ) then
      phi(1, 1, s(3):e(3)) = 0.
      phi(2, 1, s(3):e(3)) = ( phi( 4, 1, s(3):e(3)) - phi( 3, 1, s(3):e(3)) )/( x1(4) - x1(3) )*( x1(2) - x1(3) ) + phi( 3, 1, s(3):e(3))
      phi(1, 2, s(3):e(3)) = ( phi( 1, 4, s(3):e(3)) - phi( 1, 3, s(3):e(3)) )/( x2(4) - x2(3) )*( x2(2) - x2(3) ) + phi( 1, 3, s(3):e(3))
      phi(2, 2, s(3):e(3)) = ( &
        phi( 1, 2, s(3):e(3))*( x1(3)-x1(2) )/( x1(3)-x1(1) ) + &
        phi( 3, 2, s(3):e(3))*( x1(2)-x1(1) )/( x1(3)-x1(1) ) + &
        phi( 2, 1, s(3):e(3))*( x2(3)-x2(2) )/( x2(3)-x2(1) ) + &
        phi( 2, 3, s(3):e(3))*( x2(2)-x2(1) )/( x2(3)-x2(1) )   &
        )/2.
    endif
    if( BCL(1)>0 .and. BCU(2)>0 ) then
      phi(1, n(2)  , s(3):e(3)) =  0.
      phi(2, n(2)  , s(3):e(3)) = ( phi(4, n(2)  , s(3):e(3)) - phi(3, n(2)  , s(3):e(3)) )/( x1(4)      - x1(3)      )*( x1(2)      - x1(3)      ) + phi(3, n(2)  , s(3):e(3))
      phi(1, n(2)-1, s(3):e(3)) = ( phi(1, n(2)-2, s(3):e(3)) - phi(1, n(2)-3, s(3):e(3)) )/( x2(n(2)-2) - x2(n(2)-3) )*( x2(n(2)-1) - x2(n(2)-2) ) + phi(1, n(2)-2, s(3):e(3))
      phi(2, n(2)-1, s(3):e(3)) = ( &
        phi(1, n(2)-1, s(3):e(3))*( x1(3)     -x1(2)      )/( x1(3)-x1(1)         ) + &
        phi(3, n(2)-1, s(3):e(3))*( x1(2)     -x1(1)      )/( x1(3)-x1(1)         ) + &
        phi(2, n(2)  , s(3):e(3))*( x2(n(2)-1)-x2(n(2)-2) )/( x2(n(2))-x2(n(2)-2) ) + &
        phi(2, n(2)-2, s(3):e(3))*( x2(n(2)  )-x2(n(2)-1) )/( x2(n(2))-x2(n(2)-2) )   &
        )/2.
    endif
    if( BCU(1)>0 .and. BCL(2)>0 ) then
      phi(n(1)  , 1, s(3):e(3)) = 0.
      phi(n(1)-1, 1, s(3):e(3)) = ( phi(n(1)-2, 1, s(3):e(3)) - phi(n(1)-3, 1, s(3):e(3)) )/( x1(n(1)-2) - x1(n(1)-3) )*( x1(n(1)-1) - x1(n(1)-2) ) + phi(n(1)-2, 1, s(3):e(3))
      phi(n(1)  , 2, s(3):e(3)) = ( phi(n(1)  , 4, s(3):e(3)) - phi(n(1)  , 3, s(3):e(3)) )/( x2(4) - x2(3) )*( x2(2) - x2(3) )                     + phi(n(1)  , 3, s(3):e(3))
      phi(n(1)-1, 2, s(3):e(3)) = ( &
        phi(n(1)  , 2, s(3):e(3))*( x1(n(1)-1)-x1(n(1)-2) )/( x1(n(1))-x1(n(1)-2) ) + &
        phi(n(1)-2, 2, s(3):e(3))*( x1(n(1)  )-x1(n(1)-1) )/( x1(n(1))-x1(n(1)-2) ) + &
        phi(n(1)-1, 1, s(3):e(3))*( x2(3)-x2(2) )/( x2(3)-x2(1) ) + &
        phi(n(1)-1, 3, s(3):e(3))*( x2(2)-x2(1) )/( x2(3)-x2(1) )   &
        )/2.
    endif
    if( BCU(1)>0 .and. BCU(2)>0 ) then
      phi(n(1)  , n(2)  , s(3):e(3)) = 0.
      phi(n(1)-1, n(2)  , s(3):e(3)) = ( phi(n(1)-2, n(2)  , s(3):e(3)) - phi(n(1)-3, n(2)  , s(3):e(3)) )/( x1(n(1)-2) - x1(n(1)-3) )*( x1(n(1)-1) - x1(n(1)-2) ) + phi(n(1)-2, n(2)  , s(3):e(3))
      phi(n(1)  , n(2)-1, s(3):e(3)) = ( phi(n(1)  , n(2)-2, s(3):e(3)) - phi(n(1)  , n(2)-3, s(3):e(3)) )/( x2(n(2)-2) - x2(n(2)-3) )*( x2(n(2)-1) - x2(n(2)-2) ) + phi(n(1)  , n(2)-2, s(3):e(3))
      phi(n(1)-1, n(2)-1, s(3):e(3)) = ( &
        phi(n(1)-1, n(2)  , s(3):e(3))*( x2(n(2)-1)-x2(n(2)-2) )/( x2(n(2))-x2(n(2)-2) ) + &
        phi(n(1)-1, n(2)-2, s(3):e(3))*( x2(n(2)  )-x2(n(2)-1) )/( x2(n(2))-x2(n(2)-2) ) + &
        phi(n(1)  , n(2)-1, s(3):e(3))*( x1(n(1)-1)-x1(n(1)-2) )/( x1(n(1))-x1(n(1)-2) ) + &
        phi(n(1)-2, n(2)-1, s(3):e(3))*( x1(n(1)  )-x1(n(1)-1) )/( x1(n(1))-x1(n(1)-2) )   &
        )/2.
    endif

    if( BCL(1)>0 .and. BCL(3)>0 ) then
      phi(1, s(2):e(2), 1) = 0.
      phi(2, s(2):e(2), 1) = ( phi(4, s(2):e(2), 1)-phi(3, s(2):e(2), 1) )/( x1(4)-x1(3) )*( x1(2)-x1(3) ) + phi(3, s(2):e(2), 1)
      phi(1, s(2):e(2), 2) = ( phi(1, s(2):e(2), 4)-phi(1, s(2):e(2), 3) )/( x3(4)-x3(3) )*( x3(2)-x3(3) ) + phi(1, s(2):e(2), 3)
      phi(2, s(2):e(2), 2) = ( &
        phi(2, s(2):e(2), 1)*( x3(3)-x3(2) )/( x3(3)-x3(1) ) + &
        phi(2, s(2):e(2), 3)*( x3(2)-x3(1) )/( x3(3)-x3(1) ) + &
        phi(1, s(2):e(2), 2)*( x1(3)-x1(2) )/( x1(3)-x1(1) ) + &
        phi(3, s(2):e(2), 2)*( x1(2)-x1(1) )/( x1(3)-x1(1) )   &
        )/2.
    endif
    if( BCL(1)>0 .and. BCU(3)>0 ) then
      phi(1, s(2):e(2), n(3)  ) = 0
      phi(2, s(2):e(2), n(3)  ) = ( phi(4, s(2):e(2), n(3)  )-phi(3, s(2):e(2), n(3)  ) )/( x1(4)-x1(3) )*( x1(2)-x1(3) )                     + phi(3, s(2):e(2), n(3)  )
      phi(1, s(2):e(2), n(3)-1) = ( phi(1, s(2):e(2), n(3)-2)-phi(1, s(2):e(2), n(3)-3) )/( x3(n(3)-2)-x3(n(3)-3) )*( x3(n(3)-1)-x3(n(3)-2) ) + phi(1, s(2):e(2), n(3)-2)
      phi(2, s(2):e(2), n(3)-1) = ( &
        phi(2, s(2):e(2), n(3)  )*( x3(n(3)-1)-x3(n(3)-2) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(2, s(2):e(2), n(3)-2)*( x3(n(3)  )-x3(n(3)-1) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(1, s(2):e(2), n(3)-1)*( x1(3)-x1(2) )/( x1(3)-x1(1) ) + &
        phi(3, s(2):e(2), n(3)-1)*( x1(2)-x1(1) )/( x1(3)-x1(1) ) &
        )/2.
    endif
    if( BCU(1)>0 .and. BCL(3)>0 ) then
      phi(n(1)  , s(2):e(2), 1) = 0.
      phi(n(1)-1, s(2):e(2), 1) = ( phi(n(1)-2, s(2):e(2), 1) - phi(n(1)-3, s(2):e(2), 1) )/( x1(n(1)-2)-x1(n(1)-3) )*( x1(n(1)-1)-x1(n(1)-2) ) + phi(n(1)-2, s(2):e(2), 1)
      phi(n(1)  , s(2):e(2), 2) = ( phi(n(1)  , s(2):e(2), 4) - phi(n(1)  , s(2):e(2), 3) )/( x3(4)     -x3(3)      )*( x3(2)     -x3(3)      ) + phi(n(1)  , s(2):e(2), 3)
      phi(n(1)-1, s(2):e(2), 2) = ( &
        phi(n(1)  , s(2):e(2), 2)*( x1(n(1)-1)-x1(n(1)-2) )/( x1(n(1))-x1(n(1)-2) ) + &
        phi(n(1)-2, s(2):e(2), 2)*( x1(n(1)  )-x1(n(1)-1) )/( x1(n(1))-x1(n(1)-2) ) + &
        phi(n(1)-1, s(2):e(2), 1)*( x3(3)     -x3(2)      )/( x3(3)   -x3(1)      ) + &
        phi(n(1)-1, s(2):e(2), 3)*( x3(2)     -x3(1)      )/( x3(3)   -x3(1)      )   &
        )/2.
    endif
    if( BCU(1)>0 .and. BCU(3)>0 ) then
      phi(n(1)  , s(2):e(2)  , n(3)  ) = 0.
      phi(n(1)-1, s(2):e(2), n(3)  ) = ( phi(n(1)-2, s(2):e(2), n(3)  )-phi(n(1)-3, s(2):e(2), n(3)  ) )/( x1(n(1)-2)-x1(n(1)-3) )*( x1(n(1)-1)-x1(n(1)-2) ) + phi(n(1)-2, s(2):e(2), n(3)  )
      phi(n(1)  , s(2):e(2), n(3)-1) = ( phi(n(1)  , s(2):e(2), n(3)-2)-phi(n(1)  , s(2):e(2), n(3)-3) )/( x3(n(3)-2)-x3(n(3)-3) )*( x3(n(3)-1)-x3(n(3)-2) ) + phi(n(1)  , s(2):e(2), n(3)-2)
      phi(n(1)-1, s(2):e(2), n(3)-1) = ( &
        phi(n(1)-1, s(2):e(2), n(3)  )*( x3(n(3)-1)-x3(n(3)-2) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(n(1)-1, s(2):e(2), n(3)-2)*( x3(n(3)  )-x3(n(3)-1) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(n(1)  , s(2):e(2), n(3)-1)*( x1(n(1)-1)-x1(n(1)-2) )/( x1(n(1))-x1(n(1)-2) ) + &
        phi(n(1)-2, s(2):e(2), n(3)-1)*( x1(n(1)  )-x1(n(1)-1) )/( x1(n(1))-x1(n(1)-2) )   &
        )/2.
    endif

    if( BCL(2)>0 .and. BCL(3)>0 ) then
      phi(s(1):e(1), 1, 1 ) = 0.
      phi(s(1):e(1), 2, 1 ) = ( phi(s(1):e(1), 4, 1 )-phi(s(1):e(1), 3, 1 ) )/( x2(4)-x2(3) )*( x2(2)-x2(3) ) + phi(s(1):e(1), 3, 1 )
      phi(s(1):e(1), 1, 2 ) = ( phi(s(1):e(1), 1, 4 )-phi(s(1):e(1), 1, 3 ) )/( x3(4)-x3(3) )*( x3(2)-x3(3) ) + phi(s(1):e(1), 1, 3 )
      phi(s(1):e(1), 2, 2 ) = ( &
        phi(s(1):e(1), 2, 1 )*( x3(3)-x3(2) )/( x3(3)-x3(1) ) + &
        phi(s(1):e(1), 2, 3 )*( x3(2)-x3(1) )/( x3(3)-x3(1) ) + &
        phi(s(1):e(1), 1, 2 )*( x2(3)-x2(2) )/( x2(3)-x2(1) ) + &
        phi(s(1):e(1), 3, 2 )*( x2(2)-x2(1) )/( x2(3)-x2(1) )   &
        )/2.
    endif
    if( BCL(2)>0 .and. BCU(3)>0 ) then
      phi(s(1):e(1), 1, n(3)  ) = 0.
      phi(s(1):e(1), 2, n(3)  ) = ( phi(s(1):e(1), 4, n(3)  )-phi(s(1):e(1), 3, n(3)  ) )/( x2(4)     -x2(3)      )*( x2(2)     -x2(3)      ) + phi(s(1):e(1), 3, n(3)  )
      phi(s(1):e(1), 1, n(3)-1) = ( phi(s(1):e(1), 1, n(3)-2)-phi(s(1):e(1), 1, n(3)-3) )/( x3(n(3)-2)-x3(n(3)-3) )*( x3(n(3)-1)-x3(n(3)-2) ) + phi(s(1):e(1), 1, n(3)-2)
      phi(s(1):e(1), 2, n(3)-1) = ( &
        phi(s(1):e(1), 2, n(3)  )*( x3(n(3)-1)-x3(n(3)-2) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(s(1):e(1), 2, n(3)-2)*( x3(n(3)  )-x3(n(3)-1) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(s(1):e(1), 1, n(3)-1)*( x2(3)     -x2(2)      )/( x2(3)-x2(1)         ) + &
        phi(s(1):e(1), 3, n(3)-1)*( x2(2)     -x2(1)      )/( x2(3)-x2(1)         ) &
        )/2.
    endif
    if( BCU(2)>0 .and. BCL(3)>0 ) then
      phi(s(1):e(1), n(2)  , 1 ) = 0.
      phi(s(1):e(1), n(2)-1, 1 ) = ( phi(s(1):e(1), n(2)-2, 1)-phi(s(1):e(1), n(2)-3, 1) )/( x2(n(2)-2)-x2(n(2)-3) )*( x2(n(2)-1)-x2(n(2)-2) ) + phi(s(1):e(1), n(2)-2, 1)
      phi(s(1):e(1), n(2)  , 2 ) = ( phi(s(1):e(1), n(2)  , 4)-phi(s(1):e(1), n(2)  , 3) )/( x3(4)     -x3(3)      )*( x3(2)     -x3(3)      ) + phi(s(1):e(1), n(2),   3)
      phi(s(1):e(1), n(2)-1, 2 ) = ( &
        phi(s(1):e(1), n(2)-1, 1)*( x3(3)     -x3(2)      )/( x3(3)-x3(1)         ) + &
        phi(s(1):e(1), n(2)-1, 3)*( x3(2)     -x3(1)      )/( x3(3)-x3(1)         ) + &
        phi(s(1):e(1), n(2)  , 2)*( x2(n(2)-1)-x2(n(2)-2) )/( x2(n(2))-x2(n(2)-2) ) + &
        phi(s(1):e(1), n(2)-2, 2)*( x2(n(2)  )-x2(n(2)-1) )/( x2(n(2))-x2(n(2)-2) ) &
        )/2.
    endif
    if( BCU(2)>0 .and. BCU(3)>0 ) then
      phi(s(1):e(1), n(2)  , n(3)  ) = 0.
      phi(s(1):e(1), n(2)-1, n(3)  ) = ( phi(s(1):e(1), n(2)-2, n(3)  )-phi(s(1):e(1), n(2)-3, n(3)  ) )/( x2(n(2)-2)-x2(n(2)-3) )*( x2(n(2)-1)-x2(n(2)-2) ) + phi(s(1):e(1), n(2)-2, n(3)  )
      phi(s(1):e(1), n(2)  , n(3)-1) = ( phi(s(1):e(1), n(2)  , n(3)-2)-phi(s(1):e(1), n(2)  , n(3)-3) )/( x3(n(3)-2)-x3(n(3)-3) )*( x3(n(3)-1)-x3(n(3)-2) ) + phi(s(1):e(1), n(2)  , n(3)-2)
      phi(s(1):e(1), n(2)-1, n(3)-1) = (                                                   &
        phi(s(1):e(1), n(2)-1, n(3)  )*( x3(n(3)-1)-x3(n(3)-2) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(s(1):e(1), n(2)-1, n(3)-2)*( x3(n(3)  )-x3(n(3)-1) )/( x3(n(3))-x3(n(3)-2) ) + &
        phi(s(1):e(1), n(2),   n(3)-1)*( x2(n(2)-1)-x2(n(2)-2) )/( x2(n(2))-x2(n(2)-2) ) + &
        phi(s(1):e(1), n(2)-2, n(3)-1)*( x2(n(2)  )-x2(n(2)-1) )/( x2(n(2))-x2(n(2)-2) )   &
        )/2.
    endif

  end subroutine MG_InterpolateCornersPost

  !> \note:       - für allgemeine dd geeignet
  !!              - dd(i) /= 1 <===> N(i) /= 1
  !!              - es wird nur in eine Richung ausgetauscht
  !!              - Null-Setzen am Rand nicht notwendig
  !!              - Es wird sequentiell über alle Raumrichtungen interpoliert,
  !!                um keinen individuellen Interpolationsstencil für jeden
  !!                Punkt im Raum speichern zu müssen.
  !!              - Durch das sequentielle Interpolieren kann der
  !!                Interpolationsstencil klein und damit der Gesamtaufwand
  !!                minimiert werden (Alternative: 8- bzw. 26-Punkt Stencil(!)).
  !!              - Interpolationskoeffizienten werden auf dem jeweils feineren
  !!                Gitter gespeichert, um nicht auf die entsprechenden Indizes
  !!                des gröberen Gitters umrechnen zu müssen.
  !!              - Die Block-überlappenden Stirnflächen werden ebenfalls
  !!                mitverarbeitet, aber eigentlich nicht gebraucht (erleichtert
  !!                die Programmierung), so dass eigentlich eine Initialisierung
  !!                notwendig wäre. Dies wird jedoch zuvor schon in der
  !!                korrespondierenden Restriktions-Routine erledigt, so dass
  !!                dies hier nicht mehr notwendig ist.
  !!
  !! \attention: Verwendung von parametrischen Strides dd in Schleifen
  !! verhindert die Vektorisierung bzw. das Prefetching! Andererseits ist der
  !! Geschwindigkeitsgewinn nur sehr gering (schon getestet).
  !!
  !! - Geschwindigkeit ist trotz Prefetching / Vektorisierung stark durch die
  !!   Speicherzugriffszeit limitiert
  !! - Das wird z.B. deutlich bei Single- vs.  Dualcorebetrieb
  subroutine MG_interpolate(  &
      Nc,                     &
      bLc,                    &
      bUc,                    &
      Nf,                     &
      bLf,                    &
      bUf,                    &
      iimax,                  &
      dd,                     &
      cI1,                    &
      cI2,                    &
      cI3,                    &
      phic,                   &
      phif ) bind(c,name='MG_interpolate')

    implicit none

    integer(c_int), intent(in)     :: Nc(3)

    integer(c_int), intent(in)     :: bLc(3)
    integer(c_int), intent(in)     :: bUc(3)

    integer(c_int), intent(in)     :: Nf(3)

    integer(c_int), intent(in)     :: bLf(3)
    integer(c_int), intent(in)     :: bUf(3)

    integer(c_int), intent(in)     :: iimax(3)
    integer(c_int), intent(in)     :: dd(3)

    real(c_double),  intent(in)    :: cI1 ( 1:2, 1:Nc(1) )
    real(c_double),  intent(in)    :: cI2 ( 1:2, 1:Nc(2) )
    real(c_double),  intent(in)    :: cI3 ( 1:2, 1:Nc(3) )

    real(c_double),  intent(in) :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    real(c_double),  intent(out)   :: phif (bLf(1):(Nf(1)+bUf(1)),bLf(2):(Nf(2)+bUf(2)),bLf(3):(Nf(3)+bUf(3)))

    integer(c_int)               ::  i,ic
    integer(c_int)               ::  j
    integer(c_int)               ::  k

    !************************************************************************************
    !pgi$ unroll = n:8
    phif( 1:Nf(1):dd(1), 1:Nf(2):dd(2), 1:Nf(3):dd(3) ) = phic( 1:iimax(1), 1:iimax(2), 1:iimax(3) )
    !************************************************************************************
    !====================================================================================
    if( dd(3) /= 1 ) then ! (dimens == 2) <==> (dd(3) == 1) automatisch erfüllt!

      do k = 1+1, Nf(3)-1, dd(3)
        ic = k/dd(3)
        do j = 1, Nf(2), dd(2)
          !pgi$ unroll = n:8
          do i = 1, Nf(1), dd(1)
            phif(i,j,k) = cI3(1,ic)*phif(i,j,k-1) + cI3(2,ic)*phif(i,j,k+1)
          end do
        end do
      end do

    end if
    !====================================================================================
    if( dd(2) /= 1 ) then ! TEST!!! in 2D wird hier doppelte Arbeit geleistet! (NNf(3) == 2??)

      do k = 1, Nf(3)
        do j = 1+1, Nf(2)-1, dd(2)
          ic = j/dd(2)
          !pgi$ unroll = n:8
          do i = 1, Nf(1), dd(1)
            phif(i,j,k) = cI2(1,ic)*phif(i,j-1,k) + cI2(2,ic)*phif(i,j+1,k)
          end do
        end do
      end do

    end if
    !====================================================================================
    if( dd(1) /= 1 ) then

      do k = 1, Nf(3)
        do j = 1, Nf(2)
          !pgi$ unroll = n:8
          do i = 1+1, Nf(1)-1, dd(1)
            ic = i/dd(1)
            phif(i,j,k) = cI1(1,ic)*phif(i-1,j,k) + cI1(2,ic)*phif(i+1,j,k)
          end do
        end do
      end do

    end if
    !====================================================================================

  end subroutine MG_interpolate

  !> \brief interpolating velocities
  subroutine MG_interpolateV( &
      dir,                    &
      Nc,                     &
      bLc,bUc,                &
      !SSc,NNc,                &
      Nf,                     &
      bLf,bUf,                &
      !SSf,NNf,                &
      iimax,                  &
      dd,                     &
      cIV,                    &
      cI1,                    &
      cI2,                    &
      cI3,                    &
      phic,                   &
      phif ) bind (c,name='MG_interpolateV')

    implicit none

    integer(c_int), intent(in)     :: dir

    integer(c_int), intent(in)     :: Nc(1:3)

    integer(c_int), intent(in)     :: bLc(1:3)
    integer(c_int), intent(in)     :: bUc(1:3)

    !integer(c_int), intent(in)     :: SSc(1:3)
    !integer(c_int), intent(in)     :: NNc(1:3)

    integer(c_int), intent(in)     :: Nf(1:3)

    integer(c_int), intent(in)     :: bLf(1:3)
    integer(c_int), intent(in)     :: bUf(1:3)

    !integer(c_int), intent(in)     :: SSf(1:3)
    !integer(c_int), intent(in)     :: NNf(1:3)

    !integer(c_int), intent(in)     :: BCL(1:3)
    !integer(c_int), intent(in)     :: BCU(1:3)

    integer(c_int), intent(in)     :: iimax(1:3)
    integer(c_int), intent(in)     :: dd(1:3)

    real(c_double),  intent(in)    :: cIV ( 1:2, 0:Nf(dir) )

    real(c_double),  intent(in)    :: cI1 ( 1:2, 1:Nc(1) )
    real(c_double),  intent(in)    :: cI2 ( 1:2, 1:Nc(2) )
    real(c_double),  intent(in)    :: cI3 ( 1:2, 1:Nc(3) )

    real(c_double),  intent(in)   :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    real(c_double),  intent(out)  :: phif (bLf(1):(Nf(1)+bUf(1)),bLf(2):(Nf(2)+bUf(2)),bLf(3):(Nf(3)+bUf(3)))

    integer(c_int)                ::  i, ic
    integer(c_int)                ::  j, jc
    integer(c_int)                ::  k, kc

    !integer(c_int)                :: l

    !integer(c_int)                :: S(1:3)
    !integer(c_int)                :: N(1:3)
    integer(c_int)                :: ds(1:3)

    ds = dd

    do i = 1,3
      if( iimax(i)<Nc(i) ) ds = 1
    end do

    if( 1==dir ) then

      if( dd(1) /= 1 ) then

        do k = 1, Nf(3), dd(3)
          if( 1==dd(3) ) then
            kc = k
          else
            kc = ( k+1 )/dd(3)
          end if
          do j = 1, Nf(2), dd(2)
            if( 1==dd(2) ) then
              jc = j
            else
              jc = ( j+1 )/dd(2) ! holy shit
            end if
            do i = 0, Nf(1) ! zero for dirichlet
              ic = ( i )/dd(1)
              phif(i,j,k) = cIV(1,i)*phic(ic,jc,kc) + cIV(2,i)*phic(ic+1,jc,kc)
            end do
          end do
        end do

      else

        do k = 1, Nf(3), dd(3)
          if( 1==dd(3) ) then
            kc = k
          else
            kc = ( k+1 )/dd(3)
          end if
          do j = 1, Nf(2), dd(2)
            if( 1==dd(2) ) then
              jc = j
            else
              jc = ( j+1 )/dd(2) ! holy shit
            end if
            do i = 0, Nf(1)
              phif(i,j,k) = phic(i,jc,kc)
            end do
          end do
        end do

      end if

      if( dd(2) /= 1 ) then

        do k = 1, Nf(3), dd(3)
          do j = 2, Nf(2)-1, dd(2)
            jc = ( j )/dd(2)
            !pgi$ unroll = n:8
            do i = 0, Nf(1)
              phif(i,j,k) = cI2(1,jc)*phif(i,j-1,k) + cI2(2,jc)*phif(i,j+1,k)
            end do
          end do
        end do

      end if

      if( dd(3) /= 1 ) then

        do k = 2, Nf(3)-1, dd(3)
          kc = k/dd(3)
          do j = 1, Nf(2)
            !pgi$ unroll = n:8
            do i = 0, Nf(1)
              phif(i,j,k) = cI3(1,kc)*phif(i,j,k-1) + cI3(2,kc)*phif(i,j,k+1)
            end do
          end do
        end do

      end if

    end if

    if( 2==dir ) then

      if( dd(2) /= 1 ) then

        do k = 1, Nf(3), dd(3)
          if( 1==dd(3) ) then
            kc = k
          else
            kc = ( k+1 )/dd(3)
          end if
          do j = 0, Nf(2) ! zero for dirichlet
            jc = ( j )/dd(2)
            do i = 1, Nf(1), dd(1)
              if( 1==dd(1) ) then
                ic = i
              else
                ic = ( i+1 )/dd(1) ! holy shit
              end if
              phif(i,j,k) = cIV(1,j)*phic(ic,jc,kc)+cIV(2,j)*phic(ic,jc+1,kc)
            end do
          end do
        end do

      else

        do k = 1, Nf(3), dd(3)
          if( 1==dd(3) ) then
            kc = k
          else
            kc = ( k+1 )/dd(3)
          end if
          do j = 0, Nf(2)
            do i = 1, Nf(1), dd(1)
              if( 1==dd(1) ) then
                ic = i
              else
                ic = ( i+1 )/dd(1) ! holy shit
              end if
              phif(i,j,k) = phic(ic,j,kc)
            end do
          end do
        end do

      end if

      if( dd(1) /= 1 ) then

        do k = 1, Nf(3), dd(3)
          do j = 0, Nf(2)
            !pgi$ unroll = n:8
            do i = 2, Nf(1)-1, dd(1)
              ic = i/dd(1)
              phif(i,j,k) = cI1(1,ic)*phif(i-1,j,k) + cI1(2,ic)*phif(i+1,j,k)
            end do
          end do
        end do

      end if

      if( dd(3) /= 1 ) then

        do k = 2, Nf(3)-1, dd(3)
          kc = k/dd(3)
          do j = 0, Nf(2)
            !pgi$ unroll = n:8
            do i = 1, Nf(1)
              phif(i,j,k) = cI3(1,kc)*phif(i,j,k-1) + cI3(2,kc)*phif(i,j,k+1)
            end do
          end do
        end do

      end if

    end if

    if( 3==dir ) then

      if( dd(3) /= 1 ) then

        do k = 0, Nf(3)
          kc = ( k )/dd(3)
          do j = 1, Nf(2), dd(2) ! zero for dirichlet
            if( 1==dd(2) ) then
              jc = j
            else
              jc = ( j+1 )/dd(2)
            end if
            do i = 1, Nf(1), dd(1)
              if( 1==dd(1) ) then
                ic = i
              else
                ic = ( i+1 )/dd(1) ! holy shit
              end if
              phif(i,j,k) = cIV(1,k)*phic(ic,jc,kc)+cIV(2,k)*phic(ic,jc,kc+1)
            end do
          end do
        end do

      else

        do k = 0, Nf(3)
          do j = 1, Nf(2), dd(2)
            if( 1==dd(2) ) then
              jc = j
            else
              jc = ( j+1 )/dd(2)
            end if
            do i = 1, Nf(1), dd(1)
              if( 1==dd(1) ) then
                ic = i
              else
                ic = ( i+1 )/dd(1) ! holy shit
              end if
              phif(i,j,k) = phic(ic,jc,k)
            end do
          end do
        end do

      end if

      if( dd(1) /= 1 ) then

        do k = 0, Nf(3)
          do j = 1, Nf(2), dd(2)
            !pgi$ unroll = n:8
            do i = 2, Nf(1)-1, dd(1)
              ic = i/dd(1)
              phif(i,j,k) = cI1(1,ic)*phif(i-1,j,k) + cI1(2,ic)*phif(i+1,j,k)
            end do
          end do
        end do

      end if

      if( dd(2) /= 1 ) then

        do k = 0, Nf(3)
          do j = 2, Nf(2)-1, dd(2)
            jc = j/dd(2)
            !pgi$ unroll = n:8
            do i = 1, Nf(1)
              phif(i,j,k) = cI2(1,jc)*phif(i,j-1,k) + cI2(2,jc)*phif(i,j+1,k)
            end do
          end do
        end do

      end if

    end if

  end subroutine MG_interpolateV

  !> \brief
  !! \note todo understand recevbuf size not correct
  subroutine MG_InterpolateScatter( &
      Nc,                           &
      bLc,                          &
      bUc,                          &
      !np,                           &
      iimax,                        &
      n_gather,                     &
      participate_yes,              &
      rankc2,                       &
      comm2,                        &
      dispI,                        &
      offsI,                        &
      phic ) bind(c,name='MG_InterpolateScatter')

    implicit none

    integer(c_int), intent(in)     :: Nc(3)

    integer(c_int), intent(in)     :: bLc(3)
    integer(c_int), intent(in)     :: bUc(3)

    !integer(c_int), intent(in)     :: np(3)

    integer(c_int), intent(in)     :: iimax(3)

    integer(c_int), intent(in)     :: n_gather(3)

    logical(c_bool), intent(in)    :: participate_yes

    integer(c_int), intent(in)     :: rankc2

    integer(c_int), intent(in)     :: comm2

    integer(c_int), intent(in)     :: dispI(     1:n_gather(1)*n_gather(2)*n_gather(3) )
    integer(c_int), intent(in)     :: offsI(1:3, 1:n_gather(1)*n_gather(2)*n_gather(3) )

    real(c_double),intent(inout)   :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    integer(c_int)                ::  i, ii
    integer(c_int)                ::  j, jj
    integer(c_int)                ::  k, kk

    integer(c_int)                ::  merror
    real(c_double), allocatable   ::  recvbuf(:,:,:)
    integer(c_int)                ::  offsg(1:3), dispg
    !real(c_double)                ::  sendbuf( 1:( ( Nc(1)+np(1)-1 )*( Nc(2)+np(2)-1 )*( Nc(3)+np(3)-1 ) ) ) ! from IMPACT
    !real(c_double)                ::  sendbuf( 0:( ( Nc(1)+np(1)*3 )*( Nc(2)+np(2)*3 )*( Nc(3)+np(3)*3 ) ) )
    real(c_double)                ::  sendbuf( 0:( (iimax(1)+1)*(iimax(2)+1)*(iimax(3)+1)*n_gather(1)*n_gather(2)*n_gather(3) ) )
    !real(c_double)                ::  sendbuf( 0:( ( Nc(1)+12 )*( Nc(2)+12 )*( Nc(3)+12 ) ) )

    if( participate_yes ) then

      do k = 1, n_gather(3)
        do j = 1, n_gather(2)
          do i = 1, n_gather(1)

            dispg      = dispI(    i+(j-1)*n_gather(1)+(k-1)*n_gather(1)*n_gather(2))
            offsg(1:3) = offsI(1:3,i+(j-1)*n_gather(1)+(k-1)*n_gather(1)*n_gather(2))

            do kk = 0, iimax(3)
              do jj = 0, iimax(2)
                do ii = 0, iimax(1)
                  sendbuf( dispg + ii + jj*(iimax(1)+1) + kk*(iimax(1)+1)*(iimax(2)+1) ) = phic(ii+offsg(1),jj+offsg(2),kk+offsg(3))
                end do
              end do
            end do

          end do
        end do
      end do

    end if

    allocate(recvbuf(0:iimax(1),0:iimax(2),0:iimax(3))) ! Anmerkung: Besser nicht fest allocieren um Speicherplatz zu sparen, ODER gleich "phic" verwenden!

    call MPI_SCATTER(sendbuf,(iimax(1)+1)*(iimax(2)+1)*(iimax(3)+1),MPI_REAL8,recvbuf,(iimax(1)+1)*(iimax(2)+1)*(iimax(3)+1),MPI_REAL8,rankc2,comm2,merror)

    phic(0:iimax(1),0:iimax(2),0:iimax(3)) = recvbuf(0:iimax(1),0:iimax(2),0:iimax(3))

    deallocate(recvbuf)
    !------------------------------------------------------------------------------

  end subroutine MG_InterpolateScatter

end module cmod_InterpolationOp