      DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P,
     $                                  OMEGA, A, LDA, E, LDE, B, LDB,
     $                                  C, LDC, D, LDD, IWORK, DWORK,
     $                                  LDWORK, CWORK, LCWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the maximum singular value of a given continuous-time
C     or discrete-time transfer-function matrix, either standard or in
C     the descriptor form,
C
C                                     -1
C        G(lambda) = C*( lambda*E - A ) *B + D ,
C
C     for a given complex value lambda, where lambda = j*omega, in the
C     continuous-time case, and lambda = exp(j*omega), in the
C     discrete-time case. The matrices A, E, B, C, and D are real
C     matrices of appropriate dimensions. Matrix A must be in an upper
C     Hessenberg form, and if JOBE ='G', the matrix E must be upper
C     triangular. The matrices B and C must correspond to the system
C     in (generalized) Hessenberg form.
C
C     FUNCTION VALUE
C
C     AB13DX   DOUBLE PRECISION
C              The maximum singular value of G(lambda).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system, as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBE    CHARACTER*1
C             Specifies whether E is an upper triangular or an identity
C             matrix, as follows:
C             = 'G':  E is a general upper triangular matrix;
C             = 'I':  E is the identity matrix.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears in
C             the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The row size of the matrix C.  P >= 0.
C
C     OMEGA   (input) DOUBLE PRECISION
C             The frequency value for which the calculations should be
C             done.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the state dynamics matrix A in upper
C             Hessenberg form. The elements below the subdiagonal are
C             not referenced.
C             On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0,
C             and C <> 0, the leading N-by-N upper Hessenberg part of
C             this array contains the factors L and U from the LU
C             factorization of A (A = P*L*U); the unit diagonal elements
C             of L are not stored, L is lower bidiagonal, and P is
C             stored in IWORK (see SLICOT Library routine MB02SD).
C             Otherwise, this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             If JOBE = 'G', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular descriptor
C             matrix E of the system. The elements of the strict lower
C             triangular part of this array are not referenced.
C             If JOBE = 'I', then E is assumed to be the identity
C             matrix and is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of the array E.
C             LDE >= MAX(1,N), if JOBE = 'G';
C             LDE >= 1,        if JOBE = 'I'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the system input matrix B.
C             On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0,
C             C <> 0, and INFO = 0 or N+1, the leading N-by-M part of
C             this array contains the solution of the system A*X = B.
C             Otherwise, this array is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, if JOBD = 'D', the leading P-by-M part of this
C             array must contain the direct transmission matrix D.
C             On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D',
C             or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or
C             N+1), the contents of this array is destroyed.
C             Otherwise, this array is unchanged on exit.
C             This array is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P), if JOBD = 'D';
C             LDD >= 1,        if JOBD = 'Z'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0;
C             LIWORK = 0, otherwise.
C             This array contains the pivot indices in the LU
C             factorization of the matrix lambda*E - A; for 1 <= i <= N,
C             row i of the matrix was interchanged with row IWORK(i).
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the
C             singular values of G(lambda), except for the first one,
C             which is returned in the function value AB13DX.
C             If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last
C             MIN(P,M)-1 zero singular values of G(lambda) are not
C             stored in DWORK(2), ..., DWORK(MIN(P,M)).
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= MAX(1, LDW1 + LDW2 ),
C             LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0,
C                            DICO = 'C', and JOBD = 'Z';
C             LDW1 = 0,   otherwise;
C             LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)),
C                         if (N = 0, or B = 0, or C = 0) and JOBD = 'D',
C                         or (N > 0, B <> 0, C <> 0, OMEGA = 0, and
C                             DICO = 'C');
C             LDW2 = 0,   if (N = 0, or B = 0, or C = 0) and JOBD = 'Z',
C                         or MIN(P,M) = 0;
C             LDW2 = 6*MIN(P,M), otherwise.
C             For good performance, LDWORK must generally be larger.
C
C     CWORK   COMPLEX*16 array, dimension (LCWORK)
C             On exit, if INFO = 0, CWORK(1) contains the optimal
C             LCWORK.
C
C     LCWORK  INTEGER
C             The dimension of the array CWORK.
C             LCWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0
C                             and DICO = 'C') or MIN(P,M) = 0;
C             LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)),
C                          otherwise.
C             For good performance, LCWORK must generally be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, U(i,i) is exactly zero; the LU
C                   factorization of the matrix lambda*E - A has been
C                   completed, but the factor U is exactly singular,
C                   i.e., the matrix lambda*E - A is exactly singular;
C             = N+1:  the SVD algorithm for computing singular values
C                   did not converge.
C
C     METHOD
C
C     The routine implements standard linear algebra calculations,
C     taking problem structure into account. LAPACK Library routines
C     DGESVD and ZGESVD are used for finding the singular values.
C
C     CONTRIBUTORS
C
C     D. Sima, University of Bucharest, May 2001.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005.
C
C     KEYWORDS
C
C     H-infinity optimal control, robust control, system norm.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          DICO, JOBD, JOBE
      INTEGER            INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK,
     $                   M, N, P
      DOUBLE PRECISION   OMEGA
C     ..
C     .. Array Arguments ..
      COMPLEX*16         CWORK(  * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK(  * ), E( LDE, * )
      INTEGER            IWORK(  * )
C     ..
C     .. Local Scalars ..
      LOGICAL            DISCR, FULLE, NODYN, SPECL, WITHD
      INTEGER            I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J,
     $                   MAXWRK, MINCWR, MINPM, MINWRK
      DOUBLE PRECISION   BNORM, CNORM, LAMBDI, LAMBDR, UPD
C
C     .. External Functions ..
      DOUBLE PRECISION   DLANGE
      LOGICAL            LSAME
      EXTERNAL           DLANGE, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ,
     $                   XERBLA, ZGEMM, ZGESVD, ZLACP2
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          COS, DCMPLX, INT, MAX, MIN, SIN
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar parameters.
C
      INFO  = 0
      DISCR = LSAME( DICO, 'D' )
      FULLE = LSAME( JOBE, 'G' )
      WITHD = LSAME( JOBD, 'D' )
C
      IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN
         INFO = -17
      ELSE
         BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK )
         CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK )
         NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO
         SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR
         MINPM = MIN( P, M )
C
C        Compute workspace.
C
         IF( MINPM.EQ.0 ) THEN
            MINWRK = 0
         ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN
            MINWRK = MINPM + MAX( 3*MINPM + MAX( P, M ), 5*MINPM )
            IF ( SPECL .AND. .NOT.WITHD )
     $         MINWRK = MINWRK + P*M
         ELSE IF ( NODYN .AND. .NOT.WITHD ) THEN
            MINWRK = 0
         ELSE
            MINWRK = 6*MINPM
         END IF
         MINWRK = MAX( 1, MINWRK )
C
         IF( LDWORK.LT.MINWRK ) THEN
            INFO = -20
         ELSE
            IF ( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR.
     $           MINPM.EQ.0 ) THEN
               MINCWR = 1
            ELSE
               MINCWR = MAX( 1, ( N + M )*( N + P ) +
     $                          2*MINPM + MAX( P, M ) )
            END IF
            IF( LCWORK.LT.MINCWR )
     $         INFO = -22
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'AB13DX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MINPM.EQ.0 ) THEN
         AB13DX = ZERO
C
         DWORK( 1 ) = ONE
         CWORK( 1 ) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      IS   = 1
      IWRK = IS + MINPM
C
      IF( NODYN ) THEN
C
C        No dynamics: Determine the maximum singular value of G = D .
C
         IF ( WITHD ) THEN
C
C           Workspace: need   MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M),
C                                            5*MIN(P,M));
C                      prefer larger.
C
            CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD,
     $                   DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = N + 1
               RETURN
            END IF
            AB13DX = DWORK( IS )
            MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1
         ELSE
            AB13DX = ZERO
            MAXWRK = 1
         END IF
C
         DWORK( 1 ) = MAXWRK
         CWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Determine the maximum singular value of
C        G(lambda) = C*inv(lambda*E - A)*B + D.
C     The (generalized) Hessenberg form of the system is used.
C
      IF ( SPECL ) THEN
C
C        Special continuous-time case:
C        Determine the maximum singular value of the real matrix G(0).
C        Workspace: need   MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M),
C                                         5*MIN(P,M));
C                   prefer larger.
C
         CALL MB02SD( N, A, LDA, IWORK, IERR )
         IF( IERR.GT.0 ) THEN
            INFO = IERR
            DWORK( 1 ) = ONE
            CWORK( 1 ) = ONE
            RETURN
         END IF
         CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB,
     $                IERR )
         IF ( WITHD ) THEN
            CALL DGEMM(  'No Transpose', 'No Transpose', P, M, N, -ONE,
     $                   C, LDC, B, LDB, ONE, D, LDD )
            CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD,
     $                   DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, IERR )
         ELSE
C
C           Additional workspace: need   P*M.
C
            ID   = IWRK
            IWRK = ID + P*M
            CALL DGEMM(  'No Transpose', 'No Transpose', P, M, N, -ONE,
     $                   C, LDC, B, LDB, ZERO, DWORK( ID ), P )
            CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ),
     $                   P, DWORK( IS ), DWORK, P, DWORK, M,
     $                   DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         END IF
         IF( IERR.GT.0 ) THEN
            INFO = N + 1
            RETURN
         END IF
C
         AB13DX = DWORK( IS )
         DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1
         CWORK( 1 ) = ONE
         RETURN
      END IF
C
C     General case: Determine the maximum singular value of G(lambda).
C     Complex workspace:  need   N*N + N*M + P*N + P*M.
C
      ICB  = 1   + N*N
      ICC  = ICB + N*M
      ICD  = ICC + P*N
      ICWK = ICD + P*M
C
      IF ( WITHD ) THEN
         UPD = ONE
      ELSE
         UPD = ZERO
      END IF
C
      IF ( DISCR ) THEN
         LAMBDR = COS( OMEGA )
         LAMBDI = SIN( OMEGA )
C
C        Build lambda*E - A .
C
         IF ( FULLE ) THEN
C
            DO 20 J = 1, N
C
               DO 10 I = 1, J
                  CWORK( I+(J-1)*N ) =
     $               DCMPLX( LAMBDR*E( I, J ) - A( I, J ),
     $                       LAMBDI*E( I, J ) )
   10          CONTINUE
C
               IF( J.LT.N )
     $            CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO )
   20      CONTINUE
C
         ELSE
C
            DO 40 J = 1, N
C
               DO 30 I = 1, MIN( J+1, N )
                  CWORK( I+(J-1)*N ) = -A( I, J )
   30          CONTINUE
C
               CWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI )
   40      CONTINUE
C
         END IF
C
      ELSE
C
C        Build j*omega*E - A.
C
         IF ( FULLE ) THEN
C
            DO 60 J = 1, N
C
               DO 50 I = 1, J
                  CWORK( I+(J-1)*N ) =
     $               DCMPLX( -A( I, J ), OMEGA*E( I, J ) )
   50         CONTINUE
C
               IF( J.LT.N )
     $            CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO )
   60      CONTINUE
C
         ELSE
C
            DO 80 J = 1, N
C
               DO 70 I = 1, MIN( J+1, N )
                  CWORK( I+(J-1)*N ) = -A( I, J )
   70          CONTINUE
C
               CWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA )
   80      CONTINUE
C
         END IF
C
      END IF
C
C     Build G(lambda) .
C
      CALL ZLACP2( 'Full', N, M, B, LDB, CWORK( ICB ), N )
      CALL ZLACP2( 'Full', P, N, C, LDC, CWORK( ICC ), P )
      IF ( WITHD )
     $   CALL ZLACP2( 'Full', P, M, D, LDD, CWORK( ICD ), P )
C
      CALL MB02SZ( N, CWORK, N, IWORK, IERR )
      IF( IERR.GT.0 ) THEN
         INFO = IERR
         DWORK( 1 ) = ONE
         CWORK( 1 ) = ICWK - 1
         RETURN
      END IF
      CALL MB02RZ( 'No Transpose', N, M, CWORK, N, IWORK,
     $             CWORK( ICB ), N, IERR )
      CALL ZGEMM(  'No Transpose', 'No Transpose', P, M, N, CONE,
     $             CWORK( ICC ), P, CWORK( ICB ), N,
     $             DCMPLX( UPD, ZERO ), CWORK( ICD ), P )
C
C     Additional workspace, complex: need   2*MIN(P,M) + MAX(P,M);
C                                    prefer larger;
C                           real:    need   5*MIN(P,M).
C
      CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, CWORK( ICD ), P,
     $             DWORK( IS ), CWORK, P, CWORK, M, CWORK( ICWK ),
     $             LCWORK-ICWK+1, DWORK( IWRK ), IERR )
      IF( IERR.GT.0 ) THEN
         INFO = N + 1
         RETURN
      END IF
      AB13DX = DWORK( IS )
C
      DWORK( 1 ) = 6*MINPM
      CWORK( 1 ) = INT( CWORK( ICWK ) ) + ICWK - 1
C
      RETURN
C *** Last line of AB13DX ***
      END


module derivatives
  use nrtype
contains
  subroutine constant_accel(x,y,dydx)
    implicit none
    real(dp), intent(in)  :: x, y(:)
    real(dp), intent(out) :: dydx(:)
    dydx = -9.81
  end subroutine constant_accel
end module derivatives


! { dg-do compile }
! { dg-options "-c -Wall" }
!
! PR fortran/40041
! cf. also PR fortran/20373

subroutine valid_one
  REAL :: a
  INTEGER :: n
  INTRINSIC   ABS, MAX
  a(n) = MAX(ABS(2),ABS(3),n)
end subroutine

subroutine valid_two
  IMPLICIT NONE
  REAL :: a
  INTEGER :: n
  INTRINSIC   ABS, MAX
  a(n) = MAX(ABS(2),ABS(3),n)
end subroutine

subroutine warnings_one
  REAL :: a
  INTEGER :: n
  REAL :: ABS ! { dg-warning "Type specified for intrinsic function" }
  REAL :: MAX ! { dg-warning "Type specified for intrinsic function" }
  INTRINSIC   ABS, MAX
  a(n) = MAX(ABS(2),ABS(3),n)
end subroutine

subroutine warnings_two
  IMPLICIT NONE
  REAL :: a
  INTEGER :: n
  INTRINSIC ABS ! { dg-warning "Type specified for intrinsic function" }
  INTRINSIC MAX ! { dg-warning "Type specified for intrinsic function" }
  REAL :: ABS
  REAL :: MAX
  a(n) = MAX(ABS(2),ABS(3),n)
end subroutine


          program demo_s2v

           use M_strings, only: s2v, int, real, dble
           implicit none
           character(len=8)              :: s=' 10.345 '
           integer                       :: i
           character(len=14),allocatable :: strings(:)
           doubleprecision               :: dv
           integer                       :: errnum

           ! different strings representing INTEGER, REAL, and DOUBLEPRECISION
           strings=[&
           &' 10.345       ',&
           &'+10           ',&
           &'    -3        ',&
           &'    -4.94e-2  ',&
           &'0.1           ',&
           &'12345.678910d0',&
           &'              ',& ! Note: will return zero without an error message
           &'1 2 1 2 1 . 0 ',& ! Note: spaces will be ignored
           &'WHAT?         ']  ! Note: error messages will appear, zero returned

           ! a numeric value is returned,
           ! so it can be used in numeric expression
           write(*,*) '1/2 value of string is ',s2v(s)/2.0d0
           write(*,*)
           write(*,*)' STRING            VALUE                    ERROR_NUMBER'
           do i=1,size(strings)
              ! Note: not a good idea to use s2v(3f) in a WRITE(3f) statement,
              ! as it does I/O when errors occur, so called on a separate line
              dv=s2v(strings(i),errnum)
              write(*,*) strings(i)//'=',dv,errnum
           enddo
           write(*,*)"Extended intrinsics"
           write(*,*)'given inputs:',s,strings(:8)
           write(*,*)'INT(3f):',int(s),int(strings(:8))
           write(*,*)'REAL(3f):',real(s),real(strings(:8))
           write(*,*)'DBLE(3f):',dble(s),dble(strings(:8))
           write(*,*)"That's all folks!"

           end program demo_s2v


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_1Darray_random_normal
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine provides a vector of pseudo-random number independent, standard,
! normally distributed (expected value 0, standard deviation 1).
! Call u_randomseed_initialize(INFO) first to set the seed of the number
! generator.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    positive integer, dimension of A
!
!
! OUTPUT VARIABLES:
!
!  A               REAL(8) array of dimension (N)
!                    vector of real random numbers
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_1Darray_random_normal(N,A)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(inout) :: A(N)

  ! compute variables
  integer :: ii

  ! check N
  if (N < 1) then
    return
  end if

  do ii = 1,N

    call d_scalar_random_normal(A(ii))

  end do

end subroutine d_1Darray_random_normal


C       Uninitialized scalar variables
	program scalar09
	integer x,y,z
	x = sqrt(2) -1
	if (x.gt.0 ) then
	   y = 1
	else
	   z = 1
	endif
	call foo(y)
	end
	subroutine foo(y)
	integer t
	t = sqrt(2) -1
	if (t.gt.1) then
	   y = 2
	else
	   t = 2
	endif
	print *,y
	end


! { dg-do compile }
! { dg-options "-Wconversion" }
! PR 47359 - additional warnings for conversions.
program main
  implicit none
  complex(kind=4) :: c4
  complex(kind=8) :: c8
  real(kind=4) :: r4
  real(kind=8) :: r8
  complex(kind=4), parameter :: c4p = (1.0, -4.)
  complex, parameter :: c8w = (1.0_8, -4.2_8) ! { dg-warning "Change of value in conversion" }
  complex (kind=8), parameter :: c8p = (1.0_8, -4.2_8)
  integer :: i

  c4 = c8p ! { dg-warning "Change of value in conversion" }
  c4 = 2**26 + 1 ! { dg-warning "Change of value in conversion" }
  c4 = 1.3d0     ! { dg-warning "Change of value in conversion" }
  c4 = c8p       ! { dg-warning "Change of value in conversion" }
  c4 = (1.2, 1000000001) ! { dg-warning "Change of value in conversion" }
  r4 = (2**26 + 1) * 2.3 ! { dg-warning "Change of value in conversion" }
  r4 = 2.4d0 ! { dg-warning "Change of value" }
  r4 = c4p ! { dg-warning "Non-zero imaginary part" }
  r4 = r4 + 2.3d0 ! { dg-warning "Possible change of value in conversion" }
  r8 = 2_8**62 - 1_8 ! { dg-warning "Change of value in conversion" }
  i = c4p ! { dg-warning "Non-zero imaginary part" }
  i = 42 + 1.3 ! { dg-warning "Change of value in conversion" }
  i = (1.2, 0.) ! { dg-warning "Change of value in conversion" }
  c4 = 1.2       ! no warning
  c4 = -3.25d0   ! no warning
  c4 = -42       ! no warning
  c8 = 2**26 + 1 ! no warning
  i = 22.        ! no warning
  i = (35., 0.)  ! no warning
  r4 = 2.5d0     ! no warning
  r4 = 235       ! no warning
  r8 = 2.3       ! no warning
end program main


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!this test case is test for const dcomolex convert to quad
program main
  use check_mod
  complex(kind = 8) :: a = 1.1_16, ea
  ea = (1.1000000000000001_8, 0.0000000000000000_8)

  call checkc8(a, ea, 1)

end program main


! This Source Code Form is subject to the terms of the Mozilla Public
! License, v. 2.0. If a copy of the MPL was not distributed with this
! file, You can obtain one at http://mozilla.org/MPL/2.0/.
!> \brief This module contains utility functions involving pseudo-random numbers

module random
    use global_var_mod
    private
    public :: shuffle_real, shuffle_int, setup_rand
    contains

  !> \brief Randomly shuffles an array of real(kind=real8)s
  !>
  !>  Needed for a quicksort algorithm which doesn't hit \f$O(N^2)\f$ on a sorted array.
  !>  Uses the Fisher-Yates algorithm.
  !>  \param array An array of real(kind=real8)s to be shuffled randomly
  subroutine shuffle_real ( array )
    implicit none

    real(kind=real8), dimension(:), intent(inout) :: array
    integer :: i,j,n
    real(kind=real8) :: random, tmp

    ! Note we are assuming that the random number generator has been seeded correctly!
    ! Now lets shuffle by randomly picking a number on [i,n] and placing it at position array(i)
    n = size(array)
    do i = 1 , n-1
       call random_number(random)
       j = int( (n+1-i) * random + i )
       ! swap i and j
       tmp = array(i)
       array(i) = array(j)
       array(j) = tmp
    end do
  end subroutine shuffle_real

    !> \brief Randomly shuffles an array of ints
  !>
  !>  Needed for a quicksort algorithm which doesn't hit \f$O(N^2)\f$ on a sorted array.
  !>  Uses the Fisher-Yates algorithm.
  !>  \param array An array of ints to be shuffled randomly
  subroutine shuffle_int ( array )
    implicit none

    integer, dimension(:), intent(inout) :: array
    integer :: i,j,n,tmp
    real(kind=real8) :: random

    ! Note we are assuming that the random number generator has been seeded correctly!
    ! Now lets shuffle by randomly picking a number on [i,n] and placing it at position array(i)
    n = size(array)
    do i = 1 , n-1
       call random_number(random)
       j = int( (n+1-i) * random + i )
       ! swap i and j
       tmp = array(i)
       array(i) = array(j)
       array(j) = tmp
    end do
  end subroutine shuffle_int

  !> \brief Sets up the random number generator
  !>
  !> This is based on the gfortran documentation
  subroutine setup_rand()
    implicit none
    integer :: seed_size, clock, i
    integer, dimension(:), allocatable :: seed

    ! get the size of the seed
    call random_seed( size = seed_size )

    ! now allocate the seed
    allocate(seed(seed_size),stat=i)
    if ( i /= 0 ) then
       write(*,*) "Memory allocation error in setup_rand"
       stop
    end if

    ! now get the system clock time and setup the seed
    call system_clock( count = clock )
    do i = 1 , seed_size
       seed(i) = clock + 37 * i
    end do

    ! now set the seed
    call random_seed(put=seed)

    deallocate(seed)
  end subroutine setup_rand

end module random


program traffic

  use trafficlib

  implicit none

  integer, parameter :: NCELL = 100000
  integer, parameter :: maxiter = 200000000/NCELL
  integer, parameter :: printfreq = maxiter/10

  integer procid, nproc, nlocal

  integer :: i, iter, nmove, ncars
  real    :: density

  integer, allocatable, dimension(:) :: newroad, oldroad, bigroad

  double precision :: tstart, tstop

! Set target density of cars

  density = 0.52

! Start message passing system

  call mpstart(nproc, procid)

  nlocal = NCELL/nproc

  if (procid == 0) then

     write(*,*) 'Length of road is ', NCELL
     write(*,*) 'Number of iterations is ', maxiter
     write(*,*) 'Target density of cars is ', density
     write(*,*) 'Running on ', nproc, ' processes'

  end if

! Allocate arrays

  allocate(newroad(0:nlocal+1))
  allocate(oldroad(0:nlocal+1))

  if (procid == 0) then

     allocate(bigroad(NCELL))

     ! Initialise road accordingly using random number generator

     write(*,*) 'Initialising ...'

     ncars = initroad(bigroad, NCELL, density, seed)

     write(*,*) '... done'

     write(*,*) 'Actual density of cars is ', float(ncars)/float(NCELL)
     write(*,*) 'Scattering data ...'

  end if

  call mpscatter(bigroad, oldroad(1:nlocal), nlocal)

  if (procid == 0) then

     write(*,*) '... done'
     write(*,*)

  end if

  tstart = gettime()

  do iter = 1, maxiter

     call mpupdatebcs(oldroad, nlocal, procid, nproc)

     nmove = updateroad(newroad, oldroad, nlocal)

! Globally sum the value

     call mpgsum(nmove)

! Copy new to old array

     do i = 1, nlocal

        oldroad(i) = newroad(i)

     end do

     if (mod(iter, printfreq) == 0) then

        if (procid == 0) write(*,*) 'At iteration ', iter, &
             ' average velocity is ', float(nmove)/float(ncars)
     end if

  end do

  tstop = gettime()

  deallocate(oldroad)
  deallocate(newroad)

  if (procid == 0) then

     deallocate(bigroad)

     write(*,*)
     write(*,*) 'Finished'
     write(*,*)
     write(*,*) 'Time taken was  ', tstop - tstart, ' seconds'
     write(*,*) 'Update rate was ', &
                 1.d-6*float(NCELL)*float(maxiter)/(tstop-tstart), ' MCOPs'
     write(*,*)

  end if

  call mpstop()

end program traffic


!>  @file  bils.f90
!!  @brief Basic subprograms for iterative linear solvers for Cartesian grid data structure (for symmetric/asymmetric 7-band matrices)
!<

subroutine jacobi_smoother( &
                x1, x0, &
                Ap, Aw, Ae, As, An, Ab, At, &
                b, &
                omega, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x1, x0
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: b
  real                    :: omega
  real                    :: r
  real                    :: x_tmp
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
#ifdef _BLOCK_IS_LARGE_
!$omp parallel private(i, j, k) &
!$omp           private(r, x_tmp)
!$omp do schedule(static,1)
#else
!ocl nouxsimd
!ocl serial
!dir$ noparallel
#endif
  do k=1, kx
!dir$ noparallel
  do j=1, jx
  do i=1, ix
    r = b(i, j, k) &
            - Aw(i, j, k)*x0(i-1, j, k) &
            - Ae(i, j, k)*x0(i+1, j, k) &
            - As(i, j, k)*x0(i, j-1, k) &
            - An(i, j, k)*x0(i, j+1, k) &
            - Ab(i, j, k)*x0(i, j, k-1) &
            - At(i, j, k)*x0(i, j, k+1)
    x_tmp = r/Ap(i, j, k)
    x1(i, j, k) = x0(i, j, k) - omega*(x0(i, j, k) - x_tmp)
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine jacobi_smoother

subroutine rbgs_smoother( &
                x, &
                Ap, Aw, Ae, As, An, Ab, At, &
                b, &
                omega, &
                color, offset, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: b
  real                    :: omega
  integer                 :: color, offset
  real                    :: r
  real                    :: x_tmp
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
#ifdef _BLOCK_IS_LARGE_
!$omp parallel private(i, j, k) &
!$omp          private(r, x_tmp)
!$omp do schedule(static, 1)
#else
!ocl nouxsimd
!ocl serial
!dir$ noparallel
#endif
  do k=1, kx
  do j=1, jx
  do i=1+mod(k+j+color+offset,2), ix, 2
    r = b(i, j, k) &
            - Aw(i, j, k)*x(i-1, j, k) &
            - Ae(i, j, k)*x(i+1, j, k) &
            - As(i, j, k)*x(i, j-1, k) &
            - An(i, j, k)*x(i, j+1, k) &
            - Ab(i, j, k)*x(i, j, k-1) &
            - At(i, j, k)*x(i, j, k+1)
    x_tmp = r/Ap(i, j, k)
    x(i, j, k) = x(i, j, k) - omega*(x(i, j, k) - x_tmp)
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine rbgs_smoother

subroutine jacobi_smoother2( &
                x1, x0, &
                A, &
                b, &
                omega, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x1, x0
  real, dimension(0:6, 1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: A
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: b
  real                    :: omega
  real                    :: r
  real                    :: x_tmp
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
#ifdef _BLOCK_IS_LARGE_
!$omp parallel private(i, j, k) &
!$omp           private(r, x_tmp)
!$omp do schedule(static,1)
#else
!ocl nouxsimd
!ocl serial
!dir$ noparallel
#endif
  do k=1, kx
!dir$ noparallel
  do j=1, jx
  do i=1, ix
    r = b(i, j, k) &
            - A(1, i, j, k)*x0(i-1, j, k) &
            - A(2, i, j, k)*x0(i+1, j, k) &
            - A(3, i, j, k)*x0(i, j-1, k) &
            - A(4, i, j, k)*x0(i, j+1, k) &
            - A(5, i, j, k)*x0(i, j, k-1) &
            - A(6, i, j, k)*x0(i, j, k+1)
    x_tmp = r/A(0, i, j, k)
    x1(i, j, k) = x0(i, j, k) - omega*(x0(i, j, k) - x_tmp)
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine jacobi_smoother2

subroutine calc_ax( &
                Ax, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: Ax
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
#ifdef _BLOCK_IS_LARGE_
!$omp parallel
!$omp do schedule(static, 1) &
!$omp    ,private(i, j, k)
#else
!ocl nouxsimd
!ocl serial
!dir$ noparallel
#endif
  do k=1, kx
  do j=1, jx
  do i=1, ix
    Ax(i, j, k) = &
            + Aw(i, j, k)*x(i-1, j, k) &
            + Ae(i, j, k)*x(i+1, j, k) &
            + As(i, j, k)*x(i, j-1, k) &
            + An(i, j, k)*x(i, j+1, k) &
            + Ab(i, j, k)*x(i, j, k-1) &
            + At(i, j, k)*x(i, j, k+1) &
            + Ap(i, j, k)*x(i, j, k)
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine calc_ax

subroutine calc_r( &
                r, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                b, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: r
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: b
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
#ifdef _BLOCK_IS_LARGE_
!$omp parallel
!$omp do schedule(static, 1) &
!$omp    ,private(i, j, k)
#else
!ocl nouxsimd
!ocl serial
!dir$ noparallel
#endif
  do k=1, kx
  do j=1, jx
  do i=1, ix
    r(i, j, k) = b(i, j, k) &
            - Aw(i, j, k)*x(i-1, j, k) &
            - Ae(i, j, k)*x(i+1, j, k) &
            - As(i, j, k)*x(i, j-1, k) &
            - An(i, j, k)*x(i, j+1, k) &
            - Ab(i, j, k)*x(i, j, k-1) &
            - At(i, j, k)*x(i, j, k+1) &
            - Ap(i, j, k)*x(i, j, k)
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine calc_r

subroutine calc_r2( &
                rr, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                b, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: rr
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: b
  real                    :: r
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
  rr = 0.0
#ifdef _BLOCK_IS_LARGE_
!$omp parallel
!$omp do schedule(static, 1) &
!$omp     private(i, j, k) &
!$omp     private(r) &
!$omp     reduction(+:rr)
#else
#endif
  do k=1, kx
  do j=1, jx
  do i=1, ix
    r = b(i, j, k) &
            - Aw(i, j, k)*x(i-1, j, k) &
            - Ae(i, j, k)*x(i+1, j, k) &
            - As(i, j, k)*x(i, j-1, k) &
            - An(i, j, k)*x(i, j+1, k) &
            - Ab(i, j, k)*x(i, j, k-1) &
            - At(i, j, k)*x(i, j, k+1) &
            - Ap(i, j, k)*x(i, j, k)
    rr = rr + r*r
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine calc_r2

subroutine setup_mask( &
                m, &
                mask, &
                sz, g)
  implicit none
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: m
  integer, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: mask
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
#ifdef _BLOCK_IS_LARGE_
!$omp parallel private(i, j, k)
!$omp do
#else
#endif
  do k=1-g, kx+g
  do j=1-g, jx+g
  do i=1-g, ix+g
    m(i, j, k) = 0.0
    mask(i, j, k) = 0
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif

#ifdef _BLOCK_IS_LARGE_
!$omp parallel private(i, j, k)
!$omp do
#else
#endif
  do k=1, kx
  do j=1, jx
  do i=1, ix
    m(i, j, k) = 1.0
    mask(i, j, k) = 1
  end do
  end do
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine setup_mask

subroutine axpy_mask(y, x, a, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real                    :: a
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      y(ijk) = y(ijk) + a*x(ijk)
    end if
  end do
end subroutine axpy_mask

subroutine xpay_mask(y, x, a, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real                    :: a
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      y(ijk) = x(ijk) + a*y(ijk)
    end if
  end do
end subroutine xpay_mask

subroutine axpyz_mask(z, x, y, a, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: z
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real                    :: a
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      z(ijk) = a*x(ijk) + y(ijk)
    end if
  end do
end subroutine axpyz_mask

subroutine axpbypz_mask(z, x, y, a, b, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: z
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x, y
  real                    :: a, b
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      z(ijk) = a*x(ijk) + b*y(ijk) + z(ijk)
    end if
  end do
end subroutine axpbypz_mask

subroutine dot_mask(xy, x, y, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: xy
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
  xy = 0.0
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      xy = xy + x(ijk)*y(ijk)
    end if
  end do
end subroutine dot_mask

subroutine dotx2_mask(xy, xz, x, y, z, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: xy, xz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: z
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
  xy = 0.0
  xz = 0.0
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      xy = xy + x(ijk)*y(ijk)
      xz = xz + x(ijk)*z(ijk)
    end if
  end do
end subroutine dotx2_mask

subroutine jacobi_smoother_mask( &
                x1, x0, &
                Ap, Aw, Ae, As, An, Ab, At, &
                b, &
                mask, &
                omega, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x1, x0
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: b
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  real                    :: omega
  real                    :: r
  real                    :: x_tmp
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
#ifdef _BLOCK_IS_LARGE_
!$omp parallel private(ijk) &
!$omp           private(r, x_tmp)
!$omp do
#else
!ocl serial
!ocl nouxsimd
!dir$ simd
#endif
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      r = b(ijk) &
              - Aw(ijk)*x0(ijk - 1) &
              - Ae(ijk)*x0(ijk + 1) &
              - As(ijk)*x0(ijk - cx) &
              - An(ijk)*x0(ijk + cx) &
              - Ab(ijk)*x0(ijk - cx*cy) &
              - At(ijk)*x0(ijk + cx*cy)
      x_tmp = r/Ap(ijk)
      x1(ijk) = x0(ijk) - omega*(x0(ijk) - x_tmp)
    end if
  end do
#ifdef _BLOCK_IS_LARGE_
!$omp end do
!$omp end parallel
#else
#endif
end subroutine jacobi_smoother_mask

subroutine copy_mask(y, x, mask, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer, dimension(3)    :: sz
  integer                  :: g
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      y(ijk) = x(ijk)
    end if
  end do
end subroutine copy_mask

subroutine calc_ax_mask( &
                Ax, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                mask, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ax
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      Ax(ijk) = &
              + Aw(ijk)*x(ijk - 1) &
              + Ae(ijk)*x(ijk + 1) &
              + As(ijk)*x(ijk - cx) &
              + An(ijk)*x(ijk + cx) &
              + Ab(ijk)*x(ijk - cx*cy) &
              + At(ijk)*x(ijk + cx*cy) &
              + Ap(ijk)*x(ijk)
    end if
  end do
end subroutine calc_ax_mask

subroutine calc_r_mask( &
                r, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                b, &
                mask, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: r
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: b
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      r(ijk) = b(ijk) &
              - Aw(ijk)*x(ijk - 1) &
              - Ae(ijk)*x(ijk + 1) &
              - As(ijk)*x(ijk - cx) &
              - An(ijk)*x(ijk + cx) &
              - Ab(ijk)*x(ijk - cx*cy) &
              - At(ijk)*x(ijk + cx*cy) &
              - Ap(ijk)*x(ijk)
    end if
  end do
end subroutine calc_r_mask

subroutine calc_r2_mask( &
                rr, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                b, &
                mask, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: rr
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: b
  integer, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: mask
  real                    :: r
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
  rr = 0.0d0
!ocl serial
!ocl nouxsimd
!dir$ simd
  do ijk=ijk0, ijkx
    if( mask(ijk) == 1 ) then
      r = b(ijk) &
              - Aw(ijk)*x(ijk - 1) &
              - Ae(ijk)*x(ijk + 1) &
              - As(ijk)*x(ijk - cx) &
              - An(ijk)*x(ijk + cx) &
              - Ab(ijk)*x(ijk - cx*cy) &
              - At(ijk)*x(ijk + cx*cy) &
              - Ap(ijk)*x(ijk)
      rr = rr + r*r
    end if
  end do
end subroutine calc_r2_mask

subroutine axpy_mask2(y, x, a, m, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real                    :: a
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    y(ijk) = y(ijk) + a*x(ijk)*m(ijk)
  end do
end subroutine axpy_mask2

subroutine xpay_mask2(y, x, a, m, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real                    :: a
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    y(ijk) = (x(ijk) + a*y(ijk))*m(ijk) + y(ijk)*(1.0 - m(ijk))
  end do
end subroutine xpay_mask2

subroutine axpyz_mask2(z, x, y, a, m, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: z
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real                    :: a
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    z(ijk) = (a*x(ijk) + y(ijk))*m(ijk) + z(ijk)*(1.0 - m(ijk))
  end do
end subroutine axpyz_mask2

subroutine axpbypz_mask2(z, x, y, a, b, m, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: z
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x, y
  real                    :: a, b
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    z(ijk) = (a*x(ijk) + b*y(ijk))*m(ijk) + z(ijk)
  end do
end subroutine axpbypz_mask2

subroutine dot_mask2(xy, x, y, m, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: xy
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
  xy = 0.0
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    xy = xy + x(ijk)*y(ijk)*m(ijk)
  end do
end subroutine dot_mask2

subroutine dotx2_mask2(xy, xz, x, y, z, m, sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: xy, xz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: y
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: z
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
  xy = 0.0
  xz = 0.0
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    xy = xy + x(ijk)*y(ijk)*m(ijk)
    xz = xz + x(ijk)*z(ijk)*m(ijk)
  end do
end subroutine dotx2_mask2

subroutine jacobi_smoother_mask2( &
                x1, x0, &
                Ap, Aw, Ae, As, An, Ab, At, &
                b, &
                m, &
                omega, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x1, x0
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: b
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  real                    :: omega
  real                    :: r
  real                    :: x_tmp
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    r = b(ijk) &
             - Aw(ijk)*x0(ijk - 1) &
             - Ae(ijk)*x0(ijk + 1) &
             - As(ijk)*x0(ijk - cx) &
             - An(ijk)*x0(ijk + cx) &
             - Ab(ijk)*x0(ijk - cx*cy) &
             - At(ijk)*x0(ijk + cx*cy)
    x_tmp = r/Ap(ijk)
    x1(ijk) = x0(ijk) - omega*(x0(ijk) - x_tmp)*m(ijk)
  end do
end subroutine jacobi_smoother_mask2

subroutine calc_ax_mask2( &
                Ax, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                m, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ax
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    Ax(ijk) = &
            ( Aw(ijk)*x(ijk - 1) &
            + Ae(ijk)*x(ijk + 1) &
            + As(ijk)*x(ijk - cx) &
            + An(ijk)*x(ijk + cx) &
            + Ab(ijk)*x(ijk - cx*cy) &
            + At(ijk)*x(ijk + cx*cy) &
            + Ap(ijk)*x(ijk) )*m(ijk)
  end do
end subroutine calc_ax_mask2

subroutine calc_r_mask2( &
                r, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                b, &
                m, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: r
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: b
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    r(ijk) = (b(ijk) &
            - Aw(ijk)*x(ijk - 1) &
            - Ae(ijk)*x(ijk + 1) &
            - As(ijk)*x(ijk - cx) &
            - An(ijk)*x(ijk + cx) &
            - Ab(ijk)*x(ijk - cx*cy) &
            - At(ijk)*x(ijk + cx*cy) &
            - Ap(ijk)*x(ijk))*m(ijk)
  end do
end subroutine calc_r_mask2

subroutine calc_r2_mask2( &
                rr, &
                Ap, Aw, Ae, As, An, Ab, At, &
                x, &
                b, &
                m, &
                sz, g)
  implicit none
  integer                  :: cx, cy, cz
  integer                  :: ijk
  integer                  :: ijk0, ijkx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: rr
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: Ap, Aw, Ae, As, An, Ab, At
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: x
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: b
  real, dimension(1:(sz(1)+2*g)*(sz(2)+2*g)*(sz(3)+2*g))  :: m
  real                    :: r
  cx = sz(1) + 2*g
  cy = sz(2) + 2*g
  cz = sz(3) + 2*g
  ijk0 = cx*cy*g + cx*g + g + 1
  ijkx = cx*cy*cz - ijk0 + 1
  rr = 0.0d0
!ocl serial
!ocl nouxsimd
  do ijk=ijk0, ijkx
    r = b(ijk) &
            - Aw(ijk)*x(ijk - 1) &
            - Ae(ijk)*x(ijk + 1) &
            - As(ijk)*x(ijk - cx) &
            - An(ijk)*x(ijk + cx) &
            - Ab(ijk)*x(ijk - cx*cy) &
            - At(ijk)*x(ijk + cx*cy) &
            - Ap(ijk)*x(ijk)
    rr = rr + r*r*m(ijk)
  end do
end subroutine calc_r2_mask2


      SUBROUTINE CROSS(B,C,A)
C     =======================
C
C
      DIMENSION A(3),B(3),C(3)
      A(1)=B(2)*C(3)-C(2)*B(3)
      A(2)=B(3)*C(1)-C(3)*B(1)
      A(3)=B(1)*C(2)-C(1)*B(2)
      RETURN
      END
C
      FUNCTION DOT(A,B)
C     ================
C
C     DOT PRODUCT OF TWO VECTORS
C
      DIMENSION A(3),B(3)
      DOT=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)
      RETURN
      END
	SUBROUTINE MATMUL(A,B,C)
C	========================
C
C	MULTIPLY 2 3X3 MATRICES
C
C	A=BC
C
	REAL A(3,3),B(3,3),C(3,3)
	DO 1 I=1,3
	DO 2 J=1,3
	S=0
	DO 3 K=1,3
3	S=S+B(I,K)*C(K,J)
2	A(I,J)=S
1	CONTINUE
	RETURN
	END
	SUBROUTINE MATVEC(V,A,B)
C	========================
C
C	POST-MULTIPLY A 3X3 MATRIX BY A VECTOR
C
C	V=AB
C
	REAL A(3,3),B(3),V(3)
	DO 1 I=1,3
	S=0
	DO 2 J=1,3
2	S=S+A(I,J)*B(J)
1	V(I)=S
	RETURN
	END
	SUBROUTINE MINV(A,B,D)
C	======================
C
C	INVERT A GENERAL 3X3 MATRIX AND RETURN DETERMINANT IN D
C
C	A=(B)-1
C
	REAL A(3,3),B(3,3),C(3,3)
	CALL CROSS(B(1,2),B(1,3),C(1,1))
	CALL CROSS(B(1,3),B(1,1),C(1,2))
	CALL CROSS(B(1,1),B(1,2),C(1,3))
	D=DOT(B(1,1),C(1,1))
C
C	TEST DETERMINANT
C
	IF(ABS(D).GT.1.E-30)GO TO 10
	D=0.0
	RETURN
C
C	DETERMINANT IS NON-ZERO
C
10	DO 20 I=1,3
	DO 20 J=1,3
20	A(I,J)=C(J,I)/D
	RETURN
	END
C
      SUBROUTINE SCALEV(A,X,B)
C     ========================
C
C     SCALE A VECTOR B WITH SCALAR X AND PUT RESULT IN A
C
      DIMENSION A(3),B(3)
      DO 10 I=1,3
      A(I)=B(I)*X
   10 CONTINUE
      RETURN
      END
	SUBROUTINE TRANSP(A,B)
C	======================
C
C	TRANSPOSE A 3X3 MATRIX
C
C	A=BT
C
	REAL A(3,3),B(3,3)
	DO 1 I=1,3
	DO 1 J=1,3
1	A(I,J)=B(J,I)
	RETURN
	END
      SUBROUTINE UNIT(V)
C     =================
C
C
      REAL V(3)
C****VECTOR V REDUCED TO UNIT VECTOR
      VMOD=V(1)**2+V(2)**2+V(3)**2
      VMOD=SQRT(VMOD)
      DO 1 I=1,3
    1 V(I)=V(I)/VMOD
      RETURN
      END
      SUBROUTINE VDIF(A,B,C)
C     =====================
C
C
C     SUBTRACT TWO VECTORS
C
      DIMENSION A(3),B(3),C(3)
      DO 10 I=1,3
      A(I)=B(I)-C(I)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE VSET(A,B)
C     ====================
C
C
C     MOVE A VECTOR FROM B TO A
C
      DIMENSION A(3),B(3)
      DO 10 I=1,3
   10 A(I)=B(I)
      RETURN
      END
      SUBROUTINE VSUM(A,B,C)
C     ======================
C
C
C     ADD TWO VECTORS
C
      DIMENSION A(3),B(3),C(3)
      DO 10 I=1,3
      A(I)=B(I)+C(I)
   10 CONTINUE
      RETURN
      END