Merge branch 'master' into export_import_cblas_globals

BLAS/SRC/CMakeLists.txt

@@ -129,7 +129,7 @@ if(BUILD_INDEX64_EXT_API)
   set_target_properties(${BLASLIB}_64_obj PROPERTIES POSITION_INDEPENDENT_CODE ON)
   #Add _64 suffix to all Fortran functions via macros
   foreach(F IN LISTS SOURCES_64_F)
-    if(CMAKE_Fortran_COMPILER_ID STREQUAL "NAG")
+    if(CMAKE_Fortran_COMPILER_ID STREQUAL "NAG" OR CMAKE_Fortran_COMPILER_ID MATCHES "Intel")
       set_source_files_properties(${F} PROPERTIES COMPILE_FLAGS "-fpp")
     else()
       set_source_files_properties(${F} PROPERTIES COMPILE_FLAGS "-cpp")

CBLAS/CMakeLists.txt

@@ -13,9 +13,16 @@ endif()
 
 set(LAPACK_INSTALL_EXPORT_NAME ${CBLASLIB}-targets)
 
-include(CheckCSourceCompiles)
-check_c_source_compiles("int __attribute__((weak)) main() {};"
-                        HAS_ATTRIBUTE_WEAK_SUPPORT)
+if(WIN32)
+  # MSVC does not support __attribute__((weak)) and the Intel compiler supports
+  # it but produces linker errors when used in CBLAS, so we disable it for all
+  # Windows builds.
+  set(HAS_ATTRIBUTE_WEAK_SUPPORT FALSE)
+else()
+  include(CheckCSourceCompiles)
+  check_c_source_compiles("int __attribute__((weak)) main() {};"
+                          HAS_ATTRIBUTE_WEAK_SUPPORT)
+endif()
 
 include_directories(include ${LAPACK_BINARY_DIR}/include)
 add_subdirectory(src)

LAPACKE/include/lapack.h

@@ -47,7 +47,8 @@
 #else
 #include <complex>
 #endif
-#if _MSC_VER
+
+#if defined(_MSC_VER) && !defined(__INTEL_COMPILER) && !defined(__INTEL_LLVM_COMPILER)
 #define lapack_complex_float    _Fcomplex
 #else
 #define lapack_complex_float    float _Complex
@@ -69,7 +70,8 @@
 #else
 #include <complex>
 #endif
-#if _MSC_VER
+
+#if defined(_MSC_VER) && !defined(__INTEL_COMPILER) && !defined(__INTEL_LLVM_COMPILER)
 #define lapack_complex_double   _Dcomplex
 #else
 #define lapack_complex_double   double _Complex

LAPACKE/include/lapacke_config.h

@@ -99,7 +99,7 @@ typedef struct { double real, imag; } _lapack_complex_double;
 #define lapack_complex_double_real(z)       ((z).real())
 #define lapack_complex_double_imag(z)       ((z).imag())
 
-#elif _MSC_VER
+#elif defined(_MSC_VER) && !defined(__INTEL_COMPILER) && !defined(__INTEL_LLVM_COMPILER)
 
 #include <complex.h>
 #define lapack_complex_float    _Fcomplex

LAPACKE/src/lapacke_nancheck.c

@@ -32,6 +32,9 @@
 
 #include "lapacke_utils.h"
 
+#include <stdlib.h>
+#include <string.h>
+
 static int nancheck_flag = -1;
 
 void LAPACKE_set_nancheck( int flag )
@@ -39,21 +42,73 @@ void LAPACKE_set_nancheck( int flag )
     nancheck_flag = ( flag ) ? 1 : 0;
 }
 
+typedef struct {
+    int found;
+    char *value;
+} lapacke_env_var;
+
+static inline lapacke_env_var LAPACKE_getenv(const char *var_name)
+{
+    size_t var_length = 0;
+
+    /* Get the length of the environment variable value */
+#if defined(_WIN32)
+    errno_t result = getenv_s( &var_length, NULL, 0, var_name );
+    if ( result != 0 || var_length == 0 ) {
+        return (lapacke_env_var){ 0, NULL };
+    }
+#else
+    const char *env = getenv( var_name );
+    if ( env == NULL ) {
+        return (lapacke_env_var){ 0, NULL };
+    }
+    var_length = strlen( env ) + 1;
+#endif
+
+    /* Allocate memory for the environment variable value */
+    char *value = (char *)LAPACKE_malloc( var_length );
+    if ( value == NULL ) {
+        return (lapacke_env_var){ 0, NULL };
+    }
+
+    /* Get the value of the environment variable */
+#if defined(_WIN32)
+    result = getenv_s( &var_length, value, var_length, var_name );
+    if ( result != 0 ) {
+        LAPACKE_free( value );
+        return (lapacke_env_var){ 0, NULL };
+    }
+#else
+    memcpy( value, env, var_length );
+#endif
+
+    return (lapacke_env_var){ 1, value };
+}
+
+static inline void LAPACKE_freenv(lapacke_env_var *var)
+{
+    if ( var->found && var->value != NULL ) {
+        LAPACKE_free( var->value );
+    }
+    var->found = 0;
+    var->value = NULL;
+}
+
 int LAPACKE_get_nancheck( )
 {
-    char* env;
     if ( nancheck_flag != -1 ) {
         return nancheck_flag;
     }
 
     /* Check environment variable, once and only once */
-    env = getenv( "LAPACKE_NANCHECK" );
-    if ( !env ) {
+    lapacke_env_var lapacke_nancheck = LAPACKE_getenv( "LAPACKE_NANCHECK" );
+    if ( !lapacke_nancheck.found ) {
         /* By default, NaN checking is enabled */
         nancheck_flag = 1;
     } else {
-        nancheck_flag = atoi( env ) ? 1 : 0;
+        nancheck_flag = atoi( lapacke_nancheck.value ) ? 1 : 0;
     }
 
+    LAPACKE_freenv( &lapacke_nancheck );
     return nancheck_flag;
 }

LAPACKE/utils/lapacke_make_complex_double.c

@@ -43,7 +43,7 @@ lapack_complex_double lapack_make_complex_double( double re, double im ) {
     z = re + im * I;
 #elif defined(LAPACK_COMPLEX_CPP)
     z = std::complex<double>(re,im);
-#elif _MSC_VER
+#elif defined(_MSC_VER) && !defined(__INTEL_COMPILER) && !defined(__INTEL_LLVM_COMPILER)
     z = _Cbuild(re, im);
 #else /* C99 is default */
     z = re + im*I;

LAPACKE/utils/lapacke_make_complex_float.c

@@ -43,7 +43,7 @@ lapack_complex_float lapack_make_complex_float( float re, float im ) {
     z = re + im * I;
 #elif defined(LAPACK_COMPLEX_CPP)
     z = std::complex<float>(re,im);
-#elif _MSC_VER
+#elif defined(_MSC_VER) && !defined(__INTEL_COMPILER) && !defined(__INTEL_LLVM_COMPILER)
     z = _FCbuild(re, im);
 #else /* C99 is default */
     z = re + im*I;

SRC/cgees.f

@@ -209,7 +209,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(EV) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(EV)
           COMPLEX EV
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/cgeesx.f

@@ -253,7 +253,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(EV) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(EV)
           COMPLEX EV
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/cgges.f

@@ -285,7 +285,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA)
           COMPLEX ALPHA, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/cgges3.f

@@ -284,7 +284,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA)
           COMPLEX ALPHA, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/cggesx.f

@@ -347,7 +347,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA)
           COMPLEX ALPHA, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/clarf1f.f

@@ -150,7 +150,7 @@
       INTEGER            I, LASTV, LASTC
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           CAXPY, CGEMV, CGER, CSCAL
+      EXTERNAL           CAXPY, CGEMV, CGERC, CSCAL
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          CONJG

SRC/dgees.f

@@ -228,7 +228,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI)
           DOUBLE PRECISION WR, WI
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/dgeesx.f

@@ -295,7 +295,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI)
           DOUBLE PRECISION WR, WI
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/dgges.f

@@ -298,7 +298,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA)
           DOUBLE PRECISION ALPHAR, ALPHAI, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/dgges3.f

@@ -297,7 +297,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA)
           DOUBLE PRECISION ALPHAR, ALPHAI, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/dggesx.f

@@ -382,7 +382,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA)
           DOUBLE PRECISION ALPHAR, ALPHAI, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/sgees.f

@@ -228,7 +228,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI)
           REAL WR, WI
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/sgeesx.f

@@ -295,7 +295,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(WR, WI)
           REAL WR, WI
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/sgges.f

@@ -298,7 +298,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA)
           REAL ALPHAR, ALPHAI, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/sgges3.f

@@ -297,7 +297,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA)
           REAL ALPHAR, ALPHAI, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/sggesx.f

@@ -382,7 +382,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHAR, ALPHAI, BETA)
           REAL ALPHAR, ALPHAI, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/zgees.f

@@ -209,7 +209,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(EV) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(EV)
           COMPLEX*16 EV
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/zgeesx.f

@@ -253,7 +253,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELECT_PROC_TYPE(EV) BIND(C)
+        LOGICAL FUNCTION SELECT_PROC_TYPE(EV)
           COMPLEX*16 EV
         END FUNCTION SELECT_PROC_TYPE
       END INTERFACE

SRC/zgges.f

@@ -285,7 +285,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA)
           COMPLEX*16 ALPHA, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/zgges3.f

@@ -284,7 +284,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA)
           COMPLEX*16 ALPHA, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/zggesx.f

@@ -347,7 +347,7 @@
 *     ..
 *     .. Function Arguments ..
       INTERFACE
-        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA) BIND(C)
+        LOGICAL FUNCTION SELCTG_PROC_TYPE(ALPHA,BETA)
           COMPLEX*16 ALPHA, BETA
         END FUNCTION SELCTG_PROC_TYPE
       END INTERFACE

SRC/zupmtr.f

@@ -176,7 +176,7 @@
       EXTERNAL           LSAME
 *     ..
 *     .. External Subroutines ..
-      EXTERNAL           XERBLA, ZLARF1, ZLARF1F
+      EXTERNAL           XERBLA, ZLARF1L, ZLARF1F
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          DCONJG, MAX