comment debug lines in sls

tiny bug fix in lapack interface
ralna · Jan 28, 2025 · c3b2009 · c3b2009
1 parent 8fbe897
commit c3b2009
Show file tree

Hide file tree

Showing 3 changed files with 22 additions and 12 deletions.
diff --git a/src/lapack/lapack.f90 b/src/lapack/lapack.f90
@@ -1968,7 +1968,7 @@ SUBROUTINE DGESV( n, nrhs, a, lda, ipiv, b, ldb, info)
           EXTERNAL ::  DGETRF, DGETRS, XERBLA2
           INTRINSIC :: MAX
           info = 0
-          IF( n<.0 ) THEN
+          IF( n<0 ) THEN
             info = -1
           ELSE IF( nrhs<0 ) THEN
             info = -2

diff --git a/src/sls/C/slst.c b/src/sls/C/slst.c
@@ -46,9 +46,13 @@ int main(void) {
 
         // Initialize SLS - use the sytr solver
         sls_initialize( "sytr", &data, &control, &status );
+        sls_initialize( "ma57", &data, &control, &status );
+        //sls_initialize( "ssids", &data, &control, &status );
 
         // Set user-defined control options
         control.f_indexing = false; // C sparse matrix indexing
+        //control.print_level = 1;
+        //control.print_level_solver = 2;
 
         switch(d){ // import matrix data and factorize
             case 1: // sparse co-ordinate storage
@@ -75,7 +79,6 @@ int main(void) {
         for(i=0; i<n; i++) x[i] = rhs[i];
         sls_solve_system( &data, &status, n, x );
         sls_information( &data, &inform, &status );
-
         if(inform.status == 0){
           for(i=0; i<n; i++) error[i] = x[i]-sol[i];
           status = maxabsarray( error, n, &norm_residual );
@@ -96,7 +99,6 @@ int main(void) {
         for(i=0; i<n; i++) x[i] = rhs[i];
         sls_solve_system( &data, &status, n, x );
         sls_information( &data, &inform, &status );
-
         if(inform.status == 0){
           for(i=0; i<n; i++) error[i] = x[i]-sol[i];
           status = maxabsarray( error, n, &norm_residual );
@@ -112,7 +114,9 @@ int main(void) {
         // obtain the solution by part solves
         for(i=0; i<n; i++) x[i] = rhs[i];
         sls_partial_solve_system( "L", &data, &status, n, x );
+        sls_information( &data, &inform, &status );
         sls_partial_solve_system( "D", &data, &status, n, x );
+        sls_information( &data, &inform, &status );
         sls_partial_solve_system( "U", &data, &status, n, x );
         sls_information( &data, &inform, &status );
 

diff --git a/src/sls/sls.F90 b/src/sls/sls.F90
@@ -1,4 +1,4 @@
-! THIS VERSION: GALAHAD 5.2 - 2025-01-22 AT 14:10 GMT
+! THIS VERSION: GALAHAD 5.2 - 2025-01-27 AT 11:10 GMT
 
 #include "galahad_modules.h"
 #undef METIS_DBG_INFO
@@ -1588,8 +1588,8 @@ SUBROUTINE SLS_initialize_solver( solver, data, error, inform, check )
 
 !  Dummy arguments
 
-     CHARACTER ( LEN = * ), INTENT( IN ) :: solver
-     TYPE ( SLS_data_type ), INTENT( INOUT ) :: data
+     CHARACTER ( LEN = * ), INTENT( IN ) :: solver 
+    TYPE ( SLS_data_type ), INTENT( INOUT ) :: data
      INTEGER ( KIND = ip_ ), INTENT( IN ) :: error
      TYPE ( SLS_inform_type ), INTENT( OUT ) :: inform
      LOGICAL, OPTIONAL, INTENT( IN ) :: check
@@ -1604,6 +1604,7 @@ SUBROUTINE SLS_initialize_solver( solver, data, error, inform, check )
      TYPE ( ssids_akeep ) :: akeep_ssids
 !$   LOGICAL :: OMP_GET_CANCELLATION
 !$   INTEGER ( KIND = ip_ ) :: OMP_GET_PROC_BIND
+!$   INTEGER :: omp_status
 
 !  record the solver
 
@@ -1622,10 +1623,15 @@ SUBROUTINE SLS_initialize_solver( solver, data, error, inform, check )
 
 !$   SELECT CASE( data%solver( 1 : data%len_solver ) )
 !$   CASE ( 'ssids', 'mumps' )
-!!!!$     write(6,*) 'omp', OMP_GET_CANCELLATION( ), OMP_GET_PROC_BIND( )
-!$     IF ( .NOT. OMP_GET_CANCELLATION( ) .OR.                                 &
-!$          OMP_GET_PROC_BIND( ) == 0 ) THEN
-!!!!$          OMP_GET_PROC_BIND( ) /= 1 ) THEN
+!$     CALL get_environment_variable( "OMP_CANCELLATION", STATUS = omp_status )
+!$     IF ( omp_status == 0 ) THEN
+!$       CALL get_environment_variable( "OMP_PROC_BIND", STATUS = omp_status )
+!$       IF ( omp_status == 0 ) THEN
+!$         IF ( .NOT. OMP_GET_CANCELLATION( ) .OR.                             &
+!$              OMP_GET_PROC_BIND( ) == 0 ) omp_status = - 3
+!$       END IF
+!$     END IF
+!$     IF (  omp_status /= 0 ) THEN
 !$       IF ( error > 0 ) WRITE( error,                                        &
 !$         "( ' WARNING: To use the requested linear solver ', A,              &
 !$      &     ', the environment variables', /,  '          OMP_CANCELLATION', &
@@ -8736,8 +8742,8 @@ SUBROUTINE SLS_part_solve( part, X, data, control, inform )
 !  = SSIDS =
 
      CASE ( 'ssids' )
-       inform%status = GALAHAD_unavailable_option
-       GO TO 900
+!      inform%status = GALAHAD_unavailable_option
+!      GO TO 900
        CALL CPU_time( time ) ; CALL CLOCK_time( clock )
        IF ( part == 'L' .OR. ( part == 'S' .AND. data%must_be_definite ) ) THEN
          CALL SSIDS_solve( X( : data%n ), data%ssids_akeep, data%ssids_fkeep,  &