From d1a42e8fac576c7c9463532c73e19524a8ead5a8 Mon Sep 17 00:00:00 2001 From: Nick Gould Date: Tue, 17 Oct 2023 09:14:26 +0100 Subject: [PATCH] added cisgrp to find sparsity of individual functions --- man/man3/cutest.3 | 10 + man/man3/cutest_cisgrp.3 | 101 ++++++++++ man/man3/cutest_cisgrp_threaded.3 | 105 ++++++++++ src/test/ctest.f90 | 40 ++++ src/test/ctest_threaded.f90 | 45 ++++- src/tools/cisgrp.f90 | 324 ++++++++++++++++++++++++++++++ src/tools/cshj.f90 | 20 +- src/tools/cutest.f90 | 1 + src/tools/makemaster | 19 +- src/tools/timings.f90 | 2 + 10 files changed, 652 insertions(+), 15 deletions(-) create mode 100644 man/man3/cutest_cisgrp.3 create mode 100644 man/man3/cutest_cisgrp_threaded.3 create mode 100644 src/tools/cisgrp.f90 diff --git a/man/man3/cutest.3 b/man/man3/cutest.3 index 37487d2..7ac03b4 100644 --- a/man/man3/cutest.3 +++ b/man/man3/cutest.3 @@ -199,6 +199,16 @@ evaluate the sparse gradients of the objective function and constraints. .B cutest_ccfg \fP(unthreaded) and \fBcutest_ccfg_threaded \fP(threaded) evaluate the values and gradients of the constraints. .TP +.B cutest_cigr \fP(unthreaded) and \fBcutest_cigr_threaded \fP(threaded) +evaluate the gradient of the objective or an individual constraint. +.TP +.B cutest_cisgr \fP(unthreaded) and \fBcutest_cisgr_threaded \fP(threaded) +evaluate the sparse gradient of the objective or an individual constraint. +.TP +.B cutest_cisgrp \fP(unthreaded) and \fBcutest_cisgrp_threaded \fP(threaded) +evaluate the sparse pattern of the gradient of the objective or an +individual constraint. +.TP .B cutest_ccfsg \fP(unthreaded) and \fBcutest_ccfsg_threaded \fP(threaded) evaluate the values and sparse gradients of the constraints. .TP diff --git a/man/man3/cutest_cisgrp.3 b/man/man3/cutest_cisgrp.3 new file mode 100644 index 0000000..05d9272 --- /dev/null +++ b/man/man3/cutest_cisgrp.3 @@ -0,0 +1,101 @@ +'\" e @(#)cutest_cisgrp v1.0 10/2023; +.TH cutest_cisgrp 3M "17 Oct 2023" "CUTEst user documentation" "CUTEst user documentation" +.SH NAME +CUTEST_cisgrp \- CUTEst tool to evaluate the sparsity pattern of +the gradient of a problem function. +.SH SYNOPSIS +.HP 1i +CALL CUTEST_cisgrp( status, n, iprob, nnzg, lg, G_var ) +.SH DESCRIPTION +The CUTEST_cisgrp subroutine evaluates the sparsity pattern of +the gradient of either the objective function or a constraint function +of the problem decoded from a SIF file by the script +\fIsifdecoder\fP, in the constrained minimization case. +The problem under consideration +is to minimize or maximize an objective function +.EQ +f(x) +.EN +over all +.EQ +x +.EN +\(mo +.EQ +R sup n +.EN +subject to +general equations +.EQ +c sub i (x) ~=~ 0, +.EN +.EQ +~(i +.EN +\(mo +.EQ +{ 1 ,..., m sub E } ), +.EN +general inequalities +.EQ +c sub i sup l ~<=~ c sub i (x) ~<=~ c sub i sup u, +.EN +.EQ +~(i +.EN +\(mo +.EQ +{ m sub E + 1 ,..., m }), +.EN +and simple bounds +.EQ +x sup l ~<=~ x ~<=~ x sup u. +.EN +The objective function is group-partially separable and +all constraint functions are partially separable. + +.LP +.SH ARGUMENTS +The arguments of CUTEST_cisgrp are as follows +.TP 5 +.B status \fP[out] - integer +the outputr status: 0 for a succesful call, 1 for an array +allocation/deallocation error, 2 for an array bound error, +3 for an evaluation error, +.TP +.B n \fP[in] - integer +the number of variables for the problem, +.TP 5 +.B iprob \fP[in] - integer +the number of the problem function to be considered. If iprob = 0, the +value of the objective function will be evaluated, while if iprob = +i > 0, that of the i-th constraint will be evaluated, +.TP +.B nnzg \fP[out] - integer +the number of nonzeros in G_var, +.TP +.B lg \fP[in] - integer +the declared length of G_var, +.TP +.B G_var \fP[out] - integer +an array whose i-th component is the unique index of a variable within +the sparsity pattern of the gradient. +.LP +.SH AUTHORS +I. Bongartz, A.R. Conn, N.I.M. Gould, D. Orban and Ph.L. Toint +.SH "SEE ALSO" +\fICUTEst: a Constrained and Unconstrained Testing +Environment with safe threads\fP, + N.I.M. Gould, D. Orban and Ph.L. Toint, + Computational Optimization and Applications \fB60\fP:3, pp.545-557, 2014. + +\fICUTEr (and SifDec): A Constrained and Unconstrained Testing +Environment, revisited\fP, + N.I.M. Gould, D. Orban and Ph.L. Toint, + ACM TOMS, \fB29\fP:4, pp.373-394, 2003. + +\fICUTE: Constrained and Unconstrained Testing Environment\fP, + I. Bongartz, A.R. Conn, N.I.M. Gould and Ph.L. Toint, + ACM TOMS, \fB21\fP:1, pp.123-160, 1995. + +sifdecoder(1), cutest_cigr(3), cutest_cisgr(3) diff --git a/man/man3/cutest_cisgrp_threaded.3 b/man/man3/cutest_cisgrp_threaded.3 new file mode 100644 index 0000000..179e058 --- /dev/null +++ b/man/man3/cutest_cisgrp_threaded.3 @@ -0,0 +1,105 @@ +'\" e @(#)cutest_cisgrp_threaded v1.0 10/2023; +.TH cutest_cisgrp_threaded 3M "17 Oct 2023" "CUTEst user documentation" "CUTEst user documentation" +.SH NAME +CUTEST_cisgrp_threaded \- CUTEst tool to evaluate the sparsity pattern of +gradient of a problem function. +.SH SYNOPSIS +.HP 1i +CALL CUTEST_cisgrp_threaded( status, n, iprob, nnzg, lg, G_var, thread ) +.SH DESCRIPTION +The CUTEST_cisgrp_threaded subroutine evaluates the sparsity pattern of +the gradient of either the objective function or a constraint function +of the problem decoded from a SIF file by the script +\fIsifdecoder\fP, in the constrained minimization case. +The problem under consideration +is to minimize or maximize an objective function +.EQ +f(x) +.EN +over all +.EQ +x +.EN +\(mo +.EQ +R sup n +.EN +subject to +general equations +.EQ +c sub i (x) ~=~ 0, +.EN +.EQ +~(i +.EN +\(mo +.EQ +{ 1 ,..., m sub E } ), +.EN +general inequalities +.EQ +c sub i sup l ~<=~ c sub i (x) ~<=~ c sub i sup u, +.EN +.EQ +~(i +.EN +\(mo +.EQ +{ m sub E + 1 ,..., m }), +.EN +and simple bounds +.EQ +x sup l ~<=~ x ~<=~ x sup u. +.EN +The objective function is group-partially separable and +all constraint functions are partially separable. + +.LP +.SH ARGUMENTS +The arguments of CUTEST_cisgrp_threaded are as follows +.TP 5 +.B status \fP[out] - integer +the outputr status: 0 for a succesful call, 1 for an array +allocation/deallocation error, 2 for an array bound error, +3 for an evaluation error, 4 for an out-of-range thread, +.TP +.B n \fP[in] - integer +the number of variables for the problem, +.TP 5 +.B iprob \fP[in] - integer +the number of the problem function to be considered. If iprob = 0, the +value of the objective function will be evaluated, while if iprob = +i > 0, that of the i-th constraint will be evaluated, +.TP +.B nnzg \fP[out] - integer +the number of nonzeros in G_var, +.TP +.B lg \fP[in] - integer +the declared length of G_var, +.TP +.B G_var \fP[out] - integer +an array whose i-th component is the unique index of a variable within +the sparsity pattern of the gradient. +.TP +.B thread \fP[in] - integer +thread chosen for the evaluation; threads are numbered +from 1 to the value threads set when calling CUTEST_csetup_threaded. +.LP +.SH AUTHORS +I. Bongartz, A.R. Conn, N.I.M. Gould, D. Orban and Ph.L. Toint +.SH "SEE ALSO" +\fICUTEst: a Constrained and Unconstrained Testing +Environment with safe threads\fP, + N.I.M. Gould, D. Orban and Ph.L. Toint, + Computational Optimization and Applications \fB60\fP:3, pp.545-557, 2014. + +\fICUTEr (and SifDec): A Constrained and Unconstrained Testing +Environment, revisited\fP, + N.I.M. Gould, D. Orban and Ph.L. Toint, + ACM TOMS, \fB29\fP:4, pp.373-394, 2003. + +\fICUTE: Constrained and Unconstrained Testing Environment\fP, + I. Bongartz, A.R. Conn, N.I.M. Gould and Ph.L. Toint, + ACM TOMS, \fB21\fP:1, pp.123-160, 1995. + +sifdecoder(1), cutest_cigr(3), cutest_cisgr(3), cutest_setup_threaded(3M). diff --git a/src/test/ctest.f90 b/src/test/ctest.f90 index 9b63bf1..ed81f47 100644 --- a/src/test/ctest.f90 +++ b/src/test/ctest.f90 @@ -240,6 +240,13 @@ PROGRAM CUTEST_test_constrained_tools IF ( status /= 0 ) GO TO 900 CALL WRITE_SG( out, G_ne, l_g, G_val, G_var ) +! and its sparsity pattern + + WRITE( out, "( ' CALL CUTEST_cisgrp for the objective function' )" ) + CALL CUTEST_cisgrp( status, n, icon, G_ne, l_g, G_var ) + IF ( status /= 0 ) GO TO 900 + CALL WRITE_G_sparsity_pattern( out, G_ne, l_g, G_var ) + ! compute the number of nonzeros in the sparse Jacobian WRITE( out, "( ' CALL CUTEST_cdimsj' )" ) @@ -389,6 +396,13 @@ PROGRAM CUTEST_test_constrained_tools IF ( status /= 0 ) GO TO 900 CALL WRITE_SJI( out, icon, Ji_ne, n, Ji, J_var ) +! and its sparsity pattern + + WRITE( out, "( ' CALL CUTEST_cisgrp for a constraint' )" ) + CALL CUTEST_cisgrp( status, n, icon, G_ne, l_g, G_var ) + IF ( status /= 0 ) GO TO 900 + CALL WRITE_G_sparsity_pattern( out, G_ne, l_g, G_var ) + ! compute the dense Hessian value WRITE( out, "( ' CALL CUTEST_cdh' )" ) @@ -1037,6 +1051,32 @@ SUBROUTINE WRITE_JT_dense( out, n, m, l_j2_1, l_j2_2, J2_val ) END DO END SUBROUTINE WRITE_JT_dense + SUBROUTINE WRITE_G_sparsity_pattern( out, G_ne, l_g, G_ind ) + INTEGER :: l_g, G_ne, out + INTEGER, DIMENSION( l_g ) :: G_ind + INTEGER :: i + WRITE( out, "( ' * G(sparse)' )" ) + WRITE( out, "( ' * ', 5( ' ind' ) )" ) + DO i = 1, G_ne, 5 + IF ( i + 4 <= G_ne ) THEN + WRITE( out, "( ' * ', 5( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ), G_ind( i + 2 ), G_ind( i + 3 ), & + G_ind( i + 4 ) + ELSE IF ( i + 3 <= G_ne ) THEN + WRITE( out, "( ' * ', 4( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ), G_ind( i + 2 ), G_ind( i + 3 ) + ELSE IF ( i + 2 <= G_ne ) THEN + WRITE( out, "( ' * ', 3( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ), G_ind( i + 2 ) + ELSE IF ( i + 1 <= G_ne ) THEN + WRITE( out, "( ' * ', 2( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ) + ELSE + WRITE( out, "( ' * ', I7 )" ) G_ind( i ) + END IF + END DO + END SUBROUTINE WRITE_G_sparsity_pattern + SUBROUTINE WRITE_H_sparsity_pattern( out, H_ne, l_h, H_row, H_col ) INTEGER :: l_h, H_ne, out INTEGER, DIMENSION( l_h ) :: H_row, H_col diff --git a/src/test/ctest_threaded.f90 b/src/test/ctest_threaded.f90 index 8e5d745..727baef 100644 --- a/src/test/ctest_threaded.f90 +++ b/src/test/ctest_threaded.f90 @@ -40,7 +40,7 @@ PROGRAM CUTEST_test_constrained_tools INTEGER :: equality_constraints, linear_constraints INTEGER :: nnz_vector, nnz_result INTEGER :: CHP_ne, l_chp, l_j2_1, l_j2_2, l_j, icon, iprob - REAL ( KIND = wp ) :: f, ci, x0 + REAL ( KIND = wp ) :: f, ci, y0 LOGICAL :: grad, byrows, goth, gotj LOGICAL :: grlagf, jtrans CHARACTER ( len = 10 ) :: p_name @@ -243,6 +243,13 @@ PROGRAM CUTEST_test_constrained_tools IF ( status /= 0 ) GO TO 900 CALL WRITE_SG( out, G_ne, l_g, G_val, G_var ) +! and its sparsity pattern + + WRITE( out, "( ' CALL CUTEST_cisgrp for the objective function' )" ) + CALL CUTEST_cisgrp_threaded( status, n, icon, G_ne, l_g, G_var, thread ) + IF ( status /= 0 ) GO TO 900 + CALL WRITE_G_sparsity_pattern( out, G_ne, l_g, G_var ) + ! compute the number of nonzeros in the sparse Jacobian WRITE( out, "( ' CALL CUTEST_cdimsj' )" ) @@ -393,6 +400,13 @@ PROGRAM CUTEST_test_constrained_tools IF ( status /= 0 ) GO TO 900 CALL WRITE_SJI( out, icon, Ji_ne, n, Ji, J_var ) +! and its sparsity pattern + + WRITE( out, "( ' CALL CUTEST_cisgrp for a constraint' )" ) + CALL CUTEST_cisgrp_threaded( status, n, icon, G_ne, l_g, G_var, thread ) + IF ( status /= 0 ) GO TO 900 + CALL WRITE_G_sparsity_pattern( out, G_ne, l_g, G_var ) + ! compute the dense Hessian value WRITE( out, "( ' CALL CUTEST_cdh' )" ) @@ -494,11 +508,10 @@ PROGRAM CUTEST_test_constrained_tools y0 = 2.0_wp WRITE( out, "( ' CALL CUTEST_cshj' )" ) CALL CUTEST_cshj_threaded( status, n, m, X, y0, Y, & - H_ne, l_h, H_val, H_row, H_col ) + H_ne, l_h, H_val, H_row, H_col, thread ) IF ( status /= 0 ) GO TO 900 CALL WRITE_H_sparse( out, H_ne, l_h, H_val, H_row, H_col ) - ! compute the sparse Hessian value of the objective or a constraint iprob = 0 @@ -1049,6 +1062,32 @@ SUBROUTINE WRITE_JT_dense( out, n, m, l_j2_1, l_j2_2, J2_val ) END DO END SUBROUTINE WRITE_JT_dense + SUBROUTINE WRITE_G_sparsity_pattern( out, G_ne, l_g, G_ind ) + INTEGER :: l_g, G_ne, out + INTEGER, DIMENSION( l_g ) :: G_ind + INTEGER :: i + WRITE( out, "( ' * G(sparse)' )" ) + WRITE( out, "( ' * ', 5( ' ind' ) )" ) + DO i = 1, G_ne, 5 + IF ( i + 4 <= G_ne ) THEN + WRITE( out, "( ' * ', 5( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ), G_ind( i + 2 ), G_ind( i + 3 ), & + G_ind( i + 4 ) + ELSE IF ( i + 3 <= G_ne ) THEN + WRITE( out, "( ' * ', 4( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ), G_ind( i + 2 ), G_ind( i + 3 ) + ELSE IF ( i + 2 <= G_ne ) THEN + WRITE( out, "( ' * ', 3( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ), G_ind( i + 2 ) + ELSE IF ( i + 1 <= G_ne ) THEN + WRITE( out, "( ' * ', 2( I7 ) )" ) & + G_ind( i ), G_ind( i + 1 ) + ELSE + WRITE( out, "( ' * ', I7 )" ) G_ind( i ) + END IF + END DO + END SUBROUTINE WRITE_G_sparsity_pattern + SUBROUTINE WRITE_H_sparsity_pattern( out, H_ne, l_h, H_row, H_col ) INTEGER :: l_h, H_ne, out INTEGER, DIMENSION( l_h ) :: H_row, H_col diff --git a/src/tools/cisgrp.f90 b/src/tools/cisgrp.f90 new file mode 100644 index 0000000..237dd64 --- /dev/null +++ b/src/tools/cisgrp.f90 @@ -0,0 +1,324 @@ +! THIS VERSION: CUTEST 2.1 - 2023-10-17 AT 08:00 GMT. + +!-*-*-*-*-*-*- C U T E S T C I S G R P S U B R O U T I N E -*-*-*-*-*- + +! Copyright reserved, Gould/Orban/Toint, for GALAHAD productions +! Principal author: Nick Gould + +! History - +! modern fortran version released in CUTEst, 17th October 2023 + + SUBROUTINE CUTEST_cisgrp( status, n, iprob, nnzgr, lgr, GR_var ) + USE CUTEST + INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) + +! dummy arguments + + INTEGER, INTENT( IN ) :: n, iprob, lgr + INTEGER, INTENT( OUT ) :: status, nnzgr + INTEGER, INTENT( OUT ), DIMENSION( lgr ) :: GR_var + +! ------------------------------------------------------------------- +! compute the sparsity pattern of the gradient of a specified problem +! function (iprob = 0 is the objective function, while iprob > 0 is +! the iprob-th constraint) initially written in Standard Input Format +! (SIF). The nonzero components of the iprob-th gradient occur in +! positions GR_var(j), j = 1,...,nnzgr. +! ------------------------------------------------------------------- + + CALL CUTEST_cisgrp_threadsafe( CUTEST_data_global, & + CUTEST_work_global( 1 ), & + status, n, iprob, nnzgr, lgr, GR_var ) + RETURN + +! end of subroutine CUTEST_cisgrp + + END SUBROUTINE CUTEST_cisgrp + +!-*- C U T E S T C I S G R P _ t h r e a d e d S U B R O U T I N E -*- + +! Copyright reserved, Gould/Orban/Toint, for GALAHAD productions +! Principal author: Nick Gould + +! History - +! modern fortran version released in CUTEst, 17th October 2023 + + SUBROUTINE CUTEST_cisgrp_threaded( status, n, iprob, nnzgr, lgr, & + GR_var, thread ) + USE CUTEST + INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) + +! dummy arguments + + INTEGER, INTENT( IN ) :: n, iprob, lgr, thread + INTEGER, INTENT( OUT ) :: status, nnzgr + INTEGER, INTENT( OUT ), DIMENSION( lgr ) :: GR_var + +! --------------------------------------------------------------------- +! compute the sparsity pattern of the gradient of a specified problem +! function (iprob = 0 is the objective function, while iprob > 0 is +! the iprob-th constraint) initially written in Standard Input Format +! (SIF). The nonzero components of the iprob-th gradient occur in +! positions GR_var(j), j = 1,...,nnzgr. +! --------------------------------------------------------------------- + +! check that the specified thread is within range + + IF ( thread < 1 .OR. thread > CUTEST_data_global%threads ) THEN + IF ( CUTEST_data_global%out > 0 ) & + WRITE( CUTEST_data_global%out, "( ' ** CUTEST error: thread ', I0, & + & ' out of range [1,', I0, ']' )" ) thread, CUTEST_data_global%threads + status = 4 ; RETURN + END IF + +! evaluate using specified thread + + CALL CUTEST_cisgrp_threadsafe( CUTEST_data_global, & + CUTEST_work_global( thread ), & + status, n, iprob, nnzgr, lgr, GR_var ) + RETURN + +! end of subroutine CUTEST_cisgrp_threaded + + END SUBROUTINE CUTEST_cisgrp_threaded + +!-*- C U T E S T C I S G R P _ t h r e a d s a f e S U B R O U T I N E -*- + +! Copyright reserved, Gould/Orban/Toint, for GALAHAD productions +! Principal authors: Ingrid Bongartz and Nick Gould + +! History - +! modern fortran version released in CUTEst, 17th October 2023 + + SUBROUTINE CUTEST_cisgrp_threadsafe( data, work, status, n, iprob, & + nnzgr, lgr, GR_var ) + USE CUTEST + INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) + +! dummy arguments + + TYPE ( CUTEST_data_type ), INTENT( IN ) :: data + TYPE ( CUTEST_work_type ), INTENT( INOUT ) :: work + INTEGER, INTENT( IN ) :: n, iprob, lgr + INTEGER, INTENT( OUT ) :: status, nnzgr + INTEGER, INTENT( OUT ), DIMENSION( lgr ) :: GR_var + +! ------------------------------------------------------------------- +! compute the sparsity pattern of the gradient of a specified problem +! function (iprob = 0 is the objective function, while iprob > 0 is +! the iprob-th constraint) initially written in Standard Input Format +! (SIF). The nonzero components of the iprob-th gradient occur in +! positions GR_var(j), j = 1,...,nnzgr. +! ------------------------------------------------------------------- + +! local variables + + INTEGER :: i, j, iel, k, ig, ii, ig1, l, ll, ncalcg, neling + INTEGER :: nin, nvarel, nelow, nelup, istrgv, iendgv, ifstat, igstat + REAL :: time_in, time_out + LOGICAL :: nontrv + INTEGER, DIMENSION( 1 ) :: ICALCG + EXTERNAL :: RANGE + + IF ( work%record_times ) CALL CPU_TIME( time_in ) + +! check input parameters + + IF ( iprob < 0 ) THEN + IF ( data%out > 0 ) WRITE( data%out, "( ' ** SUBROUTINE CISGRP: ', & + & 'invalid constraint index iprob ' )" ) + status = 2 ; GO TO 990 + END IF + +! constraint gradient required + + IF ( iprob > 0 ) THEN + +! find group index ig of constraint iprob + + ig = 0 + DO i = 1, data%ng + IF ( data%KNDOFC( i ) == iprob ) THEN + ig = i + EXIT + END IF + END DO + IF ( ig == 0 ) THEN + IF ( data%out > 0 ) WRITE( data%out, "( ' ** SUBROUTINE CISGRP: ', & + & 'invalid constraint index iprob ' )" ) + status = 2 ; GO TO 990 + END IF + +! determine nonlinear elements in group ig. Record their indices in ICALCF + + neling = data%ISTADG( ig + 1 ) - data%ISTADG( ig ) + j = data%ISTADG( ig ) - 1 + DO i = 1, neling + j = j + 1 + work%ICALCF( i ) = data%IELING( j ) + END DO + +! objective gradient required + + ELSE + +! identify which elements are included in objective function. Use LOGIC +! to keep track of elements already included + + work%LOGIC( : data%nel ) = .FALSE. + +! now identify elements in objective function groups + + neling = 0 + DO ig = 1, data%ng + IF ( data%KNDOFC( ig ) == 0 ) THEN + DO ii = data%ISTADG( ig ), data%ISTADG( ig + 1 ) - 1 + iel = data%IELING( ii ) + IF ( .NOT. work%LOGIC( iel ) ) THEN + work%LOGIC( iel ) = .TRUE. + neling = neling + 1 + work%ICALCF( neling ) = iel + END IF + END DO + END IF + END DO + END IF + +! Use ISWKSP to flag which variables have nonzero partial derivatives + + work%ISWKSP( : data%n ) = 0 + nnzgr = 0 + +! constraint gradient required + + IF ( iprob > 0 ) THEN + ig1 = ig + 1 + +! the group has nonlinear elements + + IF ( data%ISTADG( ig ) <= data%ISTADG( ig1 ) - 1 ) THEN + +! allocate a gradient + +!DIR$ IVDEP + DO i = data%ISTAGV( ig ), data%ISTAGV( ig1 ) - 1 + ll = data%ISVGRP( i ) + +! include the contributions from only the first n variables + + IF ( ll <= n ) THEN + IF ( work%ISWKSP( ll ) == 0 ) THEN + nnzgr = nnzgr + 1 + work%ISWKSP( ll ) = nnzgr + GR_var( nnzgr ) = ll + END IF + END IF + END DO + +! the group has only linear elements + + ELSE + +! allocate a gradient + +!DIR$ IVDEP + DO k = data%ISTADA( ig ), data%ISTADA( ig1 ) - 1 + ll = data%ICNA( k ) + +! include the contributions from linear elements for only the first n +! variables + + IF ( ll <= n ) THEN + IF ( work%ISWKSP( ll ) == 0 ) THEN + nnzgr = nnzgr + 1 + work%ISWKSP( ll ) = nnzgr + GR_var( nnzgr ) = ll + END IF + END IF + END DO + END IF + +! objective gradient required + + ELSE + +! compute the list of groups involved in the required problem function + + ncalcg = 0 + DO ig = 1, data%ng + IF ( data%KNDOFC( ig ) == 0 ) THEN + ncalcg = ncalcg + 1 + work%ICALCF( ncalcg ) = ig + END IF + END DO + +! compute the group function values + + DO ig = 1, data%ng + +! consider only those groups in the objective function + + IF ( data%KNDOFC( ig ) > 0 ) CYCLE + ig1 = ig + 1 + +! the group has nonlinear elements + + IF ( data%ISTADG( ig ) <= data%ISTADG( ig1 ) - 1 ) THEN + +! allocate a gradient + +!DIR$ IVDEP + DO i = data%ISTAGV( ig ), data%ISTAGV( ig1 ) - 1 + ll = data%ISVGRP( i ) + +! include the contributions from only the first n variables + + IF ( ll <= n ) THEN + IF ( work%ISWKSP( ll ) == 0 ) THEN + nnzgr = nnzgr + 1 + work%ISWKSP( ll ) = nnzgr + GR_var( nnzgr ) = ll + END IF + END IF + END DO + +! the group has only linear elements + + ELSE + +! allocate a gradient + +!DIR$ IVDEP + DO k = data%ISTADA( ig ), data%ISTADA( ig1 ) - 1 + ll = data%ICNA( k ) + +! include the contributions from linear elements for only the first n +! variables + + IF ( ll <= n ) THEN + IF ( work%ISWKSP( ll ) == 0 ) THEN + nnzgr = nnzgr + 1 + work%ISWKSP( ll ) = nnzgr + GR_var( nnzgr ) = ll + END IF + END IF + END DO + END IF + END DO + END IF + work%nbprod = 0 + work%ISWKSP( : data%n ) = 0 + status = 0 + +! update elapsed CPU time if required + + 990 CONTINUE + IF ( work%record_times ) THEN + CALL CPU_TIME( time_out ) + work%time_cisgrp = work%time_cisgrp + time_out - time_in + END IF + RETURN + +! end of subroutine CUTEST_cisgrp_threadsafe + + END SUBROUTINE CUTEST_cisgrp_threadsafe diff --git a/src/tools/cshj.f90 b/src/tools/cshj.f90 index 0794460..0b1c05d 100644 --- a/src/tools/cshj.f90 +++ b/src/tools/cshj.f90 @@ -8,8 +8,8 @@ ! History - ! modern fortran version released in CUTEst, 16th October 2023 - SUBROUTINE CUTEST_cshj( status, n, m, X, Y0, Y, & - nnzh, lh, H_val, H_row, H_col ) + SUBROUTINE CUTEST_cshj( status, n, m, X, y0, Y, & + nnzh, lh, H_val, H_row, H_col ) USE CUTEST INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) @@ -19,7 +19,7 @@ SUBROUTINE CUTEST_cshj( status, n, m, X, Y0, Y, & INTEGER, INTENT( OUT ) :: nnzh, status INTEGER, INTENT( OUT ), DIMENSION( lh ) :: H_row, H_col REAL ( KIND = wp ), INTENT( IN ), DIMENSION( n ) :: X - REAL ( KIND = wp ), INTENT( IN ) :: Y0 + REAL ( KIND = wp ), INTENT( IN ) :: y0 REAL ( KIND = wp ), INTENT( IN ), DIMENSION( m ) :: Y REAL ( KIND = wp ), INTENT( OUT ), DIMENSION( lh ) :: H_val @@ -34,7 +34,7 @@ SUBROUTINE CUTEST_cshj( status, n, m, X, Y0, Y, & CALL CUTEST_cshj_threadsafe( CUTEST_data_global, & CUTEST_work_global( 1 ), & - status, n, m, X, Y0, Y, & + status, n, m, X, y0, Y, & nnzh, lh, H_val, H_row, H_col ) RETURN @@ -50,7 +50,7 @@ END SUBROUTINE CUTEST_cshj ! History - ! modern fortran version released in CUTEst, 16th October 2023 - SUBROUTINE CUTEST_cshj_threaded( status, n, m, X, Y0, Y, & + SUBROUTINE CUTEST_cshj_threaded( status, n, m, X, y0, Y, & nnzh, lh, H_val, H_row, H_col, thread ) USE CUTEST INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) @@ -61,7 +61,7 @@ SUBROUTINE CUTEST_cshj_threaded( status, n, m, X, Y0, Y, & INTEGER, INTENT( OUT ) :: nnzh, status INTEGER, INTENT( OUT ), DIMENSION( lh ) :: H_row, H_col REAL ( KIND = wp ), INTENT( IN ), DIMENSION( n ) :: X - REAL ( KIND = wp ), INTENT( IN ) :: Y0 + REAL ( KIND = wp ), INTENT( IN ) :: y0 REAL ( KIND = wp ), INTENT( IN ), DIMENSION( m ) :: Y REAL ( KIND = wp ), INTENT( OUT ), DIMENSION( lh ) :: H_val @@ -87,7 +87,7 @@ SUBROUTINE CUTEST_cshj_threaded( status, n, m, X, Y0, Y, & CALL CUTEST_cshj_threadsafe( CUTEST_data_global, & CUTEST_work_global( thread ), & - status, n, m, X, Y0, Y, & + status, n, m, X, y0, Y, & nnzh, lh, H_val, H_row, H_col ) RETURN @@ -104,7 +104,7 @@ END SUBROUTINE CUTEST_cshj_threaded ! derived from csh released in CUTEst, 24th November 2012 ! modern fortran version released in CUTEst, 16th October 2023 - SUBROUTINE CUTEST_cshj_threadsafe( data, work, status, n, m, X, Y0, Y, & + SUBROUTINE CUTEST_cshj_threadsafe( data, work, status, n, m, X, y0, Y, & nnzh, lh, H_val, H_row, H_col ) USE CUTEST INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) @@ -117,7 +117,7 @@ SUBROUTINE CUTEST_cshj_threadsafe( data, work, status, n, m, X, Y0, Y, & INTEGER, INTENT( OUT ) :: nnzh, status INTEGER, INTENT( OUT ), DIMENSION( lh ) :: H_row, H_col REAL ( KIND = wp ), INTENT( IN ), DIMENSION( n ) :: X - REAL ( KIND = wp ), INTENT( IN ) :: Y0 + REAL ( KIND = wp ), INTENT( IN ) :: y0 REAL ( KIND = wp ), INTENT( IN ), DIMENSION( m ) :: Y REAL ( KIND = wp ), INTENT( OUT ), DIMENSION( lh ) :: H_val @@ -209,7 +209,7 @@ SUBROUTINE CUTEST_cshj_threadsafe( data, work, status, n, m, X, Y0, Y, & DO ig = 1, data%ng i = data%KNDOFC( ig ) IF ( i == 0 ) THEN - work%GSCALE_used( ig ) = data%GSCALE( ig ) * Y0 + work%GSCALE_used( ig ) = data%GSCALE( ig ) * y0 ELSE work%GSCALE_used( ig ) = data%GSCALE( ig ) * Y( i ) END IF diff --git a/src/tools/cutest.f90 b/src/tools/cutest.f90 index b92b719..26c4f35 100644 --- a/src/tools/cutest.f90 +++ b/src/tools/cutest.f90 @@ -162,6 +162,7 @@ MODULE CUTEST REAL :: time_cifn = 0.0 REAL :: time_cigr = 0.0 REAL :: time_cisgr = 0.0 + REAL :: time_cisgrp = 0.0 REAL :: time_cidh = 0.0 REAL :: time_cish = 0.0 REAL :: time_cjprod = 0.0 diff --git a/src/tools/makemaster b/src/tools/makemaster index 7e88b1b..91dabca 100644 --- a/src/tools/makemaster +++ b/src/tools/makemaster @@ -77,7 +77,8 @@ CCUTESTS = $(LCS)(csetup.o) $(LCS)(cdimen.o) $(LCS)(cdimse.o) $(LCS)(cdimsh.o) \ $(LCS)(cofsg.o) $(LCS)(ccfg.o) $(LCS)(clfg.o) $(LCS)(ccfsg.o) \ $(LCS)(ccifg.o) $(LCS)(ccifsg.o) $(LCS)(cdh.o) $(LCS)(cdhc.o) \ $(LCS)(ceh.o) $(LCS)(cgrdh.o) $(LCS)(cifn.o) $(LCS)(cigr.o) \ - $(LCS)(cisgr.o) $(LCS)(cidh.o) $(LCS)(csh.o) $(LCS)(cshc.o) \ + $(LCS)(cisgr.o) $(LCS)(cisgrp.o) \ + $(LCS)(cidh.o) $(LCS)(csh.o) $(LCS)(cshc.o) \ $(LCS)(cshj.o) $(LCS)(cshp.o) $(LCS)(cish.o) $(LCS)(cjprod.o) \ $(LCS)(cstats.o) $(LCS)(csgr.o) $(LCS)(csgreh.o) $(LCS)(csgrsh.o) \ $(LCS)(csjprod.o) $(LCS)(chprod.o) $(LCS)(chcprod.o) $(LCS)(csjp.o) \ @@ -104,7 +105,8 @@ CCUTESTD = $(LCD)(csetup.o) $(LCD)(cdimen.o) $(LCD)(cdimse.o) $(LCD)(cdimsh.o) \ $(LCD)(cofsg.o) $(LCD)(ccfg.o) $(LCD)(clfg.o) $(LCD)(ccfsg.o) \ $(LCD)(ccifg.o) $(LCD)(ccifsg.o) $(LCD)(cdh.o) $(LCD)(cdhc.o) \ $(LCD)(ceh.o) $(LCD)(cgrdh.o) $(LCD)(cifn.o) $(LCD)(cigr.o) \ - $(LCD)(cisgr.o) $(LCD)(cidh.o) $(LCD)(csh.o) $(LCD)(cshc.o) \ + $(LCD)(cisgr.o) $(LCD)(cisgrp.o) \ + $(LCD)(cidh.o) $(LCD)(csh.o) $(LCD)(cshc.o) \ $(LCD)(cshj.o) $(LCD)(cshp.o) $(LCD)(cish.o) $(LCD)(cjprod.o) \ $(LCD)(cstats.o) $(LCD)(csgr.o) $(LCD)(csgreh.o) $(LCD)(csgrsh.o) \ $(LCD)(csjprod.o) $(LCD)(chprod.o) $(LCD)(chcprod.o) \ @@ -218,6 +220,7 @@ $(LC)(cutest.o): ../tools/cutest.f90 $(RMARFILE) cifn.o $(RMARFILE) cigr.o $(RMARFILE) cisgr.o + $(RMARFILE) cisgrp.o $(RMARFILE) cidh.o $(RMARFILE) csh.o $(RMARFILE) cshc.o @@ -584,6 +587,18 @@ $(LC)(cisgr.o): ../tools/cisgr.f90 # $(MVMODS) @printf '[ OK ]\n' +cisgrp.o: $(LC)(cisgrp.o) + +$(LC)(cisgrp.o): ../tools/cisgrp.f90 + @printf ' %-9s %-15s\t\t' "Compiling" "cisgrp" + $(SED) -f $(SEDS) ../tools/cisgrp.f90 > $(OBJ)/cisgrp.f90 + cd $(OBJ); $(FORTRAN) -o cisgrp.o $(FFLAGS) cisgrp.f90 \ + || ( printf ' %-26s' "=> Disabling optimization " ; \ + $(FORTRAN) -o cisgrp.o $(FFLAGSN) cisgrp.f90 ) + cd $(OBJ); $(ARR) cisgrp.o; $(RM) cisgrp.f90 cisgrp.o +# $(MVMODS) + @printf '[ OK ]\n' + cidh.o: $(LC)(cidh.o) $(LC)(cidh.o): ../tools/cidh.f90 diff --git a/src/tools/timings.f90 b/src/tools/timings.f90 index 409df80..07012ee 100644 --- a/src/tools/timings.f90 +++ b/src/tools/timings.f90 @@ -151,6 +151,8 @@ SUBROUTINE CUTEST_timings_threadsafe( data, work, status, name, time ) time = work%time_cigr CASE ( 'cutest_cisgr' ) time = work%time_cisgr + CASE ( 'cutest_cisgrp' ) + time = work%time_cisgrp CASE ( 'cutest_cidh' ) time = work%time_cidh CASE ( 'cutest_cish' )