diff options
Diffstat (limited to 'modules/optimization/src')
294 files changed, 22482 insertions, 0 deletions
diff --git a/modules/optimization/src/c/.deps/.dirstamp b/modules/optimization/src/c/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/optimization/src/c/.deps/.dirstamp diff --git a/modules/optimization/src/c/.deps/libscioptimization_algo_la-fsolvetable.Plo b/modules/optimization/src/c/.deps/libscioptimization_algo_la-fsolvetable.Plo new file mode 100755 index 000000000..9aa639075 --- /dev/null +++ b/modules/optimization/src/c/.deps/libscioptimization_algo_la-fsolvetable.Plo @@ -0,0 +1,15 @@ +src/c/libscioptimization_algo_la-fsolvetable.lo: src/c/fsolvetable.c \ + /usr/include/stdc-predef.h \ + ../../modules/dynamic_link/includes/GetFunctionByName.h \ + ../../modules/dynamic_link/includes/dynlib_dynamic_link.h \ + ../../modules/core/includes/machine.h includes/dynlib_optimization.h + +/usr/include/stdc-predef.h: + +../../modules/dynamic_link/includes/GetFunctionByName.h: + +../../modules/dynamic_link/includes/dynlib_dynamic_link.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_optimization.h: diff --git a/modules/optimization/src/c/.deps/libscioptimization_algo_la-lsqrsolvtable.Plo b/modules/optimization/src/c/.deps/libscioptimization_algo_la-lsqrsolvtable.Plo new file mode 100755 index 000000000..308e2b6c4 --- /dev/null +++ b/modules/optimization/src/c/.deps/libscioptimization_algo_la-lsqrsolvtable.Plo @@ -0,0 +1,15 @@ +src/c/libscioptimization_algo_la-lsqrsolvtable.lo: src/c/lsqrsolvtable.c \ + /usr/include/stdc-predef.h \ + ../../modules/dynamic_link/includes/GetFunctionByName.h \ + ../../modules/dynamic_link/includes/dynlib_dynamic_link.h \ + ../../modules/core/includes/machine.h includes/dynlib_optimization.h + +/usr/include/stdc-predef.h: + +../../modules/dynamic_link/includes/GetFunctionByName.h: + +../../modules/dynamic_link/includes/dynlib_dynamic_link.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_optimization.h: diff --git a/modules/optimization/src/c/.deps/libscioptimization_algo_la-optimtable.Plo b/modules/optimization/src/c/.deps/libscioptimization_algo_la-optimtable.Plo new file mode 100755 index 000000000..840549ea9 --- /dev/null +++ b/modules/optimization/src/c/.deps/libscioptimization_algo_la-optimtable.Plo @@ -0,0 +1,15 @@ +src/c/libscioptimization_algo_la-optimtable.lo: src/c/optimtable.c \ + /usr/include/stdc-predef.h \ + ../../modules/dynamic_link/includes/GetFunctionByName.h \ + ../../modules/dynamic_link/includes/dynlib_dynamic_link.h \ + ../../modules/core/includes/machine.h includes/dynlib_optimization.h + +/usr/include/stdc-predef.h: + +../../modules/dynamic_link/includes/GetFunctionByName.h: + +../../modules/dynamic_link/includes/dynlib_dynamic_link.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_optimization.h: diff --git a/modules/optimization/src/c/.deps/libscioptimization_algo_la-sp.Plo b/modules/optimization/src/c/.deps/libscioptimization_algo_la-sp.Plo new file mode 100755 index 000000000..469b1ab42 --- /dev/null +++ b/modules/optimization/src/c/.deps/libscioptimization_algo_la-sp.Plo @@ -0,0 +1,212 @@ +src/c/libscioptimization_algo_la-sp.lo: src/c/sp.c \ + /usr/include/stdc-predef.h /usr/include/stdio.h /usr/include/features.h \ + /usr/include/x86_64-linux-gnu/sys/cdefs.h \ + /usr/include/x86_64-linux-gnu/bits/wordsize.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs.h \ + /usr/include/x86_64-linux-gnu/gnu/stubs-64.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h \ + /usr/include/x86_64-linux-gnu/bits/types.h \ + /usr/include/x86_64-linux-gnu/bits/typesizes.h /usr/include/libio.h \ + /usr/include/_G_config.h /usr/include/wchar.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h \ + /usr/include/x86_64-linux-gnu/bits/stdio_lim.h \ + /usr/include/x86_64-linux-gnu/bits/sys_errlist.h \ + /usr/include/x86_64-linux-gnu/bits/stdio.h \ + /usr/include/x86_64-linux-gnu/bits/stdio2.h /usr/include/math.h \ + /usr/include/x86_64-linux-gnu/bits/math-vector.h \ + /usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h \ + /usr/include/x86_64-linux-gnu/bits/huge_val.h \ + /usr/include/x86_64-linux-gnu/bits/huge_valf.h \ + /usr/include/x86_64-linux-gnu/bits/huge_vall.h \ + /usr/include/x86_64-linux-gnu/bits/inf.h \ + /usr/include/x86_64-linux-gnu/bits/nan.h \ + /usr/include/x86_64-linux-gnu/bits/mathdef.h \ + /usr/include/x86_64-linux-gnu/bits/mathcalls.h \ + /usr/include/x86_64-linux-gnu/bits/mathinline.h /usr/include/string.h \ + /usr/include/xlocale.h /usr/include/x86_64-linux-gnu/bits/string.h \ + /usr/include/x86_64-linux-gnu/bits/string2.h /usr/include/endian.h \ + /usr/include/x86_64-linux-gnu/bits/endian.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap.h \ + /usr/include/x86_64-linux-gnu/bits/byteswap-16.h /usr/include/stdlib.h \ + /usr/include/x86_64-linux-gnu/bits/string3.h includes/spd.h \ + ../../modules/core/includes/machine.h includes/dynlib_optimization.h \ + ../../modules/core/includes/core_math.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h \ + /usr/include/limits.h /usr/include/x86_64-linux-gnu/bits/posix1_lim.h \ + /usr/include/x86_64-linux-gnu/bits/local_lim.h \ + /usr/include/linux/limits.h \ + /usr/include/x86_64-linux-gnu/bits/posix2_lim.h \ + /usr/include/x86_64-linux-gnu/bits/waitflags.h \ + /usr/include/x86_64-linux-gnu/bits/waitstatus.h \ + /usr/include/x86_64-linux-gnu/sys/types.h /usr/include/time.h \ + /usr/include/x86_64-linux-gnu/sys/select.h \ + /usr/include/x86_64-linux-gnu/bits/select.h \ + /usr/include/x86_64-linux-gnu/bits/sigset.h \ + /usr/include/x86_64-linux-gnu/bits/time.h \ + /usr/include/x86_64-linux-gnu/bits/select2.h \ + /usr/include/x86_64-linux-gnu/sys/sysmacros.h \ + /usr/include/x86_64-linux-gnu/bits/pthreadtypes.h /usr/include/alloca.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib-float.h \ + /usr/include/x86_64-linux-gnu/bits/stdlib.h /usr/include/values.h \ + /usr/lib/gcc/x86_64-linux-gnu/5/include/float.h \ + ../../modules/output_stream/includes/sciprint.h \ + ../../modules/core/includes/BOOL.h \ + ../../modules/localization/includes/localization.h \ + /usr/include/libintl.h /usr/include/locale.h \ + /usr/include/x86_64-linux-gnu/bits/locale.h \ + ../../modules/core/includes/warningmode.h \ + ../../modules/core/includes/BOOL.h ../../modules/core/includes/machine.h + +/usr/include/stdc-predef.h: + +/usr/include/stdio.h: + +/usr/include/features.h: + +/usr/include/x86_64-linux-gnu/sys/cdefs.h: + +/usr/include/x86_64-linux-gnu/bits/wordsize.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs.h: + +/usr/include/x86_64-linux-gnu/gnu/stubs-64.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stddef.h: + +/usr/include/x86_64-linux-gnu/bits/types.h: + +/usr/include/x86_64-linux-gnu/bits/typesizes.h: + +/usr/include/libio.h: + +/usr/include/_G_config.h: + +/usr/include/wchar.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/stdarg.h: + +/usr/include/x86_64-linux-gnu/bits/stdio_lim.h: + +/usr/include/x86_64-linux-gnu/bits/sys_errlist.h: + +/usr/include/x86_64-linux-gnu/bits/stdio.h: + +/usr/include/x86_64-linux-gnu/bits/stdio2.h: + +/usr/include/math.h: + +/usr/include/x86_64-linux-gnu/bits/math-vector.h: + +/usr/include/x86_64-linux-gnu/bits/libm-simd-decl-stubs.h: + +/usr/include/x86_64-linux-gnu/bits/huge_val.h: + +/usr/include/x86_64-linux-gnu/bits/huge_valf.h: + +/usr/include/x86_64-linux-gnu/bits/huge_vall.h: + +/usr/include/x86_64-linux-gnu/bits/inf.h: + +/usr/include/x86_64-linux-gnu/bits/nan.h: + +/usr/include/x86_64-linux-gnu/bits/mathdef.h: + +/usr/include/x86_64-linux-gnu/bits/mathcalls.h: + +/usr/include/x86_64-linux-gnu/bits/mathinline.h: + +/usr/include/string.h: + +/usr/include/xlocale.h: + +/usr/include/x86_64-linux-gnu/bits/string.h: + +/usr/include/x86_64-linux-gnu/bits/string2.h: + +/usr/include/endian.h: + +/usr/include/x86_64-linux-gnu/bits/endian.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap.h: + +/usr/include/x86_64-linux-gnu/bits/byteswap-16.h: + +/usr/include/stdlib.h: + +/usr/include/x86_64-linux-gnu/bits/string3.h: + +includes/spd.h: + +../../modules/core/includes/machine.h: + +includes/dynlib_optimization.h: + +../../modules/core/includes/core_math.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/limits.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include-fixed/syslimits.h: + +/usr/include/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix1_lim.h: + +/usr/include/x86_64-linux-gnu/bits/local_lim.h: + +/usr/include/linux/limits.h: + +/usr/include/x86_64-linux-gnu/bits/posix2_lim.h: + +/usr/include/x86_64-linux-gnu/bits/waitflags.h: + +/usr/include/x86_64-linux-gnu/bits/waitstatus.h: + +/usr/include/x86_64-linux-gnu/sys/types.h: + +/usr/include/time.h: + +/usr/include/x86_64-linux-gnu/sys/select.h: + +/usr/include/x86_64-linux-gnu/bits/select.h: + +/usr/include/x86_64-linux-gnu/bits/sigset.h: + +/usr/include/x86_64-linux-gnu/bits/time.h: + +/usr/include/x86_64-linux-gnu/bits/select2.h: + +/usr/include/x86_64-linux-gnu/sys/sysmacros.h: + +/usr/include/x86_64-linux-gnu/bits/pthreadtypes.h: + +/usr/include/alloca.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-bsearch.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib-float.h: + +/usr/include/x86_64-linux-gnu/bits/stdlib.h: + +/usr/include/values.h: + +/usr/lib/gcc/x86_64-linux-gnu/5/include/float.h: + +../../modules/output_stream/includes/sciprint.h: + +../../modules/core/includes/BOOL.h: + +../../modules/localization/includes/localization.h: + +/usr/include/libintl.h: + +/usr/include/locale.h: + +/usr/include/x86_64-linux-gnu/bits/locale.h: + +../../modules/core/includes/warningmode.h: + +../../modules/core/includes/BOOL.h: + +../../modules/core/includes/machine.h: diff --git a/modules/optimization/src/c/.dirstamp b/modules/optimization/src/c/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/optimization/src/c/.dirstamp diff --git a/modules/optimization/src/c/.libs/libscioptimization_algo_la-fsolvetable.o b/modules/optimization/src/c/.libs/libscioptimization_algo_la-fsolvetable.o Binary files differnew file mode 100755 index 000000000..8b14cf9f0 --- /dev/null +++ b/modules/optimization/src/c/.libs/libscioptimization_algo_la-fsolvetable.o diff --git a/modules/optimization/src/c/.libs/libscioptimization_algo_la-lsqrsolvtable.o b/modules/optimization/src/c/.libs/libscioptimization_algo_la-lsqrsolvtable.o Binary files differnew file mode 100755 index 000000000..51cda3afb --- /dev/null +++ b/modules/optimization/src/c/.libs/libscioptimization_algo_la-lsqrsolvtable.o diff --git a/modules/optimization/src/c/.libs/libscioptimization_algo_la-optimtable.o b/modules/optimization/src/c/.libs/libscioptimization_algo_la-optimtable.o Binary files differnew file mode 100755 index 000000000..b8febc9a9 --- /dev/null +++ b/modules/optimization/src/c/.libs/libscioptimization_algo_la-optimtable.o diff --git a/modules/optimization/src/c/.libs/libscioptimization_algo_la-sp.o b/modules/optimization/src/c/.libs/libscioptimization_algo_la-sp.o Binary files differnew file mode 100755 index 000000000..35f83190d --- /dev/null +++ b/modules/optimization/src/c/.libs/libscioptimization_algo_la-sp.o diff --git a/modules/optimization/src/c/DllmainOptimization.c b/modules/optimization/src/c/DllmainOptimization.c new file mode 100755 index 000000000..89abc60a6 --- /dev/null +++ b/modules/optimization/src/c/DllmainOptimization.c @@ -0,0 +1,35 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) 2006 - INRIA - Allan CORNET + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ + +#include <windows.h> +/*--------------------------------------------------------------------------*/ +#pragma comment(lib,"../../../../bin/libintl.lib") +#pragma comment(lib,"../../../../bin/blasplus.lib") +#pragma comment(lib,"../../../../bin/lapack.lib") +/*--------------------------------------------------------------------------*/ +int WINAPI DllMain (HINSTANCE hInstance , DWORD reason, PVOID pvReserved) +{ + switch (reason) + { + case DLL_PROCESS_ATTACH: + break; + case DLL_PROCESS_DETACH: + break; + case DLL_THREAD_ATTACH: + break; + case DLL_THREAD_DETACH: + break; + } + return 1; +} +/*--------------------------------------------------------------------------*/ + diff --git a/modules/optimization/src/c/core_Import.def b/modules/optimization/src/c/core_Import.def new file mode 100755 index 000000000..79ccef23c --- /dev/null +++ b/modules/optimization/src/c/core_Import.def @@ -0,0 +1,23 @@ + LIBRARY core.dll + + +EXPORTS +;core +callFunctionFromGateway +com_ +putlhsvar_ +intersci_ +iop_ +check_length +check_scalar +stack_ +createvar_ +check_square +getrhsvar_ +checklhs_ +checkrhs_ +gettype_ +vstk_ +getWarningMode +MyHeapAlloc +MyHeapFree diff --git a/modules/optimization/src/c/fsolvetable.c b/modules/optimization/src/c/fsolvetable.c new file mode 100755 index 000000000..36aeaca20 --- /dev/null +++ b/modules/optimization/src/c/fsolvetable.c @@ -0,0 +1,88 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +#include "GetFunctionByName.h" +#include "machine.h" +#include "dynlib_optimization.h" +/*********************************** +* Search Table for fsolve +***********************************/ + +#define ARGS_fsolvf int*,double *,double*,int* +typedef void (*fsolvff)(ARGS_fsolvf); + +#define ARGS_fsolvj int*,double*,double*,int* +typedef void (*fsolvjf)(ARGS_fsolvj); + + +/**************** fsolvf ***************/ +extern void C2F(fsol1)(ARGS_fsolvf); +OPTIMIZATION_IMPEXP void C2F(fsolvf)(ARGS_fsolvf); +OPTIMIZATION_IMPEXP void C2F(setfsolvf)(char *name, int *rep); + +FTAB FTab_fsolvf[] = +{ + {"fsol1", (voidf) C2F(fsol1)}, + {(char *) 0, (voidf) 0} +}; +/**************** fsolvj ***************/ +extern void C2F(fsolj1)(ARGS_fsolvj); +OPTIMIZATION_IMPEXP void C2F(fsolvj)(ARGS_fsolvj); +OPTIMIZATION_IMPEXP void C2F(setfsolj)(char *name, int *rep); +OPTIMIZATION_IMPEXP void C2F(setfsolvj)(char *name, int *rep); + +FTAB FTab_fsolvj[] = +{ + {"fsolj1", (voidf) C2F(fsolj1)}, + {(char *) 0, (voidf) 0} +}; + +/*********************************** +* Search Table for fsolve +* uses : fsolvf and fsolvj +***********************************/ + +/** the current function fixed by setsolvf **/ + +static fsolvff fsolvffonc ; + +/** function call : fsolvf **/ + +void C2F(fsolvf)(int *n, double *x, double *fvec, int *iflag) +{ + (*fsolvffonc)(n, x, fvec, iflag); +} + +/** fixes the function associated to name **/ + +void C2F(setfsolvf)(char *name, int *rep) +{ + fsolvffonc = (fsolvff) GetFunctionByName(name, rep, FTab_fsolvf); +} + +/** the current function fixed by setfsolvj **/ + +static fsolvjf fsolvjfonc ; + +/** function call **/ + +void C2F(fsolvj)(int *n, double *x, double *fjac, int *iflag) +{ + (*fsolvjfonc)(n, x, fjac, iflag); +} + +/** fixes the function associated to name **/ + +void C2F(setfsolvj)(char *name, int *rep) +{ + fsolvjfonc = (fsolvjf) GetFunctionByName(name, rep, FTab_fsolvj); +} diff --git a/modules/optimization/src/c/libscioptimization_algo_la-fsolvetable.lo b/modules/optimization/src/c/libscioptimization_algo_la-fsolvetable.lo new file mode 100755 index 000000000..de5542d9a --- /dev/null +++ b/modules/optimization/src/c/libscioptimization_algo_la-fsolvetable.lo @@ -0,0 +1,12 @@ +# src/c/libscioptimization_algo_la-fsolvetable.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscioptimization_algo_la-fsolvetable.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/c/libscioptimization_algo_la-lsqrsolvtable.lo b/modules/optimization/src/c/libscioptimization_algo_la-lsqrsolvtable.lo new file mode 100755 index 000000000..8cedec901 --- /dev/null +++ b/modules/optimization/src/c/libscioptimization_algo_la-lsqrsolvtable.lo @@ -0,0 +1,12 @@ +# src/c/libscioptimization_algo_la-lsqrsolvtable.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscioptimization_algo_la-lsqrsolvtable.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/c/libscioptimization_algo_la-optimtable.lo b/modules/optimization/src/c/libscioptimization_algo_la-optimtable.lo new file mode 100755 index 000000000..4d57e571d --- /dev/null +++ b/modules/optimization/src/c/libscioptimization_algo_la-optimtable.lo @@ -0,0 +1,12 @@ +# src/c/libscioptimization_algo_la-optimtable.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscioptimization_algo_la-optimtable.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/c/libscioptimization_algo_la-sp.lo b/modules/optimization/src/c/libscioptimization_algo_la-sp.lo new file mode 100755 index 000000000..1a2892e27 --- /dev/null +++ b/modules/optimization/src/c/libscioptimization_algo_la-sp.lo @@ -0,0 +1,12 @@ +# src/c/libscioptimization_algo_la-sp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/libscioptimization_algo_la-sp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/c/lsqrsolvtable.c b/modules/optimization/src/c/lsqrsolvtable.c new file mode 100755 index 000000000..8f3068bdb --- /dev/null +++ b/modules/optimization/src/c/lsqrsolvtable.c @@ -0,0 +1,87 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +#include "GetFunctionByName.h" +#include "machine.h" +#include "dynlib_optimization.h" +/*********************************** +* Search Table for lsqrsolve +***********************************/ + +#define ARGS_lsqrsolvf int*,int*,double *,double*,int* +typedef void (*lsqrsolvff)(ARGS_lsqrsolvf); + +#define ARGS_lsqrsolvj int*,int*,double*,double*,int*,int* +typedef void (*lsqrsolvjf)(ARGS_lsqrsolvj); + +/**************** lsqrsolvf ***************/ +extern void C2F(lsqrsol1)(ARGS_lsqrsolvf); +OPTIMIZATION_IMPEXP void C2F(lsqrsolvf)(ARGS_lsqrsolvf); +OPTIMIZATION_IMPEXP void C2F(setlsqrsolvf)(char *name, int *rep); + + +FTAB FTab_lsqrsolvf[] = +{ + {"lsqrsol1", (voidf) C2F(lsqrsol1)}, + {(char *) 0, (voidf) 0} +}; +/**************** lsqrsolvj ***************/ +extern void C2F(lsqrsolj1)(ARGS_lsqrsolvj); +OPTIMIZATION_IMPEXP void C2F(lsqrsolvj)(ARGS_lsqrsolvj); +OPTIMIZATION_IMPEXP void C2F(setlsqrsolvj)(char *name, int *rep); + +FTAB FTab_lsqrsolvj[] = +{ + {"lsqrsolj1", (voidf) C2F(lsqrsolj1)}, + {(char *) 0, (voidf) 0} +}; + +/*********************************** +* Search Table for fsolve +* uses : lsqrsolvf and lsqrsolvj +***********************************/ + +/** the current function fixed by setsolvf **/ + +static lsqrsolvff lsqrsolvffonc ; + +/** function call : lsqrsolvf **/ + +void C2F(lsqrsolvf)(int *m, int *n, double *x, double *fvec, int *iflag) +{ + (*lsqrsolvffonc)(m, n, x, fvec, iflag); +} + +/** fixes the function associated to name **/ + +void C2F(setlsqrsolvf)(char *name, int *rep) +{ + lsqrsolvffonc = (lsqrsolvff) GetFunctionByName(name, rep, FTab_lsqrsolvf); +} + +/** the current function fixed by setfsolvj **/ + +static lsqrsolvjf lsqrsolvjfonc ; + +/** function call **/ + +void C2F(lsqrsolvj)(int *m, int *n, double *x, double *fjac, int *ldfjac, int *iflag) +{ + (*lsqrsolvjfonc)(m, n, x, fjac, ldfjac, iflag); +} + +/** fixes the function associated to name **/ + +void C2F(setlsqrsolvj)(char *name, int *rep) +{ + lsqrsolvjfonc = (lsqrsolvjf) GetFunctionByName(name, rep, FTab_lsqrsolvj); +} diff --git a/modules/optimization/src/c/optimization.rc b/modules/optimization/src/c/optimization.rc new file mode 100755 index 000000000..b9e6a766f --- /dev/null +++ b/modules/optimization/src/c/optimization.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "optimization module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "optimization module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "optimization.dll" + VALUE "ProductName", "optimization module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/optimization/src/c/optimization.vcxproj b/modules/optimization/src/c/optimization.vcxproj new file mode 100755 index 000000000..9bdaa2409 --- /dev/null +++ b/modules/optimization/src/c/optimization.vcxproj @@ -0,0 +1,252 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectGuid>{425B887B-9FC5-4CD2-B632-DBFC000E3E25}</ProjectGuid> + <RootNamespace>optimization</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <WholeProgramOptimization>false</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <WholeProgramOptimization>false</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>MultiByte</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../includes;../../../dynamic_link/includes;../../../output_stream/includes;../../../localization/includes;../../../core/includes;../../../../libs/intl;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;_DEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>sparse_f.lib;core.lib;optimization_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../includes;../../../dynamic_link/includes;../../../output_stream/includes;../../../localization/includes;../../../core/includes;../../../../libs/intl;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;_DEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>sparse_f.lib;core.lib;optimization_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../includes;../../../dynamic_link/includes;../../../output_stream/includes;../../../localization/includes;../../../core/includes;../../../../libs/intl;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;NDEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <StringPooling>true</StringPooling> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>sparse_f.lib;core.lib;optimization_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>false</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <FavorSizeOrSpeed>Speed</FavorSizeOrSpeed> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../includes;../../../dynamic_link/includes;../../../output_stream/includes;../../../localization/includes;../../../core/includes;../../../../libs/intl;../../../api_scilab/includes;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>_CRT_SECURE_NO_DEPRECATE;FORDLL;NDEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_EXPORTS;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <StringPooling>true</StringPooling> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Make dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)sparse_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)sparse_f.lib" 1>NUL 2>NUL</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>sparse_f.lib;core.lib;optimization_f.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <GenerateDebugInformation>false</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="DllmainOptimization.c" /> + <ClCompile Include="fsolvetable.c" /> + <ClCompile Include="..\..\sci_gateway\c\gw_optimization.c" /> + <ClCompile Include="lsqrsolvtable.c" /> + <ClCompile Include="optimtable.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_fsolv.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_optim.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_qld.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_qp_solve.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_readmps.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_semidef.c" /> + <ClCompile Include="..\..\sci_gateway\c\sci_sqrsolve.c" /> + <ClCompile Include="sp.c" /> + </ItemGroup> + <ItemGroup> + <ClInclude Include="..\..\includes\dynlib_optimization.h" /> + <ClInclude Include="..\..\includes\gw_optimization.h" /> + <ClInclude Include="..\..\includes\spd.h" /> + </ItemGroup> + <ItemGroup> + <None Include="..\..\locales\optimization.pot" /> + <None Include="core_import.def" /> + <None Include="optimization_f_Import.def" /> + <None Include="..\..\Makefile.am" /> + <None Include="..\..\optimization.iss" /> + <None Include="..\..\sci_gateway\optimization_gateway.xml" /> + <None Include="sparse_f_Import.def" /> + </ItemGroup> + <ItemGroup> + <ResourceCompile Include="optimization.rc" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + <ProjectReference Include="..\..\..\api_scilab\api_scilab.vcxproj"> + <Project>{43c5bab1-1dca-4743-a183-77e0d42fe7d0}</Project> + </ProjectReference> + <ProjectReference Include="..\..\..\dynamic_link\src\c\dynamic_link.vcxproj"> + <Project>{eab6c580-22b3-4359-ba1d-dd7499a96163}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + <ProjectReference Include="..\..\..\localization\src\localization.vcxproj"> + <Project>{ecffeb0c-1eda-45ee-9a10-b18143852e17}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + <ProjectReference Include="..\..\..\output_stream\src\c\output_stream.vcxproj"> + <Project>{a5911cd7-f8e8-440c-a23e-4843a0636f3a}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/optimization/src/c/optimization.vcxproj.filters b/modules/optimization/src/c/optimization.vcxproj.filters new file mode 100755 index 000000000..910192595 --- /dev/null +++ b/modules/optimization/src/c/optimization.vcxproj.filters @@ -0,0 +1,99 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{ae4b7045-0d5f-41eb-b509-7a3eec4e865c}</UniqueIdentifier> + <Extensions>cpp;c;cxx;rc;def;r;odl;idl;hpj;bat</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{b84f72dd-818e-4247-a9de-140234f3c003}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl</Extensions> + </Filter> + <Filter Include="localization"> + <UniqueIdentifier>{8f475a84-ec76-4509-ab3b-ba8f3440a3c5}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{b0049a8b-6a0c-4b3e-8eca-3dbce3979765}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies\Imports"> + <UniqueIdentifier>{453e0080-87c3-4f4b-98cc-ff5b35e6f5b2}</UniqueIdentifier> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{af72edc2-8ff5-492c-a180-26b3e81c8fd2}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="DllmainOptimization.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fsolvetable.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\gw_optimization.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="lsqrsolvtable.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="optimtable.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_fsolv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_optim.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_qld.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_qp_solve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_readmps.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_semidef.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\c\sci_sqrsolve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="sp.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <ClInclude Include="..\..\includes\dynlib_optimization.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\gw_optimization.h"> + <Filter>Header Files</Filter> + </ClInclude> + <ClInclude Include="..\..\includes\spd.h"> + <Filter>Header Files</Filter> + </ClInclude> + </ItemGroup> + <ItemGroup> + <None Include="core_import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="optimization_f_Import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + <None Include="..\..\Makefile.am" /> + <None Include="..\..\optimization.iss" /> + <None Include="..\..\sci_gateway\optimization_gateway.xml" /> + <None Include="..\..\locales\optimization.pot"> + <Filter>localization</Filter> + </None> + <None Include="sparse_f_Import.def"> + <Filter>Libraries Dependencies\Imports</Filter> + </None> + </ItemGroup> + <ItemGroup> + <ResourceCompile Include="optimization.rc"> + <Filter>Resource Files</Filter> + </ResourceCompile> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/optimization/src/c/optimization_f_Import.def b/modules/optimization/src/c/optimization_f_Import.def new file mode 100755 index 000000000..b54bbd04e --- /dev/null +++ b/modules/optimization/src/c/optimization_f_Import.def @@ -0,0 +1,22 @@ +LIBRARY optimization_f.dll + + +EXPORTS +; --------------------------------------- +; optimization_f +; --------------------------------------- +fsolj1_ +fsol1_ +ql0001_ +lsqrsolj1_ +lsqrsol1_ +topt2_ +icsemc_ +genros_ +scisolv_ +scioptim_ +qpgen1sci_ +qpgen2_ +scisemidef_ +intlsqrsolve_ +intreadmps_
\ No newline at end of file diff --git a/modules/optimization/src/c/optimtable.c b/modules/optimization/src/c/optimtable.c new file mode 100755 index 000000000..76d650909 --- /dev/null +++ b/modules/optimization/src/c/optimtable.c @@ -0,0 +1,59 @@ +/* + * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab + * Copyright (C) INRIA + * + * This file must be used under the terms of the CeCILL. + * This source file is licensed as described in the file COPYING, which + * you should have received as part of this distribution. The terms + * are also available at + * http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + * + */ +/*--------------------------------------------------------------------------*/ +#include "GetFunctionByName.h" +#include "machine.h" +#include "dynlib_optimization.h" +/*********************************** +* Search Table for foptim +***********************************/ +#define ARGS_foptim int*,int*,double *,double*,double*,int*,float*,double* +typedef void (*foptimf)(ARGS_foptim); + +/**************** foptim ***************/ +extern void C2F(genros)(ARGS_foptim); +extern void C2F(topt2)(ARGS_foptim); +extern void C2F(icsemc)(ARGS_foptim); + +OPTIMIZATION_IMPEXP void C2F(foptim)(ARGS_foptim); +OPTIMIZATION_IMPEXP void C2F(setfoptim)(char *name, int *rep); + +FTAB FTab_foptim[] = +{ + {"genros", (voidf) C2F(genros)}, + {"icsemc", (voidf) C2F(icsemc)}, + {"topt2", (voidf) C2F(topt2)}, + {(char *) 0, (voidf) 0} +}; +/*********************************** +* Search Table for optim +* uses : foptim +***********************************/ + +/** the current function fixed by setsolvf **/ + +static foptimf foptimfonc ; + +/** function call : foptim **/ + +void C2F(foptim)(int *indsim, int *n, double *x, double *f, double *g, int *izs, float *rzs, double *dzs) +{ + (*foptimfonc)(indsim, n, x, f, g, izs, rzs, dzs); +} + +/** fixes the function associated to name **/ + +void C2F(setfoptim)(char *name, int *rep) +{ + foptimfonc = (foptimf) GetFunctionByName(name, rep, FTab_foptim); +} + diff --git a/modules/optimization/src/c/sp.c b/modules/optimization/src/c/sp.c new file mode 100755 index 000000000..03cb98d6d --- /dev/null +++ b/modules/optimization/src/c/sp.c @@ -0,0 +1,949 @@ +/* + * Copyright (c) 1994 by Lieven Vandenberghe and Stephen Boyd. + * Permission to use, copy, modify, and distribute this software for + * any purpose without fee is hereby granted, provided that this entire + * notice is included in all copies of any software which is or includes + * a copy or modification of this software and in all copies of the + * supporting documentation for such software. + * This software is being provided "as is", without any express or + * implied warranty. In particular, the authors do not make any + * representation or warranty of any kind concerning the merchantability + * of this software or its fitness for any particular purpose. + */ +/*--------------------------------------------------------------------------*/ +#include <stdio.h> +#include <math.h> +#include <string.h> +#include "spd.h" +#include "sciprint.h" +#include "localization.h" +#include "warningmode.h" +/*--------------------------------------------------------------------------*/ +/* BLAS 1 */ +extern double F2C(dnrm2)( ); +extern double F2C(ddot)( ); +extern void F2C(dcopy)( ); +extern void F2C(daxpy)( ); +extern void F2C(dscal)( ); + +/* BLAS 2 */ +extern void F2C(dgemv)( ); +extern void F2C(dspmv)( ); + +/* BLAS 3 */ +extern void F2C(dgemm)( ); + +/* LAPACK */ +extern void F2C(dgels)( ); +extern void F2C(dspgst)( ); +extern void F2C(dspev)( ); +extern void F2C(dspgv)( ); +extern void F2C(dtrcon)( ); +extern double F2C(dlamch)( ); +/*--------------------------------------------------------------------------*/ +/* + * if itype = 1, computes C = B*A*B', otherwise, computes C = B'*A*B + * A and B are nxn with A symmetric. + * + * Arguments: + * @param itype = 1: compute C = B*A*B' + * = any other integer: computes C = B'*A*B + * @param n dimension of A and B + * @param AP (input) double array of size n*(n+1)2; + * the lower triangle of A in packed storage + * @param B (input) double array of size n*n; + * @param CP (output) double array of size n*(n+1)/2; + * the lower triangle of C in packed storage + * @param temp: n-array, workspace + */ +/*--------------------------------------------------------------------------*/ +static void cngrncb(int itype, int n, double *AP, double *B, double *CP, double *temp) +{ + + int j, pos, lngth = n * (n + 1) / 2; + int int1 = 1; + double dbl0 = 0.0, dbl1 = 1.0; + + /* C := 0 */ + F2C(dscal)(&lngth, &dbl0, CP, &int1); + + if (itype == 1) + { + + for (j = 0, pos = 0; j < n; pos += n - j, j++) + { + + /* temp = A*B(j,:)' */ + F2C(dspmv)("L", &n, &dbl1, AP, B + j, &n, &dbl0, temp, &int1); + + /* C(j:n,j) = B(j:n,:)*temp */ + lngth = n - j; + F2C(dgemv)("N", &lngth, &n, &dbl1, B + j, &n, temp, &int1, &dbl0, + CP + pos, &int1); + + } + + } + else + { + + for (j = 0, pos = 0; j < n; pos += n - j, j++) + { + + /* temp = A*B(:,j) */ + F2C(dspmv)("L", &n, &dbl1, AP, B + j * n, &int1, &dbl0, temp, &int1); + + /* C(j:n,j) = B(:,j:n)'*temp */ + lngth = n - j; + F2C(dgemv)("T", &n, &lngth, &dbl1, B + j * n, &n, temp, &int1, &dbl0, + CP + pos, &int1); + + } + } + +} +/*--------------------------------------------------------------------------*/ +static double inprd(double *X, double *Z, int L, int *blck_szs) +/* + * Computes Tr X*Z + * + * Arguments: + * X,Z: block diagonal matrices with L blocks X^0, ..., X^{L-1}, + * and Z^0, ..., Z^{L-1}. X^j and Z^j have size + * blck_szs[j] times blck_szs[j]. Every block is stored + * using packed storage of the lower triangle. + * L: number of blocks + * blck_szs: int vector of length L + * blck_szs[i], i=0,...,L-1 is the size of block i + * + */ + +{ + double result; + int i, j, k, lngth, pos, sz, int1 = 1; + + /* sz = length of Z and X */ + for (i = 0, sz = 0; i < L; i++) + { + sz += (blck_szs[i] * (blck_szs[i] + 1)) / 2; + } + + /* result = Tr X Z + contributions of diagonal elements */ + result = 2.0 * F2C(ddot)(&sz, X, &int1, Z, &int1); + + /* correct for diagonal elements + * loop over blocks, j=0,...,L-1 */ + for (j = 0, pos = 0; j < L; j++) + + /* loop over columns, k=0,...,blck_szs[j]-1 + * pos is position of (k,k) element of block j + * lngth is length of column k */ + for (k = 0, lngth = blck_szs[j]; k < blck_szs[j]; pos += lngth, + lngth -= 1, k++) + + /* subtract Z^j_{kk}*X^j_{kk} from result */ + { + result -= Z[pos] * X[pos]; + } + + return result; +} +/*--------------------------------------------------------------------------*/ +int C2F(spf)( + int *m, /* no of variables */ + int *L, /* no of blocks in F */ + double *F, /* F_i's in packed storage */ + int *blck_szs, /* L-vector, dimensions of diagonal blocks */ + double *c, /* m-vector */ + double *x, /* m-vector */ + double *Z, /* block diagonal matrix in packed storage */ + double *ul, /* ul[0] = pr. obj, ul[1] = du. obj */ + double *nu, /* >= 1.0 */ + double *abstol, /* absolute accuracy */ + double *reltol, /* relative accuracy */ + double *tv, /* target value */ + int *iters, /* on entry: the maximum number of iterations, + * on exit: the number of iterations taken */ + double *work, /* work array */ + int *lwork, /* size of work */ + int *iwork, /* work array of m integers */ + int *info /* status on termination */ +) +{ + return(sp(*m, *L, F, blck_szs, c, x, Z, ul, *nu, *abstol, *reltol, *tv, iters, work, + *lwork, iwork, info)); +} +/*--------------------------------------------------------------------------*/ +int sp( + int m, /* no of variables */ + int L, /* no of blocks in F */ + double *F, /* F_i's in packed storage */ + int *blck_szs, /* L-vector, dimensions of diagonal blocks */ + double *c, /* m-vector */ + double *x, /* m-vector */ + double *Z, /* block diagonal matrix in packed storage */ + double *ul, /* ul[0] = pr. obj, ul[1] = du. obj */ + double nu, /* >= 1.0 */ + double abstol, /* absolute accuracy */ + double reltol, /* relative accuracy */ + double tv, /* target value */ + int *iters, /* on entry: the maximum number of iterations, + * on exit: the number of iterations taken */ + double *work, /* work array */ + int lwork, /* size of work */ + int *iwork, /* work array of m integers */ + int *info /* status on termination */ +) +/* + * Solves semidefinite program + * + * minimize c'*x + * subject to F_0 + x_1*F_1 + ... + x_m*F_m >= 0 + * + * and its dual + * + * maximize -Tr F_0*Z + * subject to Z >= 0 + * Tr F_i*Z = c_i, i=1,...,m + * + * + * Convergence criteria: + * (1) maxiters is exceeded + * (2) duality gap is less than abstol + * (3) primal and dual objective are both positive and + * duality gap is less than reltol * dual objective + * or primal and dual objective are both negative and + * duality gap is less than reltol * minus the primal objective + * (4) reltol is negative and primal objective is less than tv + * (5) reltol is negative and dual objective is greater than tv + * + * Arguments: + * - m: number of variables x_i. m >= 1. + * - L: number of diagonal blocks in F_i. L >= 1. + * - F: the block diagonal matrices F_i, i=0,...,m. + * it is assumed that the matrices F_i are linearly + * independent. + * let F_i^j, i=0,..,m, j=0,...,L-1 denote the jth + * diagonal block of F_i, + * the array F contains F_0^0, ..., F_0^{L-1}, F_1^0, ..., + * F_1^{L-1}, ..., F_m^0, ..., F_m^{L-1}, in this order, + * using packed storage for the lower triangular part of + * F_i^j. + * - blck_szs: an int L-vector. blck_szs[j], j=0,....L-1 gives the + * size of block j, ie, F_i^j has size blck_szs[j] + * times blck_szs[j]. + * - c: m-vector, primal objective. + * - x: m-vector. On entry, a strictly primal feasible point. + * On exit, the last iterate for x. + * - Z: block diagonal matrix with L blocks Z^0, ..., Z^{L-1}. + * Z^j has size blck_szs[j] times blck_szs[j]. + * Every block is stored using packed storage of the lower + * triangular part. + * On entry, a strictly dual feasible point. On exit, the + * last dual iterate. + * - ul: two-vector. On exit, ul[0] is the primal objective value + * c'*x; ul[1] is the dual objective value -Tr F_0*Z. + * - nu: >= 1.0. Controls the rate of convergence. + * - abstol: absolute tolerance, >= MINABSTOL. + * - reltol: relative tolerance. Has a special meaning when negative. + * - tv: target value, only referenced if reltol < 0. + * - iters: on entry: maximum number of iterations >= 0, + * on exit: the number of iterations taken. + * - work: work array of size lwork. + * - lwork: size of work, must be at least: + * (m+2)*sz + up_sz + 2*n + ltemp, with + * ltemp = max( m+sz*nb, 3max_n + max_n*(max_n+1), 3*m ) + * (sz: space needed to store one matrix F_i in packed + * storage, ie, + * sum_{j=0}^{L-1} blck_szs[j]*(blck_szs[j]+1)/2; + * up_sz: space needed to store one matrix F_i in + * unpacked storage, ie, + * sum_{j=0}^{L-1} blck_szs[j]*blck_szs[j]; + * max_n: max block size; + * n: sum of the block sizes. + * nb >= 1, for best performance, nb should be at least + * equal to the optimal block size for dgels. + * - iwork: work array of m integers + * - info: returns 1 if maxiters exceeded, 2 if absolute accuracy + * is reached, 3 if relative accuracy is reached, + * 4 if target value is reached, 5 if target value is + * not achievable; + * negative values indicate errors: -i means argument i + * has an illegal value, -18 stands for all other errors. + * + * + * Returns 0 for normal exit, 1 if an error occurred. + * + */ + + +{ + int i, j, k, n, sz, up_sz, max_n, lngth, pos, pos2, pos3, pos4, ltemp, + maxiters, info2, minlwork; + double q, *rhs, *Fsc, *R, *X, rho, *dx, *sigx, *sigz, *dZ, *temp, scal, + scal2, XdZ, ZdX, alphax, alphaz, lambda_ls, gradx, hessx, + gradz, hessz, dalphax, dalphaz, gap, newgap = 0.0, newu = 0.0, + newl = 0.0, maxpossigx, minnegsigx, maxpossigz, minnegsigz, nrmc, + nrmx, nrmz, nrmmax, rcond; + int int2 = 2, int1 = 1; + double dbl1 = 1.0, dbl0 = 0.0, sqrt2 = sqrt(2.0); + double dbl_epsilon; + + if (m < 1) + { + if ( getWarningMode() ) + { + sciprint(_("m must be at least one.\n")); + } + *info = -1; + return 1; + } + if (L < 1) + { + if ( getWarningMode() ) + { + sciprint(_("L must be at least one.\n")); + } + *info = -2; + return 1; + } + for (i = 0; i < L; i++) if (blck_szs[i] < 1) + { + if ( getWarningMode() ) + { + sciprint(_("blck_szs[%d] must be at least one.\n"), i); + } + *info = -4; + return 1; + } + if (nu < 1.0) + { + if ( getWarningMode() ) + { + sciprint(_("nu must be at least 1.0.\n")); + } + *info = -9; + return 1; + } + + + /* + * calculate dimensions: + * n: total size of semidefinite program + * sz: length of one block-diagonal matrix in packed storage + * up_sz: length of one block-diagonal matrix in unpacked storage + * max_n: size of biggest block + */ + + for (i = 0, n = 0, sz = 0, up_sz = 0, max_n = 0; i < L; i++) + { + n += blck_szs[i]; + sz += blck_szs[i] * (blck_szs[i] + 1) / 2; + up_sz += blck_szs[i] * blck_szs[i]; + max_n = Max(max_n, blck_szs[i]); + } + if (m > sz) + { + sciprint(_("Matrices Fi, i=1,...,m are linearly dependent.\n")); + *info = -3; + return 1; + } + + q = (double)n + nu * sqrt((double)n); + + + /* + * check if Tr Fi*Z = c_i, i=1,...,m + */ + + nrmc = F2C(dnrm2)(&m, c, &int1); + for (i = 0; i < m; i++) + if (fabs(inprd(F + (i + 1)*sz, Z, L, blck_szs) - c[i]) > nrmc * TOLC) + { + if ( getWarningMode() ) + { + sciprint(_("Z0 does not satisfy equality conditions for dual feasibility.\n")); + } + + *info = -7; + return 1; + } + + + /* + * organize workspace + * + * work: (m+2)*sz + up_sz + 2*n + ltemp + * minimum ltemp: the maximum of + * m+sz*nb, 3*max_n + max_n*(max_n+1), and 3*m + * (nb is at least one) + * + * for dgels: m + sz*nb, nb at least 1 + * for dspev("N"): 3*max_n + max_n*(max_n+1) + * for dspgv("N"): 3*max_n + max_n*(max_n+1) + * for dspgv("V"): 3*max_n + max_n*(max_n+1)/2 + * for cngrncb: max_n + * for dtrcon: 3*m + * + * rhs (sz): work[0 ... sz-1] + * Fsc (m*sz): work[sz ... (m+1)*sz-1] + * R (up_sz): work[(m+1)*sz ... (m+1)*sz+up_sz-1] + * X (sz): work[(m+1)*sz+up_sz ... (m+2)*sz+up_sz-1] + * sigx (n): work[(m+2)*sz+up_sz ... (m+2)*sz+up_sz+n-1] + * sigz (n): work[(m+2)*sz+up_sz+n ... (m+2)*sz+up_sz+2*n-1] + * temp (remainder): work[(m+2)*sz+up_sz+2*n ... lwork-1] + */ + + /* check lwork */ + minlwork = (m + 2) * sz + up_sz + 2 * n + + Max( Max( m + sz, 3 * max_n + max_n * (max_n + 1) ), 3 * m ); + if (lwork < minlwork) + { + if ( getWarningMode() ) + { + sciprint(_("Work space is too small. Need at least %d*sizeof(double).\n"), minlwork); + } + *info = -15; + return 1; + } + + rhs = work; /* rhs for ls problem */ + dx = work; /* solution of ls system; overlaps with rhs */ + Fsc = rhs + sz; /* scaled matrices */ + dZ = rhs + sz; /* overlaps with first column of Fsc */ + R = Fsc + m * sz; /* eigenvectors of Z*F */ + X = R + up_sz; /* F(x) */ + sigx = X + sz; /* generalized eigenvalues of (dX,X) */ + sigz = sigx + n; /* generalized eigenvalues of (dZ,Z) */ + temp = sigz + n; + ltemp = lwork - (m + 2) * sz - up_sz - 2 * n; + + + maxiters = (*iters >= 0) ? *iters : MAXITERS; + for (*iters = 0; *iters <= maxiters; (*iters)++) + { + + + /* compute F(x) = F_0 + x_1*F_1 + ... + x_m*F_m, store in X */ + F2C(dcopy)(&sz, F, &int1, X, &int1); + F2C(dgemv)("N", &sz, &m, &dbl1, F + sz, &sz, x, &int1, &dbl1, X, &int1); + + + /* + * compute generalized eigendecomp Z*F*x = lambda*x + * loop over blocks, i=0,...,L-1 + * pos: position of (0,0) element of block i in packed storage + * pos2: position of (0,0) element of block i in unpacked + * storage + * pos3: position of first eigenvalue of block i in sigx + */ + + for (i = 0, pos = 0, pos2 = 0, pos3 = 0, gap = 0.0; i < L; + pos += blck_szs[i] * (blck_szs[i] + 1) / 2, + pos2 += blck_szs[i] * blck_szs[i], + pos3 += blck_szs[i], i++) + { + + lngth = blck_szs[i] * (blck_szs[i] + 1) / 2; + + /* copy block i of Z in temp (need max_n*(max_n+1)/2) */ + F2C(dcopy)(&lngth, Z + pos, &int1, temp, &int1); + + /* generalized eigenvalue decomposition Z*F*x = lambda*x + * - eigenvectors V are normalized s.t. V^T*F*V = I + * - store block i of V in R+pos2 + * - store eigenvalues of block i in sigx+pos3 + * - dspgv replaces X+pos by cholesky factor L of ith + * block of F (F = L*L^T) + * use temp+lngth as workspace (need at least 3*max_n) */ + F2C(dspgv)(&int2, "V", "L", blck_szs + i, temp, X + pos, sigx + pos3, + R + pos2, blck_szs + i, temp + lngth, &info2); + if (info2) + { + if ( getWarningMode() ) + { + sciprint(_("Error in dspgv, info = %d.\n"), info2); + } + if (*iters == 0 && info2 > blck_szs[i]) + { + if ( getWarningMode() ) + { + sciprint( _("x0 is not strictly primal feasible.\n")); + } + *info = -6; + } + else + { + *info = -18; + } + return 1; + } + + /* - replace sigx+pos3 by lambda^(1/2) + * - normalize block i of V (stored in R+pos2) s.t. + * V^T*F*V = Lambda^(1/2) */ + for (k = 0; k < blck_szs[i]; k++) + { + scal = sigx[pos3 + k]; + if (scal < 0.0) + { + if (*iters == 0) + { + if ( getWarningMode() ) + { + sciprint(_("Z0 is not positive definite.\n")); + } + *info = 7; + } + else + { + if ( getWarningMode() ) + { + sciprint(_("F(x)*Z has a negative eigenvalue.\n")); + } + *info = -18; + } + return 1; + } + gap += scal; /* duality gap is sum of eigenvalues of ZF */ + scal2 = sqrt(scal); + scal = sqrt(scal2); + sigx[pos3 + k] = scal2; + F2C(dscal)(blck_szs + i, &scal, R + pos2 + k * blck_szs[i], &int1); + } + + } + + + /* + * check convergence + */ + + ul[1] = -inprd(F, Z, L, blck_szs); /* -Tr F_0 Z */ + ul[0] = F2C(ddot)(&m, c, &int1, x, &int1); /* c^T x */ + if (*iters == 0) + { + if ( getWarningMode() ) + { + sciprint(_("\n primal obj. dual obj. dual. gap \n")); + } + + } + if ( getWarningMode() ) + { + sciprint("% 13.2e % 12.2e %10.2e\n", ul[0], ul[1], gap); + } + if (gap <= Max(abstol, MINABSTOL)) + { + *info = 2; + } + else if ( (ul[1] > 0.0 && gap <= reltol * ul[1]) || + (ul[0] < 0.0 && gap <= reltol * (-ul[0])) ) + { + *info = 3; + } + else if ( reltol < 0.0 && ul[0] <= tv ) + { + *info = 4; + } + else if ( reltol < 0.0 && ul[1] >= tv ) + { + *info = 5; + } + else if ( *iters == maxiters ) + { + *info = 1; + } + else + { + *info = 0; + } + if (*info) + { + return 0; + } + + + + /* + * compute scaled matrices F + */ + + for (j = 0, pos = 0; j < m; j++) for (i = 0, pos2 = 0; i < L; + pos += blck_szs[i] * (blck_szs[i] + 1) / 2, + pos2 += blck_szs[i] * blck_szs[i], i++) + { + + /* compute R' * Fj(i) * R, store in Fsc+pos */ + cngrncb(2, blck_szs[i], F + sz + pos, R + pos2, Fsc + pos, temp); + + /* correct diagonal elements */ + for (k = 0, pos4 = pos; k < blck_szs[i]; pos4 += blck_szs[i] - k, k++) + { + Fsc[pos4] /= sqrt2; + } + + } + + + /* + * form rhs = Lambda^(-1/2) - (q/gap) * Lambda^(1/2) + */ + + F2C(dscal)(&sz, &dbl0, rhs, &int1); /* rhs := 0 */ + rho = -q / gap; + for (i = 0, pos = 0, pos3 = 0; i < L; + pos += blck_szs[i] * (blck_szs[i] + 1) / 2, + pos3 += blck_szs[i], i++) + for (k = 0, pos4 = pos; k < blck_szs[i]; pos4 += blck_szs[i] - k, k++) + { + scal = sigx[pos3 + k]; + rhs[pos4] = (1.0 / scal + rho * scal) / sqrt2; + } + + + /* + * solve least-squares problem; need workspace of size m + nb*sz + * - rhs is overwritten by dx + * - in first iteration, estimate condition number of Fsc + */ + + F2C(dgels)("N", &sz, &m, &int1, Fsc, &sz, rhs, &sz, temp, <emp, + &info2); + if (info2) + { + if ( getWarningMode() ) + { + sciprint(_("Error in dgels, info = %d.\n"), info2); + } + *info = -18; + return 1; + } + + if (*iters == 0) + { + + /* estimate the condition number in 1-norm of the R-factor of + * the qr-decomposition of Fsc (is stored in Fsc) + * need work space of size 3*m */ + F2C(dtrcon)("1", "U", "N", &m, Fsc, &sz, &rcond, temp, iwork, + &info2); + if (info2 < 0) + { + if ( getWarningMode() ) + { + sciprint(_("Error in dtrcon, info = %d.\n"), info2); + } + *info = -18; + return 1; + } + if (rcond < MINRCOND) + { + if ( getWarningMode() ) + { + sciprint(_("The matrices F_i, i=1,...,m are linearly dependent (or the initial points are very badly conditioned).\n")); + } + *info = -3; + return 1; + } + + } + + + + /* + * - compute dZ = + * R*((q/gap)*Lambda^(1/2) - Lambda^(-1/2) + R^T*dF*R )*R^T + * - compute generalized eigenvalues of (dF, F), store in sigx + * - compute generalized eigenvalues of (dZ, Z), store in sigz + * + * loop over blocks i=0,...,L-1 + * pos: position of (0,0) element of block i in packed storage + * pos2: position of (0,0) element of block i in unpacked storage + * pos3: position of first eigenvalue of in sigx and sigz + */ + + for (i = 0, pos = 0, pos2 = 0, pos3 = 0; i < L; + pos += blck_szs[i] * (blck_szs[i] + 1) / 2, + pos2 += blck_szs[i] * blck_szs[i], + pos3 += blck_szs[i], i++) + { + + lngth = blck_szs[i] * (blck_szs[i] + 1) / 2; + + /* compute ith block of dF = \sum \delta x_i F_i, + * store in temp */ + F2C(dgemv)("N", &lngth, &m, &dbl1, F + sz + pos, &sz, dx, &int1, + &dbl0, temp, &int1); + + /* scale dF as R'*dF*R, store in temp + lngth */ + cngrncb(2, blck_szs[i], temp, R + pos2, temp + lngth, temp + 2 * lngth); + + /* add (q/gap)*Lambda^(1/2) - Lambda^(-1/2) */ + for (k = 0, pos4 = lngth; k < blck_szs[i]; pos4 += blck_szs[i] - k, k++) + { + temp[pos4] -= rho * sigx[pos3 + k] + 1.0 / sigx[pos3 + k]; + } + + /* replace dF in temp by L^{-1}*dF*L^{-T}, + * (L: cholesky factor of F, stored in X) + * and compute eigenvalues of L^{-1}*dF*L^{-T} */ + F2C(dspgst)(&int1, "L", blck_szs + i, temp, X + pos, &info2); + if (info2) + { + if ( getWarningMode() ) + { + sciprint(_("Error in dspst, info = %d.\n"), info2); + } + + *info = -18; + return 1; + } + /* temp has to be of size max_n*(max_n+1)+3*max_n */ + F2C(dspev)("N", "L", blck_szs + i, temp, sigx + pos3, NULL, &int1, + temp + 2 * lngth, &info2); + if (info2) + { + if ( getWarningMode() ) + { + sciprint(_("Error in dspev, info = %d.\n"), info2); + } + *info = -18; + return 1; + } + + /* dZ := R*((q/gap)*Lambda^(1/2) - Lambda^(-1/2) + R'*dF*R)*R' */ + cngrncb(1, blck_szs[i], temp + lngth, R + pos2, dZ + pos, + temp + 2 * lngth); + + /* copy ith block of dZ to temp */ + F2C(dcopy)(&lngth, dZ + pos, &int1, temp, &int1); + + /* copy ith block of Z to temp + lngth */ + F2C(dcopy)(&lngth, Z + pos, &int1, temp + lngth, &int1); + + /* sigz: generalized eigenvalues of (dZ,Z) + * required size of temp: 3*max_n + max_n*(max_n+1) */ + F2C(dspgv)(&int1, "N", "L", blck_szs + i, temp, temp + lngth, sigz + pos3, + NULL, &int1, temp + 2 * lngth, &info2); + if (info2) + { + if ( getWarningMode() ) + { + sciprint(_("Error in dspgv, info = %d.\n"), info2); + } + *info = -18; + return 1; + } + + } + + + /* + * compute feasible rectangle for plane search + */ + + maxpossigx = 0.0; + minnegsigx = 0.0; + maxpossigz = 0.0; + minnegsigz = 0.0; + for (i = 0; i < n; i++) + { + if ( sigx[i] > maxpossigx ) + { + maxpossigx = sigx[i]; /* max pos eigenvalue in sigx */ + } + else if ( sigx[i] < minnegsigx ) + { + minnegsigx = sigx[i]; /* min neg eigenvalue in sigx */ + } + if ( sigz[i] > maxpossigz ) + { + maxpossigz = sigz[i]; /* max pos eigenvalue in sigz */ + } + else if ( sigz[i] < minnegsigz ) + { + minnegsigz = sigz[i]; /* min neg eigenvalue in sigz */ + } + } + nrmx = F2C(dnrm2)(&n, sigx, &int1); /* norm of scaled dx */ + nrmz = F2C(dnrm2)(&n, sigz, &int1); /* norm of scaled dZ */ + nrmmax = Max( nrmx, nrmz); + + XdZ = inprd(F, dZ, L, blck_szs); /* Tr F0*dZ */ + ZdX = F2C(ddot)(&m, c, &int1, dx, &int1); /* c^T*dx */ + + + /* + * check corners of feasible rectangle + */ + + dbl_epsilon = F2C(dlamch)("e"); + if (nrmx > SIGTOL * nrmmax) + if (ZdX < 0.0) + { + alphax = (minnegsigx < -dbl_epsilon) ? -1.0 / minnegsigx : 0.0; + } + else + { + alphax = (maxpossigx > dbl_epsilon) ? -1.0 / maxpossigx : 0.0; + } + else + { + alphax = 0.0; + } + + if (nrmz > SIGTOL * nrmmax) + if (XdZ < 0.0) + { + alphaz = (minnegsigz < -dbl_epsilon) ? -1.0 / minnegsigz : 0.0; + } + else + { + alphaz = (maxpossigz > dbl_epsilon) ? -1.0 / maxpossigz : 0.0; + } + else + { + alphaz = 0.0; + } + + newgap = gap + alphax * ZdX + alphaz * XdZ; + newu = ul[0] + alphax * ZdX; + newl = ul[1] - alphaz * XdZ; + + if (newgap <= Max(abstol, MINABSTOL)) + { + *info = 2; + } + else if ( (newl > 0.0 && newgap <= reltol * newl) || + (newu < 0.0 && newgap <= -reltol * newu) ) + { + *info = 3; + } + else if ( reltol < 0.0 && newu <= tv ) + { + *info = 4; + } + else if ( reltol < 0.0 && newl >= tv ) + { + *info = 5; + } + else if ( *iters == maxiters ) + { + *info = 1; + } + else + { + *info = 0; + } + + if (*info) + { + F2C(daxpy)(&m, &alphax, dx, &int1, x, &int1); + F2C(daxpy)(&sz, &alphaz, dZ, &int1, Z, &int1); + gap = newgap; + ul[0] = newu; + ul[1] = newl; + if ( getWarningMode() ) + { + sciprint("% 13.2e % 12.2e %10.2e\n", ul[0], ul[1], gap); + } + (*iters)++; + return 0; + } + + + /* + * plane search + * minimize phi(alphax,alphaz) = + * q*log(dual_gap + alphax*c^T*dx + alphaz* Tr F_0 dZ) + * - sum log (1+alphax*sigx_i) - sum log (1+alphaz*sigz) + */ + + alphax = 0.0; + alphaz = 0.0; + lambda_ls = 1.0; + + if (nrmx > SIGTOL * nrmmax) + if (nrmz > SIGTOL * nrmmax) /* compute primal and dual steps */ + while ( lambda_ls > 1e-4 ) + { + + /* compute 1st and 2nd derivatives of phi */ + rho = q / (gap + alphax * ZdX + alphaz * XdZ); + gradx = rho * ZdX; + hessx = 0.0; + gradz = rho * XdZ; + hessz = 0.0; + for (i = 0; i < n; i++) + { + gradx -= sigx[i] / (1.0 + alphax * sigx[i]); + hessx += SQR( sigx[i] / (1.0 + alphax * sigx[i]) ); + gradz -= sigz[i] / (1.0 + alphaz * sigz[i]); + hessz += SQR( sigz[i] / (1.0 + alphaz * sigz[i]) ); + } + + /* newton step */ + dalphax = -gradx / hessx; + dalphaz = -gradz / hessz; + lambda_ls = sqrt( SQR(gradx) / hessx + SQR(gradz) / hessz ); + alphax += (lambda_ls > 0.25) ? + dalphax / (1.0 + lambda_ls) : dalphax; + alphaz += (lambda_ls > 0.25) ? + dalphaz / (1.0 + lambda_ls) : dalphaz; + + } + + else while ( lambda_ls > 1e-4 ) /* primal step only */ + { + + /* compute 1st and 2nd derivatives of phi */ + rho = q / (gap + alphax * ZdX); + gradx = rho * ZdX; + hessx = 0.0; + for (i = 0; i < n; i++) + { + gradx -= sigx[i] / (1.0 + alphax * sigx[i]); + hessx += SQR( sigx[i] / (1.0 + alphax * sigx[i]) ); + } + + /* newton step */ + dalphax = -gradx / hessx; + lambda_ls = fabs(gradx) / sqrt(hessx); + alphax += (lambda_ls > 0.25) ? + dalphax / (1.0 + lambda_ls) : dalphax; + + } + + else if (nrmz > SIGTOL * nrmmax) /* dual step only */ + while ( lambda_ls > 1e-4 ) + { + + /* compute 1st and 2nd derivatives of phi */ + rho = q / (gap + alphaz * XdZ); + gradz = rho * XdZ; + hessz = 0.0; + for (i = 0; i < n; i++) + { + gradz -= sigz[i] / (1.0 + alphaz * sigz[i]); + hessz += SQR( sigz[i] / (1.0 + alphaz * sigz[i]) ); + } + + /* newton step */ + dalphaz = -gradz / hessz; + lambda_ls = fabs(gradz) / sqrt(hessz); + alphaz += (lambda_ls > 0.25) ? + dalphaz / (1.0 + lambda_ls) : dalphaz; + } + + + + /* update x and Z */ + F2C(daxpy)(&m, &alphax, dx, &int1, x, &int1); + F2C(daxpy)(&sz, &alphaz, dZ, &int1, Z, &int1); + + } + + return -1; /* should never happen */ +} + diff --git a/modules/optimization/src/c/sparse_f_Import.def b/modules/optimization/src/c/sparse_f_Import.def new file mode 100755 index 000000000..cb8361f3e --- /dev/null +++ b/modules/optimization/src/c/sparse_f_Import.def @@ -0,0 +1,6 @@ +LIBRARY sparse_f.dll + + +EXPORTS + +spt_
\ No newline at end of file diff --git a/modules/optimization/src/fortran/.deps/.dirstamp b/modules/optimization/src/fortran/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/optimization/src/fortran/.deps/.dirstamp diff --git a/modules/optimization/src/fortran/.dirstamp b/modules/optimization/src/fortran/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/optimization/src/fortran/.dirstamp diff --git a/modules/optimization/src/fortran/.libs/ajour.o b/modules/optimization/src/fortran/.libs/ajour.o Binary files differnew file mode 100755 index 000000000..8e2030c1e --- /dev/null +++ b/modules/optimization/src/fortran/.libs/ajour.o diff --git a/modules/optimization/src/fortran/.libs/bfgsd.o b/modules/optimization/src/fortran/.libs/bfgsd.o Binary files differnew file mode 100755 index 000000000..35d0b714f --- /dev/null +++ b/modules/optimization/src/fortran/.libs/bfgsd.o diff --git a/modules/optimization/src/fortran/.libs/calbx.o b/modules/optimization/src/fortran/.libs/calbx.o Binary files differnew file mode 100755 index 000000000..bac33ce93 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/calbx.o diff --git a/modules/optimization/src/fortran/.libs/calmaj.o b/modules/optimization/src/fortran/.libs/calmaj.o Binary files differnew file mode 100755 index 000000000..b096c1e61 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/calmaj.o diff --git a/modules/optimization/src/fortran/.libs/ctcab.o b/modules/optimization/src/fortran/.libs/ctcab.o Binary files differnew file mode 100755 index 000000000..96c100018 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/ctcab.o diff --git a/modules/optimization/src/fortran/.libs/ctonb.o b/modules/optimization/src/fortran/.libs/ctonb.o Binary files differnew file mode 100755 index 000000000..39ebf59a6 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/ctonb.o diff --git a/modules/optimization/src/fortran/.libs/dcube.o b/modules/optimization/src/fortran/.libs/dcube.o Binary files differnew file mode 100755 index 000000000..db053b72e --- /dev/null +++ b/modules/optimization/src/fortran/.libs/dcube.o diff --git a/modules/optimization/src/fortran/.libs/ddd2.o b/modules/optimization/src/fortran/.libs/ddd2.o Binary files differnew file mode 100755 index 000000000..c2aee60b7 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/ddd2.o diff --git a/modules/optimization/src/fortran/.libs/fajc1.o b/modules/optimization/src/fortran/.libs/fajc1.o Binary files differnew file mode 100755 index 000000000..6641512a8 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fajc1.o diff --git a/modules/optimization/src/fortran/.libs/fcomp1.o b/modules/optimization/src/fortran/.libs/fcomp1.o Binary files differnew file mode 100755 index 000000000..b75071a9e --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fcomp1.o diff --git a/modules/optimization/src/fortran/.libs/fcube.o b/modules/optimization/src/fortran/.libs/fcube.o Binary files differnew file mode 100755 index 000000000..f09dd1adb --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fcube.o diff --git a/modules/optimization/src/fortran/.libs/ffinf1.o b/modules/optimization/src/fortran/.libs/ffinf1.o Binary files differnew file mode 100755 index 000000000..fed73bdbb --- /dev/null +++ b/modules/optimization/src/fortran/.libs/ffinf1.o diff --git a/modules/optimization/src/fortran/.libs/fmani1.o b/modules/optimization/src/fortran/.libs/fmani1.o Binary files differnew file mode 100755 index 000000000..54f08ddd5 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmani1.o diff --git a/modules/optimization/src/fortran/.libs/fmc11a.o b/modules/optimization/src/fortran/.libs/fmc11a.o Binary files differnew file mode 100755 index 000000000..c30270eb3 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmc11a.o diff --git a/modules/optimization/src/fortran/.libs/fmc11b.o b/modules/optimization/src/fortran/.libs/fmc11b.o Binary files differnew file mode 100755 index 000000000..4b486f4ce --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmc11b.o diff --git a/modules/optimization/src/fortran/.libs/fmc11e.o b/modules/optimization/src/fortran/.libs/fmc11e.o Binary files differnew file mode 100755 index 000000000..adeae3e1e --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmc11e.o diff --git a/modules/optimization/src/fortran/.libs/fmc11z.o b/modules/optimization/src/fortran/.libs/fmc11z.o Binary files differnew file mode 100755 index 000000000..ed546ba22 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmc11z.o diff --git a/modules/optimization/src/fortran/.libs/fmlag1.o b/modules/optimization/src/fortran/.libs/fmlag1.o Binary files differnew file mode 100755 index 000000000..f0f5f509d --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmlag1.o diff --git a/modules/optimization/src/fortran/.libs/fmulb1.o b/modules/optimization/src/fortran/.libs/fmulb1.o Binary files differnew file mode 100755 index 000000000..c2fb64515 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmulb1.o diff --git a/modules/optimization/src/fortran/.libs/fmuls1.o b/modules/optimization/src/fortran/.libs/fmuls1.o Binary files differnew file mode 100755 index 000000000..4e0ee6e85 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fmuls1.o diff --git a/modules/optimization/src/fortran/.libs/fprf2.o b/modules/optimization/src/fortran/.libs/fprf2.o Binary files differnew file mode 100755 index 000000000..5d74663c4 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fprf2.o diff --git a/modules/optimization/src/fortran/.libs/frdf1.o b/modules/optimization/src/fortran/.libs/frdf1.o Binary files differnew file mode 100755 index 000000000..6b375a1bc --- /dev/null +++ b/modules/optimization/src/fortran/.libs/frdf1.o diff --git a/modules/optimization/src/fortran/.libs/fremf2.o b/modules/optimization/src/fortran/.libs/fremf2.o Binary files differnew file mode 100755 index 000000000..d8ac6ce07 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fremf2.o diff --git a/modules/optimization/src/fortran/.libs/fuclid.o b/modules/optimization/src/fortran/.libs/fuclid.o Binary files differnew file mode 100755 index 000000000..f18d8444f --- /dev/null +++ b/modules/optimization/src/fortran/.libs/fuclid.o diff --git a/modules/optimization/src/fortran/.libs/gcbd.o b/modules/optimization/src/fortran/.libs/gcbd.o Binary files differnew file mode 100755 index 000000000..e6cb75ac5 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/gcbd.o diff --git a/modules/optimization/src/fortran/.libs/gcp.o b/modules/optimization/src/fortran/.libs/gcp.o Binary files differnew file mode 100755 index 000000000..f75558331 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/gcp.o diff --git a/modules/optimization/src/fortran/.libs/icscof.o b/modules/optimization/src/fortran/.libs/icscof.o Binary files differnew file mode 100755 index 000000000..d3fea9638 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icscof.o diff --git a/modules/optimization/src/fortran/.libs/icse.o b/modules/optimization/src/fortran/.libs/icse.o Binary files differnew file mode 100755 index 000000000..f1104d07e --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icse.o diff --git a/modules/optimization/src/fortran/.libs/icse0.o b/modules/optimization/src/fortran/.libs/icse0.o Binary files differnew file mode 100755 index 000000000..a410841f1 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icse0.o diff --git a/modules/optimization/src/fortran/.libs/icse1.o b/modules/optimization/src/fortran/.libs/icse1.o Binary files differnew file mode 100755 index 000000000..774005848 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icse1.o diff --git a/modules/optimization/src/fortran/.libs/icse2.o b/modules/optimization/src/fortran/.libs/icse2.o Binary files differnew file mode 100755 index 000000000..3b4a9f5a0 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icse2.o diff --git a/modules/optimization/src/fortran/.libs/icsec2.o b/modules/optimization/src/fortran/.libs/icsec2.o Binary files differnew file mode 100755 index 000000000..7f0d9176a --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icsec2.o diff --git a/modules/optimization/src/fortran/.libs/icsei.o b/modules/optimization/src/fortran/.libs/icsei.o Binary files differnew file mode 100755 index 000000000..e82e22992 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/icsei.o diff --git a/modules/optimization/src/fortran/.libs/intreadmps.o b/modules/optimization/src/fortran/.libs/intreadmps.o Binary files differnew file mode 100755 index 000000000..990919f40 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/intreadmps.o diff --git a/modules/optimization/src/fortran/.libs/majour.o b/modules/optimization/src/fortran/.libs/majour.o Binary files differnew file mode 100755 index 000000000..71b562ead --- /dev/null +++ b/modules/optimization/src/fortran/.libs/majour.o diff --git a/modules/optimization/src/fortran/.libs/majysa.o b/modules/optimization/src/fortran/.libs/majysa.o Binary files differnew file mode 100755 index 000000000..6701c255d --- /dev/null +++ b/modules/optimization/src/fortran/.libs/majysa.o diff --git a/modules/optimization/src/fortran/.libs/majz.o b/modules/optimization/src/fortran/.libs/majz.o Binary files differnew file mode 100755 index 000000000..d405b2adf --- /dev/null +++ b/modules/optimization/src/fortran/.libs/majz.o diff --git a/modules/optimization/src/fortran/.libs/n1fc1.o b/modules/optimization/src/fortran/.libs/n1fc1.o Binary files differnew file mode 100755 index 000000000..75a768e01 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1fc1.o diff --git a/modules/optimization/src/fortran/.libs/n1fc1a.o b/modules/optimization/src/fortran/.libs/n1fc1a.o Binary files differnew file mode 100755 index 000000000..7adc043ac --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1fc1a.o diff --git a/modules/optimization/src/fortran/.libs/n1fc1o.o b/modules/optimization/src/fortran/.libs/n1fc1o.o Binary files differnew file mode 100755 index 000000000..feb678cc8 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1fc1o.o diff --git a/modules/optimization/src/fortran/.libs/n1gc2.o b/modules/optimization/src/fortran/.libs/n1gc2.o Binary files differnew file mode 100755 index 000000000..f44380091 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1gc2.o diff --git a/modules/optimization/src/fortran/.libs/n1gc2a.o b/modules/optimization/src/fortran/.libs/n1gc2a.o Binary files differnew file mode 100755 index 000000000..262bd898d --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1gc2a.o diff --git a/modules/optimization/src/fortran/.libs/n1gc2b.o b/modules/optimization/src/fortran/.libs/n1gc2b.o Binary files differnew file mode 100755 index 000000000..40f8e7926 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1gc2b.o diff --git a/modules/optimization/src/fortran/.libs/n1qn1.o b/modules/optimization/src/fortran/.libs/n1qn1.o Binary files differnew file mode 100755 index 000000000..d8713963f --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1qn1.o diff --git a/modules/optimization/src/fortran/.libs/n1qn1a.o b/modules/optimization/src/fortran/.libs/n1qn1a.o Binary files differnew file mode 100755 index 000000000..34ec53fe5 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1qn1a.o diff --git a/modules/optimization/src/fortran/.libs/n1qn2.o b/modules/optimization/src/fortran/.libs/n1qn2.o Binary files differnew file mode 100755 index 000000000..38ffc8de2 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1qn2.o diff --git a/modules/optimization/src/fortran/.libs/n1qn2a.o b/modules/optimization/src/fortran/.libs/n1qn2a.o Binary files differnew file mode 100755 index 000000000..6bcd79a6c --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1qn2a.o diff --git a/modules/optimization/src/fortran/.libs/n1qn3.o b/modules/optimization/src/fortran/.libs/n1qn3.o Binary files differnew file mode 100755 index 000000000..4fc18ac1a --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1qn3.o diff --git a/modules/optimization/src/fortran/.libs/n1qn3a.o b/modules/optimization/src/fortran/.libs/n1qn3a.o Binary files differnew file mode 100755 index 000000000..4bd131144 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/n1qn3a.o diff --git a/modules/optimization/src/fortran/.libs/nlis0.o b/modules/optimization/src/fortran/.libs/nlis0.o Binary files differnew file mode 100755 index 000000000..88db90aca --- /dev/null +++ b/modules/optimization/src/fortran/.libs/nlis0.o diff --git a/modules/optimization/src/fortran/.libs/nlis2.o b/modules/optimization/src/fortran/.libs/nlis2.o Binary files differnew file mode 100755 index 000000000..8fc35c475 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/nlis2.o diff --git a/modules/optimization/src/fortran/.libs/proj.o b/modules/optimization/src/fortran/.libs/proj.o Binary files differnew file mode 100755 index 000000000..2e93d5e40 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/proj.o diff --git a/modules/optimization/src/fortran/.libs/ql0001.o b/modules/optimization/src/fortran/.libs/ql0001.o Binary files differnew file mode 100755 index 000000000..d5a5a8aeb --- /dev/null +++ b/modules/optimization/src/fortran/.libs/ql0001.o diff --git a/modules/optimization/src/fortran/.libs/qnbd.o b/modules/optimization/src/fortran/.libs/qnbd.o Binary files differnew file mode 100755 index 000000000..b36e0d801 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/qnbd.o diff --git a/modules/optimization/src/fortran/.libs/qpgen1sci.o b/modules/optimization/src/fortran/.libs/qpgen1sci.o Binary files differnew file mode 100755 index 000000000..10f2122ea --- /dev/null +++ b/modules/optimization/src/fortran/.libs/qpgen1sci.o diff --git a/modules/optimization/src/fortran/.libs/qpgen2.o b/modules/optimization/src/fortran/.libs/qpgen2.o Binary files differnew file mode 100755 index 000000000..223c5e756 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/qpgen2.o diff --git a/modules/optimization/src/fortran/.libs/rdmps1.o b/modules/optimization/src/fortran/.libs/rdmps1.o Binary files differnew file mode 100755 index 000000000..3d854a07a --- /dev/null +++ b/modules/optimization/src/fortran/.libs/rdmps1.o diff --git a/modules/optimization/src/fortran/.libs/rdmpsz.o b/modules/optimization/src/fortran/.libs/rdmpsz.o Binary files differnew file mode 100755 index 000000000..23d3ea9ba --- /dev/null +++ b/modules/optimization/src/fortran/.libs/rdmpsz.o diff --git a/modules/optimization/src/fortran/.libs/rednor.o b/modules/optimization/src/fortran/.libs/rednor.o Binary files differnew file mode 100755 index 000000000..f6a787902 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/rednor.o diff --git a/modules/optimization/src/fortran/.libs/relvar.o b/modules/optimization/src/fortran/.libs/relvar.o Binary files differnew file mode 100755 index 000000000..8e638cc19 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/relvar.o diff --git a/modules/optimization/src/fortran/.libs/rlbd.o b/modules/optimization/src/fortran/.libs/rlbd.o Binary files differnew file mode 100755 index 000000000..65dfafef2 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/rlbd.o diff --git a/modules/optimization/src/fortran/.libs/satur.o b/modules/optimization/src/fortran/.libs/satur.o Binary files differnew file mode 100755 index 000000000..64e753c1b --- /dev/null +++ b/modules/optimization/src/fortran/.libs/satur.o diff --git a/modules/optimization/src/fortran/.libs/shanph.o b/modules/optimization/src/fortran/.libs/shanph.o Binary files differnew file mode 100755 index 000000000..ea35afefa --- /dev/null +++ b/modules/optimization/src/fortran/.libs/shanph.o diff --git a/modules/optimization/src/fortran/.libs/strang.o b/modules/optimization/src/fortran/.libs/strang.o Binary files differnew file mode 100755 index 000000000..121557525 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/strang.o diff --git a/modules/optimization/src/fortran/.libs/writebuf.o b/modules/optimization/src/fortran/.libs/writebuf.o Binary files differnew file mode 100755 index 000000000..eb190cb8d --- /dev/null +++ b/modules/optimization/src/fortran/.libs/writebuf.o diff --git a/modules/optimization/src/fortran/.libs/zgcbd.o b/modules/optimization/src/fortran/.libs/zgcbd.o Binary files differnew file mode 100755 index 000000000..fa5164a81 --- /dev/null +++ b/modules/optimization/src/fortran/.libs/zgcbd.o diff --git a/modules/optimization/src/fortran/.libs/zqnbd.o b/modules/optimization/src/fortran/.libs/zqnbd.o Binary files differnew file mode 100755 index 000000000..83adaa65c --- /dev/null +++ b/modules/optimization/src/fortran/.libs/zqnbd.o diff --git a/modules/optimization/src/fortran/Core_f_Import.def b/modules/optimization/src/fortran/Core_f_Import.def new file mode 100755 index 000000000..0c7c0885a --- /dev/null +++ b/modules/optimization/src/fortran/Core_f_Import.def @@ -0,0 +1,18 @@ + LIBRARY core_f.dll + + +EXPORTS +; +;core_f +; +clunit_ +allowptr_ +btof_ +ftob_ +funs_ +isbyref_ +ref2val_ + + + + diff --git a/modules/optimization/src/fortran/Elementary_functions_Import.def b/modules/optimization/src/fortran/Elementary_functions_Import.def new file mode 100755 index 000000000..714513e47 --- /dev/null +++ b/modules/optimization/src/fortran/Elementary_functions_Import.def @@ -0,0 +1,9 @@ + LIBRARY elementary_functions.dll + + +EXPORTS +; +;elementary_functions +vfinite_ +unsfdcopy_ +int2db_ diff --git a/modules/optimization/src/fortran/Elementary_functions_f_Import.def b/modules/optimization/src/fortran/Elementary_functions_f_Import.def new file mode 100755 index 000000000..16f9731f8 --- /dev/null +++ b/modules/optimization/src/fortran/Elementary_functions_f_Import.def @@ -0,0 +1,12 @@ + LIBRARY elementary_functions_f.dll + + +EXPORTS +; +;elementary_functions_f +dadd_ +dmmul_ +dset_ +entier_ +iset_ +lnblnk_ diff --git a/modules/optimization/src/fortran/Optimization_Import.def b/modules/optimization/src/fortran/Optimization_Import.def new file mode 100755 index 000000000..c44321c3d --- /dev/null +++ b/modules/optimization/src/fortran/Optimization_Import.def @@ -0,0 +1,21 @@ +LIBRARY optimization.dll + + +EXPORTS +setlsqrsolvf_ +lsqrsolvf_ +setlsqrsolvj_ +lsqrsolvj_ +setfsolvj_ +setfsolvf_ +spf_ +fsolvj_ +setfoptim_ +foptim_ +fsolvf_ +optim_ +nird_ +csolve_ +clsqrsolve_ +icsez_ +fprf2c_
\ No newline at end of file diff --git a/modules/optimization/src/fortran/Output_stream_Import.def b/modules/optimization/src/fortran/Output_stream_Import.def new file mode 100755 index 000000000..089553a97 --- /dev/null +++ b/modules/optimization/src/fortran/Output_stream_Import.def @@ -0,0 +1,9 @@ + LIBRARY output_stream.dll + + +EXPORTS +; +; output_stream +error_ +msgs_ +basout_
\ No newline at end of file diff --git a/modules/optimization/src/fortran/String_Import.def b/modules/optimization/src/fortran/String_Import.def new file mode 100755 index 000000000..85ee24c87 --- /dev/null +++ b/modules/optimization/src/fortran/String_Import.def @@ -0,0 +1,7 @@ + LIBRARY string.dll + + +EXPORTS +; +; string +cvstr_
\ No newline at end of file diff --git a/modules/optimization/src/fortran/ajour.f b/modules/optimization/src/fortran/ajour.f new file mode 100755 index 000000000..9c938fce6 --- /dev/null +++ b/modules/optimization/src/fortran/ajour.f @@ -0,0 +1,251 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ajour(mode,n,nc,nr,h,w,indi) +c + implicit double precision (a-h,o-z) + dimension h(*),w(n),indi(n) +c +c mode = +1 factorise la ligne nc (indices de depart) +c = -1 defactorise ' +c nr nbre de lignes factorisees +c h mat de dim n +c w,d vect de travail +c indi(i) ligne ou est stockee la ligne i de depart +c + inc=indi(nc) + nr1=nr+1 + nr2=nr-1 + nrr=n-nr + nii=n-inc + nkk=nr-inc + if(mode.eq.-1)go to 240 +c +c addition d'une ligne a l +c +c stockage des elements de la colonne inc dans w + nsaut=nii+1 + nh=inc*(n+1)-inc*(inc+1)/2 + nw=n + if(inc.eq.n) go to 20 + do 10 i=1,nii + w(nw)=h(nh) + nw=nw-1 + 10 nh=nh-1 + 20 w(nr1)=h(nh) + nh=nh-1 + if(inc.eq.nr1) go to 60 + do 40 i=1,inc-nr1 + nl=nii+i-1 + if(nl.eq.0) go to 35 + do 30 j=1,nl + h(nh+nsaut)=h(nh) + 30 nh=nh-1 + 35 w(nw)=h(nh) + nw=nw-1 + nh=nh-1 + 40 nsaut=nsaut+1 + do 50 j=1,inc-nr1 + h(nh+nsaut)=h(nh) + 50 nh=nh-1 +c + 60 nw=nw-1 + nsaut=1 + if(nr.eq.0) go to 125 + if(inc.eq.n) go to 80 + do 70 i=1,nii + h(nh+nsaut)=h(nh) + 70 nh=nh-1 + 80 if(nr.eq.1) go to 110 + do 100 i=1,nr2 + w(nw)=h(nh) + nw=nw-1 + nh=nh-1 + nsaut=nsaut+1 + if(n.eq.nr1) go to 100 + do 90 j=1,n-nr1 + h(nh+nsaut)=h(nh) + 90 nh=nh-1 + 100 continue + 110 w(nw)=h(nh) + nh=nh-1 + nsaut=nsaut+1 + if(inc.eq.nr1) go to 125 + do 120 i=1,inc-nr1 + h(nh+nsaut)=h(nh) + 120 nh=nh-1 +c mise a jour de l + 125 if(nr.ne.0) go to 130 + if(w(1).gt.0.0d+0) go to 220 + mode=-1 + return + 130 if(nr.eq.1) go to 160 + do 150 i=2,nr + ij=i + i1=i-1 + v=w(i) + do 140 j=1,i1 + v=v-h(ij)*w(j) + 140 ij=ij+nr-j + 150 w(i)=v + 160 ij=1 + v=w(nr1) + do 170 i=1,nr + wi=w(i) + hij=h(ij) + v=v-(wi**2)/hij + w(i)=wi/hij + 170 ij=ij+nr1-i + if(v.gt.0.0d+0) go to 180 + mode=-1 + return + 180 w(nr1)=v +c stockage de w dans h + nh=nr*(nr+1)/2 + nw=nr1 + nsaut=nw + h(nh+nsaut)=w(nw) + nw=nw-1 + nsaut=nsaut-1 + if(nr.eq.1) go to 220 + do 210 i=1,nr2 + h(nh+nsaut)=w(nw) + nw=nw-1 + nsaut=nsaut-1 + do 200 j=1,i + h(nh+nsaut)=h(nh) + 200 nh=nh-1 + 210 continue + 220 h(nr1)=w(1) + if(n.eq.nr1) go to 233 + nh1=nr*(n+1)-nr*(nr+1)/2+1 + nw=nr1 + do 230 i=1,n-nr1 + 230 h(nh1+i)=w(nw+i) +c mise a jour de indi + 233 do 235 i=1,n + ii=indi(i) + if(ii.le.nr.or.ii.ge.inc) go to 235 + indi(i)=ii+1 + 235 continue + nr=nr+1 + indi(nc)=nr + mode=0 + return +c +c soustraction d'une ligne a l +c +c recherche des composantes de h + 240 do 260 i=1,nr + ik=i + ij=inc + ii=1 + ko=min(ik,inc) + v=0.0d+0 + if(ko.eq.1) go to 252 + do 250 k=1,ko-1 + nk=nr1-k + v=v+h(ij)*h(ik)*h(ii) + ij=ij+nk-1 + ii=ii+nk + 250 ik=ik+nk-1 + 252 a=1.0d+0 + b=1.0d+0 + if(ko.eq.i) go to 253 + a=h(ik) + 253 if(ko.eq.inc) go to 260 + b=h(ij) + 260 w(i)=v+a*b*h(ii) +c mise a jour de l + if(inc.eq.nr) go to 315 + inc1=inc-1 + nh=inc1*nr1-inc1*inc/2+2 + nh1=nh+nkk + di=h(nh-1) + do 310 j=1,nkk + di1=h(nh1) + nh1=nh1+1 + a=h(nh) + ai=a*di + c=(a**2)*di+di1 + h(nh)=c + nh=nh+1 + if(j.eq.nkk) go to 315 + do 300 i=1,nkk-j + h1=h(nh) + h2=h(nh1) + u=ai*h1+h2*di1 + h(nh)=u/c + h(nh1)=-h1+a*h2 + nh=nh+1 + nh1=nh1+1 + 300 continue + nh=nh+1 + di=di*di1/c + 310 continue +c condensation de la matrice l + 315 nh=inc+1 + nsaut=1 + nj=nr-2 + if(inc.eq.1) nj=nj+1 + if(nr.eq.1) go to 440 + do 430 i=1,nr2 + do 425 j=1,nj + h(nh-nsaut)=h(nh) + 425 nh=nh+1 + nsaut=nsaut+1 + nh=nh+1 + if(i.eq.inc-1) go to 430 + nj=nj-1 + if(nj.eq.0) go to 440 + 430 continue +c mise a jour de la matrice h + 440 nh=((nr*nr2)/2)+1 + nw=1 + nsaut=nr + if(inc.eq.1) go to 470 + do 460 i=1,inc-1 + h(nh)=w(nw) + nw=nw+1 + nsaut=nsaut-1 + if(n.eq.nr) go to 455 + do 450 j=1,nrr + 450 h(nh+j)=h(nh+nsaut+j) + 455 nh=nh+nrr+1 + 460 continue + 470 nw=nw+1 + if(nr.eq.n) go to 485 + do 480 i=1,nrr + 480 w(nr+i)=h(nh+nsaut+i-1) + nsaut=nsaut+nrr + 485 if(inc.eq.nr) go to 510 + do 500 i=1,nkk + nsaut=nsaut-1 + h(nh)=w(nw) + nw=nw+1 + if(nr.eq.n) go to 495 + do 490 j=1,nrr + 490 h(nh+j)=h(nh+nsaut+j) + 495 nh=nh+nrr+1 + 500 continue + 510 h(nh)=w(inc) + if(nr.eq.n) go to 540 + do 520 i=1,nrr + 520 h(nh+i)=w(nr+i) +c mise a jour de indi + 540 do 550 i=1,n + ii=indi(i) + if(ii.le.inc.or.ii.gt.nr) go to 550 + indi(i)=ii-1 + 550 continue + indi(nc)=nr + nr=nr-1 + mode=0 + return + end diff --git a/modules/optimization/src/fortran/ajour.lo b/modules/optimization/src/fortran/ajour.lo new file mode 100755 index 000000000..39d2ce9a5 --- /dev/null +++ b/modules/optimization/src/fortran/ajour.lo @@ -0,0 +1,12 @@ +# src/fortran/ajour.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ajour.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/bfgsd.f b/modules/optimization/src/fortran/bfgsd.f new file mode 100755 index 000000000..0fe8c81a1 --- /dev/null +++ b/modules/optimization/src/fortran/bfgsd.f @@ -0,0 +1,45 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine bfgsd(diag,n,nt,np,y,s,ys,condm,param,zero,index) +c mise a jour de diag par la methode de bfgs diagonal +c utiliser a la suite de la correction de powell +c condm borne sup du conditionnement de diag +c param borne inf rapport reduction diag(i) +c + implicit double precision (a-h,o-z) + dimension diag(n),y(nt,n),s(nt,n),ys(nt) + integer index(nt) +c + inp=index(np) + ys1=1./ys(inp) + sds=0. + do 10 i=1,n +10 sds=sds + diag(i)*s(inp,i)**2 + sds1=1./sds + dmin=1.e25 + dmax=0. + do 20 i=1,n + dd1=param*diag(i) + dd1=dd1+1000.*zero + dd=diag(i)+ys1*y(inp,i)**2-sds1*(diag(i)*s(inp,i))**2 + diag(i)=dd +c sauvegarde positivite + if(dd.le.dd1)diag(i)=dd1 +c calcul conditionnement + if(diag(i).lt.dmin)dmin=diag(i) + if(diag(i).gt.dmax)dmax=diag(i) +20 continue +c limitation du conditionnement + if((condm*dmin)/dmax.gt.1)return + omeg=log(condm)/log(dmax/dmin) + do 30 i=1,n +30 diag(i)=diag(i)**omeg + return + end diff --git a/modules/optimization/src/fortran/bfgsd.lo b/modules/optimization/src/fortran/bfgsd.lo new file mode 100755 index 000000000..57d855276 --- /dev/null +++ b/modules/optimization/src/fortran/bfgsd.lo @@ -0,0 +1,12 @@ +# src/fortran/bfgsd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/bfgsd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/calbx.f b/modules/optimization/src/fortran/calbx.f new file mode 100755 index 000000000..159e5398b --- /dev/null +++ b/modules/optimization/src/fortran/calbx.f @@ -0,0 +1,44 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,bx) +c +c fonction : {bx}=[b]*{x}. +c [b] est definie par les vecteurs +c ({y}(i),{s}(i),{z}(i), i=1,np) et {diag} +c + implicit double precision (a-h,o-z) + dimension y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt) + dimension diag(n),bx(n),x(n) + integer indic(n),index(nt) +c + do 100 i=1,n + if(indic(i).gt.0) go to 100 + bx(i)=diag(i)*x(i) +100 continue +c + do 110 i=1,np + ii=index(i) +c + yx=0 + zx=0 + do 120 j=1,n + if(indic(j).gt.0) go to 120 + yx=yx+y(ii,j)*x(j) + zx=zx+z(ii,j)*x(j) +120 continue +c + do 130 j=1,n + if(indic(j).gt.0) go to 130 + bx(j)=bx(j)+yx*y(ii,j)/ys(ii)-zx*z(ii,j)/zs(ii) +130 continue +110 continue +c + return + end diff --git a/modules/optimization/src/fortran/calbx.lo b/modules/optimization/src/fortran/calbx.lo new file mode 100755 index 000000000..193f59528 --- /dev/null +++ b/modules/optimization/src/fortran/calbx.lo @@ -0,0 +1,12 @@ +# src/fortran/calbx.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/calbx.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/calmaj.f b/modules/optimization/src/fortran/calmaj.f new file mode 100755 index 000000000..ef4ec9c0b --- /dev/null +++ b/modules/optimization/src/fortran/calmaj.f @@ -0,0 +1,38 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine calmaj(dh,n,g1,sig,w,ir,mk,epsmc,nfac) +c + implicit double precision (a-h,o-z) +c subroutine de qnbd + dimension dh(*),g1(*),w(*) + if(nfac.eq.n) go to 50 + nfac1=nfac+1 + nnfac=n-nfac + n2fac=(nfac*nfac1)/2 + do 10 i=1,n +10 w(i)=g1(i)*sig + k=n2fac + if(nfac.eq.0)go to 25 + do 20 j=1,nfac + do 20 i=nfac1,n + k=k+1 + dh(k)=dh(k)+g1(i)*w(j) +20 continue +25 k=n2fac+nfac*nnfac + do 30 j=nfac1,n + do 30 i=j,n + k=k+1 + dh(k)=dh(k) + g1(i)*w(j) +30 continue +50 ir=nfac + if(nfac.eq.0)return + call majour(dh,g1,w,nfac,sig,ir,mk,epsmc) + return + end diff --git a/modules/optimization/src/fortran/calmaj.lo b/modules/optimization/src/fortran/calmaj.lo new file mode 100755 index 000000000..01e54169d --- /dev/null +++ b/modules/optimization/src/fortran/calmaj.lo @@ -0,0 +1,12 @@ +# src/fortran/calmaj.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/calmaj.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/core_Import.def b/modules/optimization/src/fortran/core_Import.def new file mode 100755 index 000000000..432b23c73 --- /dev/null +++ b/modules/optimization/src/fortran/core_Import.def @@ -0,0 +1,38 @@ + LIBRARY core.dll + + +EXPORTS +; +;core +iop_ +vstk_ +stack_ +errgst_ +com_ +recu_ +cha1_ +parse_ +isrecursioncalltofunction_ +callinterf_ +eqid_ +getscalar_ +checkrhs_ +checklhs_ +getrmat_ +getexternal_ +gettype_ +cremat_ +getsmat_ +checkval_ +getvect_ +cretlist_ +listcresmat_ +listcremat_ +listcrestring_ +; +; explicit imports (COMMON) to fix warning LNK4049: locally defined symbol +; +adre_ +intersci_ +errgst_ +; diff --git a/modules/optimization/src/fortran/ctcab.f b/modules/optimization/src/fortran/ctcab.f new file mode 100755 index 000000000..f23263c20 --- /dev/null +++ b/modules/optimization/src/fortran/ctcab.f @@ -0,0 +1,21 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ctcab (n,u,v,izs,rzs,dzs) +c + + integer n,izs(1) + real rzs(1) + double precision u(1),v(1),dzs(1) + do 1 i=1,n + v(i)=u(i) + 1 continue + return + end + diff --git a/modules/optimization/src/fortran/ctcab.lo b/modules/optimization/src/fortran/ctcab.lo new file mode 100755 index 000000000..f795279e2 --- /dev/null +++ b/modules/optimization/src/fortran/ctcab.lo @@ -0,0 +1,12 @@ +# src/fortran/ctcab.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ctcab.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/ctonb.f b/modules/optimization/src/fortran/ctonb.f new file mode 100755 index 000000000..0a209ceb7 --- /dev/null +++ b/modules/optimization/src/fortran/ctonb.f @@ -0,0 +1,19 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ctonb (n,u,v,izs,rzs,dzs) +c + integer n,izs(1) + real rzs(1) + double precision u(1),v(1),dzs(1) + do 1 i=1,n + v(i)=u(i) + 1 continue + return + end diff --git a/modules/optimization/src/fortran/ctonb.lo b/modules/optimization/src/fortran/ctonb.lo new file mode 100755 index 000000000..1ac2b16ee --- /dev/null +++ b/modules/optimization/src/fortran/ctonb.lo @@ -0,0 +1,12 @@ +# src/fortran/ctonb.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ctonb.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/dcube.f b/modules/optimization/src/fortran/dcube.f new file mode 100755 index 000000000..e17087fd4 --- /dev/null +++ b/modules/optimization/src/fortran/dcube.f @@ -0,0 +1,69 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine dcube(t,f,fp,ta,fa,fpa,tlower,tupper) +c +c --- arguments +c + double precision sign,den,anum,t,f,fp,ta,fa,fpa,tlower,tupper +c +c --- variables locales +c + double precision z1,b,discri +c +c Using f and fp at t and ta, computes new t by cubic formula +c safeguarded inside [tlower,tupper]. +c + z1=fp+fpa-3.d0*(fa-f)/(ta-t) + b=z1+fp +c +c first compute the discriminant (without overflow) +c + if (dabs(z1).le.1.d0) then + discri=z1*z1-fp*fpa + else + discri=fp/z1 + discri=discri*fpa + discri=z1-discri + if (z1.ge.0.d0 .and. discri.ge.0.d0) then + discri=dsqrt(z1)*dsqrt(discri) + go to 120 + endif + if (z1.le.0.d0 .and. discri.le.0.d0) then + discri=dsqrt(-z1)*dsqrt(-discri) + go to 120 + endif + discri=-1.d0 + endif + if (discri.lt.0.d0) then + if (fp.lt.0.d0) t=tupper + if (fp.ge.0.d0) t=tlower + go to 900 + endif +c +c discriminant nonnegative, compute solution (without overflow) +c + discri=dsqrt(discri) + 120 if (t-ta.lt.0.d0) discri=-discri + sign=(t-ta)/dabs(t-ta) + if (b*sign.gt.0.d+0) then + t=t+fp*(ta-t)/(b+discri) + else + den=z1+b+fpa + anum=b-discri + if (dabs((t-ta)*anum).lt.(tupper-tlower)*dabs(den)) then + t=t+anum*(ta-t)/den + else + t=tupper + endif + endif + 900 t=dmax1(t,tlower) + t=dmin1(t,tupper) + return + end diff --git a/modules/optimization/src/fortran/dcube.lo b/modules/optimization/src/fortran/dcube.lo new file mode 100755 index 000000000..553c99c31 --- /dev/null +++ b/modules/optimization/src/fortran/dcube.lo @@ -0,0 +1,12 @@ +# src/fortran/dcube.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dcube.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/ddd2.f b/modules/optimization/src/fortran/ddd2.f new file mode 100755 index 000000000..0c1744ecc --- /dev/null +++ b/modules/optimization/src/fortran/ddd2.f @@ -0,0 +1,83 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ddd2 (prosca,ctonb,ctcab,n,nm,depl,aux,jmin,jmax,diag, + / alpha,ybar,sbar,izs,rzs,dzs) +c +c calcule le produit h g ou +c . h est une matrice construite par la formule de bfgs inverse +c a nm memoires a partir de la matrice diagonale diag +c dans un espace hilbertien dont le produit scalaire +c est donne par prosca +c (cf. J. Nocedal, Math. of Comp. 35/151 (1980) 773-782) +c . g est un vecteur de dimension n (en general le gradient) +c +c la matrice diag apparait donc comme un preconditionneur diagonal +c +c depl = g (en entree), = h g (en sortie) +c +c la matrice h est memorisee par les vecteurs des tableaux +c ybar, sbar et les pointeurs jmin, jmax +c +c alpha(nm) est une zone de travail +c +c izs(1),rzs(1),dzs(1) sont des zones de travail pour prosca +c +c---- +c +c arguments +c + integer n,nm,jmin,jmax,izs(1) + real rzs(1) + double precision depl(n),diag(n),alpha(nm),ybar(n,nm),sbar(n,nm), + / aux(n),dzs(1) + external prosca,ctonb,ctcab +c +c variables locales +c + integer jfin,i,j,jp + double precision r,ps +c + jfin=jmax + if (jfin.lt.jmin) jfin=jmax+nm +c +c phase de descente +c + do 100 j=jfin,jmin,-1 + jp=j + if (jp.gt.nm) jp=jp-nm + call prosca (n,depl,sbar(1,jp),ps,izs,rzs,dzs) + r=ps + alpha(jp)=r + do 20 i=1,n + depl(i)=depl(i)-r*ybar(i,jp) +20 continue +100 continue +c +c preconditionnement +c + call ctonb (n,depl,aux,izs,rzs,dzs) + do 150 i=1,n + aux(i)=aux(i)*diag(i) +150 continue + call ctcab (n,aux,depl,izs,rzs,dzs) +c +c remontee +c + do 200 j=jmin,jfin + jp=j + if (jp.gt.nm) jp=jp-nm + call prosca (n,depl,ybar(1,jp),ps,izs,rzs,dzs) + r=alpha(jp)-ps + do 120 i=1,n + depl(i)=depl(i)+r*sbar(i,jp) +120 continue +200 continue + return + end diff --git a/modules/optimization/src/fortran/ddd2.lo b/modules/optimization/src/fortran/ddd2.lo new file mode 100755 index 000000000..e243074e0 --- /dev/null +++ b/modules/optimization/src/fortran/ddd2.lo @@ -0,0 +1,12 @@ +# src/fortran/ddd2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ddd2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fajc1.f b/modules/optimization/src/fortran/fajc1.f new file mode 100755 index 000000000..e2db642c5 --- /dev/null +++ b/modules/optimization/src/fortran/fajc1.f @@ -0,0 +1,130 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fajc1(n,nc,nr,h,w,indi) +c + implicit double precision (a-h,o-z) + dimension h(*),w(n),indi(n) +c + inc=indi(nc) + nr1=nr+1 + nr2=nr-1 + nrr=n-nr + nkk=nr-inc +c +c recherche des composantes de h + do 260 i=1,nr + ik=i + ij=inc + ii=1 + ko=min0(ik,inc) + v=0.d0 + if(ko.eq.1) go to 252 + kom1=ko-1 + do 250 k=1,kom1 + nk=nr1-k + v=v+h(ij)*h(ik)*h(ii) + ij=ij+nk-1 + ii=ii+nk + 250 ik=ik+nk-1 + 252 a=1 + b=1 + if(ko.eq.i) go to 253 + a=h(ik) + 253 if(ko.eq.inc) go to 260 + b=h(ij) + 260 w(i)=v+a*b*h(ii) +c mise a jour de l + if(inc.eq.nr) go to 315 + inc1=inc-1 + nh=inc1*nr1-inc1*inc/2+2 + nh1=nh+nkk + di=h(nh-1) + do 310 j=1,nkk + di1=h(nh1) + nh1=nh1+1 + a=h(nh) + ai=a*di + c=(a**2)*di+di1 + h(nh)=c + nh=nh+1 + if(j.eq.nkk) go to 315 + nkkmj=nkk-j + do 300 i=1,nkkmj + h1=h(nh) + h2=h(nh1) + u=ai*h1+h2*di1 + h(nh)=u/c + h(nh1)=-h1+a*h2 + nh=nh+1 + nh1=nh1+1 + 300 continue + nh=nh+1 + di=di*di1/c + 310 continue +c condensation de la matrice l + 315 nh=inc+1 + nsaut=1 + nj=nr-2 + if(inc.eq.1) nj=nj+1 + if(nr.eq.1) go to 440 + do 430 i=1,nr2 + do 425 j=1,nj + h(nh-nsaut)=h(nh) + 425 nh=nh+1 + nsaut=nsaut+1 + nh=nh+1 + if(i.eq.inc-1) go to 430 + nj=nj-1 + if(nj.eq.0) go to 440 + 430 continue +c mise a jour de la matrice h + 440 nh=((nr*nr2)/2)+1 + nw=1 + nsaut=nr + if(inc.eq.1) go to 470 + incm1=inc-1 + do 460 i=1,incm1 + h(nh)=w(nw) + nw=nw+1 + nsaut=nsaut-1 + if(n.eq.nr) go to 455 + do 450 j=1,nrr + 450 h(nh+j)=h(nh+nsaut+j) + 455 nh=nh+nrr+1 + 460 continue + 470 nw=nw+1 + if(nr.eq.n) go to 485 + do 480 i=1,nrr + 480 w(nr+i)=h(nh+nsaut+i-1) + nsaut=nsaut+nrr + 485 if(inc.eq.nr) go to 510 + do 500 i=1,nkk + nsaut=nsaut-1 + h(nh)=w(nw) + nw=nw+1 + if(nr.eq.n) go to 495 + do 490 j=1,nrr + 490 h(nh+j)=h(nh+nsaut+j) + 495 nh=nh+nrr+1 + 500 continue + 510 h(nh)=w(inc) + if(nr.eq.n) go to 540 + do 520 i=1,nrr + 520 h(nh+i)=w(nr+i) +c mise a jour de indi + 540 do 550 i=1,n + ii=indi(i) + if(ii.le.inc.or.ii.gt.nr) go to 550 + indi(i)=ii-1 + 550 continue + indi(nc)=nr + nr=nr-1 + return + end diff --git a/modules/optimization/src/fortran/fajc1.lo b/modules/optimization/src/fortran/fajc1.lo new file mode 100755 index 000000000..d4b25c611 --- /dev/null +++ b/modules/optimization/src/fortran/fajc1.lo @@ -0,0 +1,12 @@ +# src/fortran/fajc1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fajc1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fcomp1.f b/modules/optimization/src/fortran/fcomp1.f new file mode 100755 index 000000000..35a703b11 --- /dev/null +++ b/modules/optimization/src/fortran/fcomp1.f @@ -0,0 +1,75 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fcomp1(indic2,ibloc,indi,h,g,d,w,w1,n,nr,ncs, + &dga,delta,prop,acc,scale) +c + implicit double precision (a-h,o-z) + dimension ibloc(n),indi(n),h(*),g(n),d(n), + &w(n),w1(n),scale(n) +c + ncs=0 + if(nr.eq.n) return + zm=0.d0 + if(indic2.eq.1) go to 900 + delta=0.d0 + nh=nr*(nr+1)/2 + nrr=n-nr + call fmlag1(n,nr,h,d,w) + do 500 i=1,n + ibi=ibloc(i) + if(ibi.eq.0) go to 500 + gi=g(i) + inc=indi(i) + inc1=inc-1 + inr=inc-nr + winc=w(inc) + dmu=winc+gi + am=dmin1(dabs(gi),dabs(dmu)) + if(2.d0*dabs(winc).ge.am) go to 500 + if(ibi.eq.-1.and.dmu.ge.0.d0) go to 500 + if(ibi.eq.1.and.dmu.le.0.d0) go to 500 + dmu=dabs(dmu) + if(dmu*scale(i).le.acc) go to 500 + dmu1=dmu*dmu + k=inr + nh1=(inc1)*(n+1)-(inc1)*inc/2+1 + z=h(nh1) + if(nr.eq.0) go to 350 + do 200 j=1,nr + w1(j)=h(nh+k) + 200 k=k+nrr + call fmc11e(h,nr,w1,w1,nr) + k=inr + do 250 j=1,nr + z=z-w1(j)*h(nh+k) + 250 k=k+nrr + 350 dmu1=dmu1/z + if(dmu1.le.delta) go to 500 + delta=dmu1 + ncs=i + zm=dmu + 500 continue + if(ncs.eq.0) return + if(delta.le.-prop*dga)ncs=0 + return + 900 do 910 i=1,n + ibi=ibloc(i) + if(ibi.eq.0) go to 910 + dmu=g(i) + if(ibi.eq.-1.and.dmu.ge.0.d0) go to 910 + if(ibi.eq.1.and.dmu.le.0.d0) go to 910 + dmu=dabs(dmu)*scale(i) + if(dmu.le.zm) go to 910 + zm=dmu + ncs=i + 910 continue + if(zm.le.acc) ncs=0 + return + end diff --git a/modules/optimization/src/fortran/fcomp1.lo b/modules/optimization/src/fortran/fcomp1.lo new file mode 100755 index 000000000..26ba88cc9 --- /dev/null +++ b/modules/optimization/src/fortran/fcomp1.lo @@ -0,0 +1,12 @@ +# src/fortran/fcomp1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fcomp1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fcube.f b/modules/optimization/src/fortran/fcube.f new file mode 100755 index 000000000..d4a55ac40 --- /dev/null +++ b/modules/optimization/src/fortran/fcube.f @@ -0,0 +1,75 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fcube(t,f,fp,ta,fa,fpa,tlower,tupper) +c + implicit double precision (a-h,o-z) +c +c Using f and fp at t and ta, computes new t by cubic formula +c safeguarded inside [tlower,tupper]. +c + z1=fp+fpa-3.d0*(fa-f)/(ta-t) + b=z1+fp +c +c first compute the discriminant (without overflow) +c + if (dabs(z1).le.1.d0) then + discri=z1*z1-fp*fpa + else + discri=fp/z1 + discri=discri*fpa + discri=z1-discri + if (z1.ge.0.d0 .and. discri.ge.0.d0) then + discri=dsqrt(z1)*dsqrt(discri) + go to 200 + endif + if (z1.le.0.d0 .and. discri.le.0.d0) then + discri=dsqrt(-z1)*dsqrt(-discri) + go to 200 + endif + discri=-1.d0 + endif + if (discri.lt.0.d0) then + if (fp.lt.0.d0) t=tupper + if (fp.ge.0.d0) t=tlower + go to 990 + endif +c +c discriminant nonnegative, stable solution formula +c + discri=dsqrt(discri) + 200 if (t-ta.lt.0.d0) discri=-discri + sign=(t-ta)/dabs(t-ta) + if (b*sign.gt.0.) then + anum=(ta-t)*fp + den=b+discri + else + den=z1+b+fpa + anum=(ta-t)*(b-discri) + endif +c +c now compute the ratio (without overflow) +c + if (dabs(den).ge.1.d0) then + t=t+anum/den + else + if (dabs(anum).lt.(tupper-tlower)*dabs(den)) then + t=t+anum/den + else + if (fp.lt.0.d0) t=tupper + if (fp.ge.0.d0) t=tlower + endif + endif +c +c finally, safeguard +c + t=dmax1(t,tlower) + t=dmin1(t,tupper) + 990 return + end diff --git a/modules/optimization/src/fortran/fcube.lo b/modules/optimization/src/fortran/fcube.lo new file mode 100755 index 000000000..4b158c7df --- /dev/null +++ b/modules/optimization/src/fortran/fcube.lo @@ -0,0 +1,12 @@ +# src/fortran/fcube.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fcube.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/ffinf1.f b/modules/optimization/src/fortran/ffinf1.f new file mode 100755 index 000000000..bb305c83a --- /dev/null +++ b/modules/optimization/src/fortran/ffinf1.f @@ -0,0 +1,27 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine ffinf1 (n,nv,jc,xpr,p,s) + implicit double precision (a-h,o-z) + dimension jc(nv),p(*),s(n),xpr(nv) +c +c cette subroutine calcule s = sigma xpr(.)*p(.) +c sachant que les xpr ont ete calcules par fprf2 +c + do 920 i=1,n + ps=0. + do 910 k=1,nv + j=jc(k)-1 + if(j.eq.0) go to 910 + nij=(j-1)*n+i + ps=ps+xpr(k)*p(nij) + 910 continue + 920 s(i)=ps + return + end diff --git a/modules/optimization/src/fortran/ffinf1.lo b/modules/optimization/src/fortran/ffinf1.lo new file mode 100755 index 000000000..0ba5d3c6c --- /dev/null +++ b/modules/optimization/src/fortran/ffinf1.lo @@ -0,0 +1,12 @@ +# src/fortran/ffinf1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ffinf1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmani1.f b/modules/optimization/src/fortran/fmani1.f new file mode 100755 index 000000000..31c2d7aab --- /dev/null +++ b/modules/optimization/src/fortran/fmani1.f @@ -0,0 +1,22 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmani1 (mode,n,d,w,indi) +c + implicit double precision (a-h,o-z) + dimension d(n),w(n),indi(n) +c + if(mode.eq.-1) go to 20 + do 10 i=1,n + 10 w(indi(i))=d(i) + return + 20 do 30 i=1,n + 30 w(i)=d(indi(i)) + return + end diff --git a/modules/optimization/src/fortran/fmani1.lo b/modules/optimization/src/fortran/fmani1.lo new file mode 100755 index 000000000..d8c5fd94f --- /dev/null +++ b/modules/optimization/src/fortran/fmani1.lo @@ -0,0 +1,12 @@ +# src/fortran/fmani1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmani1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmc11a.f b/modules/optimization/src/fortran/fmc11a.f new file mode 100755 index 000000000..83d68b300 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11a.f @@ -0,0 +1,129 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmc11a(a,n,z,sig,w,ir,mk,eps) + implicit double precision (a-h,o-z) + dimension a(*),z(n),w(n) +c update factors given in a by sig*z*ztranspose + if(n.gt.1)goto1 + a(1)=a(1)+sig *z(1)**2 + ir=1 + if(a(1).gt.0.d0)return + a(1)=0.d0 + ir=0 + return + 1 continue + np=n+1 + if(sig.gt.0.d0)goto40 + if(sig.eq.0.d0.or.ir.eq.0)return + ti=1.d0/sig + ij=1 + if(mk.eq.0)goto10 + do 7 i=1,n + if(a(ij).ne.0.d0)ti=ti+w(i)**2/a(ij) + 7 ij=ij+np-i + goto20 + 10 continue + do 11 i=1,n + 11 w(i)=z(i) + do 15 i=1,n + ip=i+1 + v=w(i) + if(a(ij).gt.0.d0)goto12 + w(i)=0.d0 + ij=ij+np-i + goto15 + 12 continue + ti=ti+v**2/a(ij) + if(i.eq.n)goto14 + do 13 j=ip,n + ij=ij+1 + 13 w(j)=w(j)-v*a(ij) + 14 ij=ij+1 + 15 continue + 20 continue + if(ir.le.0 )goto21 + if(ti.gt.0.d0)goto22 + if ((mk-1) .le. 0) then + goto 40 + else + goto 23 + endif + 21 ti=0.d0 + ir=-ir-1 + goto23 + 22 ti=eps/sig + if(eps.eq.0.d0)ir=ir-1 + 23 continue + mm=1 + tim=ti + do 30 i=1,n + j=np-i + ij=ij-i + if(a(ij).ne.0.d0)tim=ti-w(j)**2/a(ij) + w(j)=ti + 30 ti=tim + goto41 + 40 continue + mm=0 + tim=1.d0/sig + 41 continue + ij=1 + do 66 i=1,n + ip=i+1 + v=z(i) + if(a(ij).gt.0.d0)goto53 + if(ir.gt.0 .or.sig.lt.0.d0.or.v.eq.0.d0)goto52 + ir=1-ir + a(ij)=v**2/tim + if(i.eq.n)return + do 51 j=ip,n + ij=ij+1 + 51 a(ij)=z(j)/v + return + 52 continue + ti=tim + ij=ij+np-i + goto66 + 53 continue + al=v/a(ij) + if (nm .le. 0) then + goto 54 + else + goto 55 + endif + 54 ti=tim+v*al + goto56 + 55 ti=w(i) + 56 continue + r=ti/tim + a(ij)=a(ij)*r + if(r.eq.0.d0)goto70 + if(i.eq.n)goto70 + b=al/ti + if(r.gt.4.d0)goto62 + do 61 j=ip,n + ij=ij+1 + z(j)=z(j)-v*a(ij) + 61 a(ij)=a(ij)+b*z(j) + goto64 + 62 gm=tim/ti + do 63 j=ip,n + ij=ij+1 + y=a(ij) + a(ij)=b*z(j)+y*gm + 63 z(j)=z(j)-v*y + 64 continue + tim=ti + ij=ij+1 + 66 continue + 70 continue + if(ir.lt.0)ir=-ir + return + end diff --git a/modules/optimization/src/fortran/fmc11a.lo b/modules/optimization/src/fortran/fmc11a.lo new file mode 100755 index 000000000..eb55acb33 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11a.lo @@ -0,0 +1,12 @@ +# src/fortran/fmc11a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmc11a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmc11b.f b/modules/optimization/src/fortran/fmc11b.f new file mode 100755 index 000000000..ceb81365b --- /dev/null +++ b/modules/optimization/src/fortran/fmc11b.f @@ -0,0 +1,46 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmc11b(a,n,ir) +c factorize a matrix given in a + implicit double precision (a-h,o-z) + dimension a(*) + ir=n + if(n.gt.1)goto100 + if(a(1).gt.0.d0)return + a(1)=0.d0 + ir=0 + return + 100 continue + np=n+1 + ii=1 + do 104 i=2,n + aa=a(ii) + ni=ii+np-i + if(aa.gt.0.d0)goto101 + a(ii)=0.d0 + ir=ir-1 + ii=ni+1 + goto104 + 101 continue + ip=ii+1 + ii=ni+1 + jk=ii + do 103 ij=ip,ni + v=a(ij)/aa + do 102 ik=ij,ni + a(jk)=a(jk)-a(ik)*v + 102 jk=jk+1 + 103 a(ij)=v + 104 continue + if(a(ii).gt.0.d0)return + a(ii)=0.d0 + ir=ir-1 + return + end diff --git a/modules/optimization/src/fortran/fmc11b.lo b/modules/optimization/src/fortran/fmc11b.lo new file mode 100755 index 000000000..8166e3081 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11b.lo @@ -0,0 +1,12 @@ +# src/fortran/fmc11b.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmc11b.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmc11e.f b/modules/optimization/src/fortran/fmc11e.f new file mode 100755 index 000000000..1ca0e95b1 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11e.f @@ -0,0 +1,42 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmc11e(a,n,z,w,ir) +c multiply a vector z by the inverse of the factors given in a + implicit double precision (a-h,o-z) + dimensiona(*),z(n),w(n) + if(ir.lt.n)return + w(1)=z(1) + if(n.gt.1)goto400 + z(1)=z(1)/a(1) + return + 400 continue + do 402 i=2,n + ij=i + i1=i-1 + v=z(i) + do 401 j=1,i1 + v=v-a(ij)*z(j) + 401 ij=ij+n-j + w(i)=v + 402 z(i)=v + z(n)=z(n)/a(ij) + np=n+1 + do 411 nip=2,n + i=np-nip + ii=ij-nip + v=z(i)/a(ii) + ip=i+1 + ij=ii + do 410 j=ip,n + ii=ii+1 + 410 v=v-a(ii)*z(j) + 411 z(i)=v + return + end diff --git a/modules/optimization/src/fortran/fmc11e.lo b/modules/optimization/src/fortran/fmc11e.lo new file mode 100755 index 000000000..fe8109fb2 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11e.lo @@ -0,0 +1,12 @@ +# src/fortran/fmc11e.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmc11e.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmc11z.f b/modules/optimization/src/fortran/fmc11z.f new file mode 100755 index 000000000..69d0284e2 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11z.f @@ -0,0 +1,31 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmc11z(a,n,nr,z,sig,w,ir,mk,eps) + implicit double precision (a-h,o-z) + dimension a(*),z(n),w(n) +c + if(nr.eq.n) go to 45 + nr1=nr+1 + nh=nr*(nr1)/2+1 + if(nr.eq.0) go to 25 + do 20 i=1,nr + do 10 j=nr1,n + a(nh)=a(nh)+sig*z(i)*z(j) + 10 nh=nh+1 + 20 continue + 25 do 40 j=nr1,n + do 30 i=j,n + a(nh)=a(nh)+sig*z(i)*z(j) + 30 nh=nh+1 + 40 continue + if(nr.eq.0) return + 45 call fmc11a(a,nr,z,sig,w,ir,mk,eps) + return + end diff --git a/modules/optimization/src/fortran/fmc11z.lo b/modules/optimization/src/fortran/fmc11z.lo new file mode 100755 index 000000000..565bdd960 --- /dev/null +++ b/modules/optimization/src/fortran/fmc11z.lo @@ -0,0 +1,12 @@ +# src/fortran/fmc11z.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmc11z.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmlag1.f b/modules/optimization/src/fortran/fmlag1.f new file mode 100755 index 000000000..c8e72a4fb --- /dev/null +++ b/modules/optimization/src/fortran/fmlag1.f @@ -0,0 +1,33 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmlag1(n,nr,a,z,w) + implicit double precision (a-h,o-z) + dimension a(*),z(n),w(n) +c + if(nr.eq.n)return + nr1=nr+1 + if(nr.ne.0) go to 20 + do 10 i=nr1,n + 10 w(i)=0.d0 + return + 20 nrr=n-nr + nh1=nr*nr1/2 + nh=nh1+1 + do 30 j=nr1,n + u=0.d0 + nj=nh + do 40 i=1,nr + u=u+a(nj)*z(i) + 40 nj=nj+nrr + nh=nh+1 + w(j)=u + 30 continue + return + end diff --git a/modules/optimization/src/fortran/fmlag1.lo b/modules/optimization/src/fortran/fmlag1.lo new file mode 100755 index 000000000..9add057bf --- /dev/null +++ b/modules/optimization/src/fortran/fmlag1.lo @@ -0,0 +1,12 @@ +# src/fortran/fmlag1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmlag1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmulb1.f b/modules/optimization/src/fortran/fmulb1.f new file mode 100755 index 000000000..dffd7b2df --- /dev/null +++ b/modules/optimization/src/fortran/fmulb1.f @@ -0,0 +1,74 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmulb1(n,h,x,hx,tabaux,nmisaj,prosca,izs,rzs,dzs) + implicit double precision (a-h,o-z) + external prosca +c +c parametres + double precision un , deux + parameter ( un=1.0d+0, deux=2.0d+0 ) +c declarations + double precision h(*), x(n), hx(n), tabaux(n), dzs(*) + real rzs(*) + integer izs(*) + double precision uscalx, sscalx, nu, eta, gamma, mu, sigma + integer n, nmisaj, memsup, ptnu, compt, iu, is, k +c +c calcul de la longueur d'un bloc + memsup=2*n+2 +c calcul de h0*x=x=x + do 1000 k=1,n + hx(k)=x(k) +1000 continue +c + if (nmisaj.eq.0) then + return + else + ptnu=1 + compt=1 + endif +c +2000 iu=ptnu+1 + is=iu+n + do 3000 k=1,n + tabaux(k)=h(iu+k) +3000 continue + call prosca(n,tabaux,x,uscalx,izs,rzs,dzs) + do 4000 k=1,n + tabaux(k)=h(is+k) +4000 continue + call prosca(n,tabaux,x,sscalx,izs,rzs,dzs) + nu=h(ptnu) + eta=h(ptnu+1) +c calcul du nouveau terme et addition dans hx + if (compt.eq.1) then + gamma=eta / nu + do 5000 k=1,n + hx(k)=gamma * hx(k) +5000 continue + mu=sscalx / nu + sigma=-(deux * sscalx / eta)+(uscalx / nu) + else + mu=sscalx / eta + sigma=-(un + nu / eta)* mu + uscalx / eta + endif +c + do 6000 k=1,n + hx(k)=hx(k) - mu * h(iu+k) - sigma * h(is+k) +6000 continue +c + compt=compt+1 + if (compt.le.nmisaj) then + ptnu=ptnu+memsup + goto 2000 + else + return + endif + end diff --git a/modules/optimization/src/fortran/fmulb1.lo b/modules/optimization/src/fortran/fmulb1.lo new file mode 100755 index 000000000..6131d9600 --- /dev/null +++ b/modules/optimization/src/fortran/fmulb1.lo @@ -0,0 +1,12 @@ +# src/fortran/fmulb1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmulb1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fmuls1.f b/modules/optimization/src/fortran/fmuls1.f new file mode 100755 index 000000000..a7bfa8397 --- /dev/null +++ b/modules/optimization/src/fortran/fmuls1.f @@ -0,0 +1,49 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fmuls1(n,h,x,hx) + implicit double precision (a-h,o-z) +c +c ce sous-programme effectue le produit h * x avec: +c n (e) dimension du probleme +c h (e) dimension n(n+1)/2. tiangle superieur, coefficients par ligne +c x (e) vecteur de dimension n +c hx (s) dimension n. resultat du produit +c +c parametre + double precision zero + parameter ( zero=0.0d+0 ) +c declarations + double precision h(*), x(n), hx(n), aux1 + integer n, k, km1, kj, j +c + do 3000 k=1,n +c calcul de la keme composante du produit h* x + aux1=zero +c h(kj) est le coefficient (k,j) de la matrice symetrique complete + kj=k + km1=k-1 +c contribution du triangle inferieur + if (km1.ge.1) then + do 1000 j=1,km1 + aux1=aux1 + h(kj) * x(j) + kj=kj+(n-j) +1000 continue + endif +c contribution du triangle superieur + do 2000 j=k,n + aux1=aux1 + h(kj) * x(j) + kj=kj+1 +2000 continue +c + hx(k)=aux1 +3000 continue +c + return + end diff --git a/modules/optimization/src/fortran/fmuls1.lo b/modules/optimization/src/fortran/fmuls1.lo new file mode 100755 index 000000000..94b6aaeee --- /dev/null +++ b/modules/optimization/src/fortran/fmuls1.lo @@ -0,0 +1,12 @@ +# src/fortran/fmuls1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fmuls1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fprf2.f b/modules/optimization/src/fortran/fprf2.f new file mode 100755 index 000000000..b6e8df62f --- /dev/null +++ b/modules/optimization/src/fortran/fprf2.f @@ -0,0 +1,400 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fprf2(iflag,ntot,nv,io,zero,s2,eps,al,imp,u,eta,mm1,jc, + & ic,r,a,e,rr,xpr,y,w1,w2) +c + implicit double precision (a-h,o-z) + common /fprf2c/ u1,nc +C the dimension is mm1*mm1 for r + dimension al(ntot), jc(mm1), ic(mm1), a(mm1), e(mm1), r(*), + & rr(mm1), xpr(mm1), y(mm1), w1(mm1), w2(mm1) + dimension i5(1), d3(1), d4(1) +C +C ***** on entry ***** +C +C iflag=0-1 initialize on one subgradient (mu in) +C +C iflag=2 " " " " " " " +C and strive to enter by priority the +C points of the previous corral at the +C beginning of the iterations. +C +C iflag=3 initialize on the previous projection +C (with its corresponding corral) +C +C +C ***** on exit ***** +C +C iflag=0 normal end +C +C 1 old solution is already optimal +C +C 2 constraints non feasible +C +C 3 trying to enter a variable +C that is already in the corral +C +C 4 starting to loop +C +C +C +C +C imp > 5 one prints final information +C +C +C imp > 6 one prints information at each iteration +C +C +C imp > 7 one prints also +C +C - at each iteration the choleski matrix +C - and the initial information such as (pi,pj) ... +C +C +C +C +C +C **** begin **** +C +C prepare various data +C +C + iterpr = 0 + nt1 = ntot + 1 + itmax = 10 * ntot + deps = eps + incr = 0 + k00 = 1 + w1s = 0.d0 + w2s = 0.d0 + w12s = 0.d0 + gama = .99d0 + dzero = 10.d0 * zero +C initial printouts + if (imp .gt. 7) call n1fc1o(io,21,nt1,mm1,i3,i4,i5,deps,d2,a,r) +C +C initial point +C + 100 if (iflag .ne. 3) goto 110 + if (imp .gt. 6) call n1fc1o(io,22,nv,i2,i3,i4,jc,d1,d2,d3,d4) + j0 = nt1 + ps = u1 * (a(nt1)-deps) + ment = (nt1-1) * mm1 + do 103 k = 1,nv + jk = ment + jc(k) + 103 ps = ps + xpr(k)*r(jk) + if (ps .lt. s2) goto 107 + if (imp .gt. 0) call n1fc1o(io,23,i1,i2,i3,i4,i5,d1,d2,d3,d4) + iflag = 1 + return + 107 nv = nv + 1 + nc = nc + 1 + jc(nv) = j0 + iterpr = 1 + goto 300 + 110 if (iflag .le. 1) goto 140 +C save the corral of previous call + do 120 i = 1,nt1 + 120 ic(i) = 0 + do 130 k = 1,nv + jk = jc(k) + 130 ic(jk) = 1 + ic(nt1) = 1 +C initialize with one feasible gradient + 140 jc(1) = 1 + nv = 2 + nc = 1 + jc(2) = 0 + do 150 j = 2,nt1 + if (a(j) .gt. deps) goto 150 + jc(2) = j + 150 continue + if (jc(2) .gt. 0) goto 160 + if (imp .gt. 0) call n1fc1o(io,24,i1,i2,i3,i4,i5,d1,d2,d3,d4) + iflag = 2 + return + 160 j = jc(2) + rr(1) = 1.d0 + jj = (j-1)*mm1 + j + ps = 1.d0 + r(jj) + if (ps .gt. 0.d0) goto 170 + iflag = 3 + return + 170 rr(2) = dsqrt(ps) + r(2) = a(j) + do 180 i = 1,nt1 + 180 xpr(i) = 0.d0 + xpr(1) = deps - a(j) + xpr(2) = 1.d0 + u1 = 0.d0 + u2 = -r(jj) + if (imp .gt. 6) call n1fc1o(io,25,j,i2,i3,i4,i5,d1,d2,d3,d4) +C +C stopping criterion +C + 200 iterpr = iterpr + 1 + if (imp .gt. 6) call n1fc1o(io,26,nv,i2,i3,i4,i5,d1,d2,d3,xpr) + if (iterpr .le. itmax) goto 205 + if (imp .gt. 0) call n1fc1o(io,27,i1,i2,i3,i4,i5,d1,d2,d3,d4) + iflag = 4 + return + 205 s2 = (-deps)*u1 - u2 + if (s2 .le. eta) goto 900 + sp = gama * s2 +C first compute all the tests, +C and test with the corral of previous call + j0 = 0 + do 220 j = 2,nt1 + ps = u1 * (a(j)-deps) + do 210 k = 1,nv + jj = jc(k) + if (jj .eq. 1) goto 210 + j1 = max0(j,jj) + j2 = min0(j,jj) + jj = (j1-1)*mm1 + j2 + ps = ps + xpr(k)*r(jj) + 210 continue + y(j) = ps + if (iflag .ne. 2) goto 220 + if (ic(j) .ne. 1) goto 220 + if (ps .ge. sp) goto 220 + j0 = j + sp = ps + 220 continue + if (j0 .eq. 0) goto 240 + if (sp .ge. gama*s2) goto 240 + ps1 = dabs(u1*(deps-a(j0))) + do 230 k = 1,nv + j = jc(k) + if (j .eq. j0) goto 240 + if (j .eq. 1) goto 230 + j1 = max0(j0,j) + j2 = min0(j0,j) + jj = (j1-1)*mm1 + j2 + ps1 = ps1 + xpr(k)*dabs(u1*(2.d0*deps-a(j))+2.d0*y(j)-r(jj)) + 230 continue + ps1 = ps1 * 1000.d0 * dzero + if (sp .gt. s2-ps1) goto 240 + ic(j0) = 0 + goto 280 +C now the remaining ones + 240 j0 = 0 + sp = gama * s2 + do 260 j = 2,nt1 + if (iflag.eq.2 .and. ic(j).eq.1) goto 260 + if (y(j) .ge. sp) goto 260 + sp = y(j) + j0 = j + 260 continue + if (j0 .eq. 0) goto 290 + ps1 = dabs(u1*(deps-a(j0))) + do 270 k = 1,nv + j = jc(k) + if (j .eq. 1) goto 270 + j1 = max0(j0,j) + j2 = min0(j0,j) + jj = (j1-1)*mm1 + j2 + ps1 = ps1 + xpr(k)*dabs(u1*(2.d0*deps-a(j))+2.d0*y(j)-r(jj)) + 270 continue + ps1 = ps1 * 1000.d0 * dzero + if (sp .gt. s2-ps1) goto 290 + 280 nc = nc + 1 + nv = nv + 1 + jc(nv) = j0 + if (imp .gt. 6) call n1fc1o(io,28,j0,i2,i3,i4,i5,s2,sp,d3,d4) + goto 300 +C first set of optimality conditions satisfied + 290 if (u1 .ge. (-dble(float(nv)))*dzero) goto 900 + j0 = 1 + nv = nv + 1 + jc(nv) = 1 + if (imp .gt. 6) call n1fc1o(io,29,i1,i2,i3,i4,i5,s2,u1,d3,d4) +C +C augmenting r +C + 300 nv1 = nv - 1 + do 305 k = 1,nv1 + if (jc(k) .ne. j0) goto 305 + if (imp .gt. 0) call n1fc1o(io,30,j0,i2,i3,i4,i5,d1,d2,d3,d4) + iflag = 3 + return + 305 continue + j = jc(1) + j1 = max0(j,j0) + j2 = min0(j,j0) + jj = (j1-1)*mm1 + j2 + r(nv) = (a(j)*a(j0)+e(j)*e(j0)+r(jj)) / rr(1) + ps0 = r(nv) * r(nv) + if (nv1 .eq. 1) goto 330 + do 320 k = 2,nv1 + j = jc(k) + j1 = max0(j,j0) + j2 = min0(j,j0) + jj = (j1-1)*mm1 + j2 + ps = a(j)*a(j0) + e(j)*e(j0) + r(jj) + k1 = k - 1 + do 310 kk = 1,k1 + j1 = (kk-1)*mm1 + k + j2 = (kk-1)*mm1 + nv + 310 ps = ps - r(j1)*r(j2) + mek = k1*mm1 + nv + r(mek) = ps / rr(k) + 320 ps0 = ps0 + r(mek)*r(mek) + jj = (j0-1)*mm1 + j0 + ps0 = a(j0)*a(j0) + e(j0)*e(j0) + r(jj) - ps0 + if (ps0 .gt. 0.d0) goto 330 + iflag = 3 + return + 330 rr(nv) = dsqrt(ps0) + if (iterpr .le. 1) goto 400 + incr = 1 + k00 = nv +C +C solving the corral-system +C + 400 k = k00 + if (k .gt. nv) goto 430 + if (imp .gt. 7) call n1fc1o(io,31,nv,mm1,i3,i4,i5,d1,d2,rr,r) + 410 j = jc(k) + ps1 = a(j) + ps2 = e(j) + if (k .eq. 1) goto 420 + k1 = k - 1 + do 415 kk = 1,k1 + jj = (kk-1)*mm1 + k + ps0 = r(jj) + ps1 = ps1 - ps0*w1(kk) + 415 ps2 = ps2 - ps0*w2(kk) + 420 ps0 = rr(k) + w1(k) = ps1 / ps0 + w2(k) = ps2 / ps0 + k = k + 1 + if (k .le. nv) goto 410 +C two-two system + 430 k = 1 + if (incr .eq. 1) k = nv + 440 w1s = w1s + w1(k)*w1(k) + w2s = w2s + w2(k)*w2(k) + w12s = w12s + w1(k)*w2(k) + k = k + 1 + if (k .le. nv) goto 440 + det = w1s*w2s - w12s*w12s + ps2 = w2s*deps - w12s + ps1 = w1s - w12s*deps + 450 v1 = ps2 / det + v2 = ps1 / det + 460 u1 = deps - v1 + u2 = 1.d0 - v2 + if (nv .eq. nc+1) u1 = 0.d0 +C backward + y(nv) = (v1*w1(nv)+v2*w2(nv)) / rr(nv) + if (nv .eq. 1) goto 500 + do 480 l = 2,nv + k = nv - l + 1 + k1 = k + 1 + ps = v1*w1(k) + v2*w2(k) + mek = (k-1) * mm1 + do 470 kk = k1,nv + mej = mek + kk + 470 ps = ps - r(mej)*y(kk) + 480 y(k) = ps / rr(k) +C +C test for positivity +C + 500 continue + do 530 k = 1,nv + if (y(k) .le. 0.d0) goto 550 + 530 continue + do 540 k = 1,nv + 540 xpr(k) = y(k) + goto 200 +C interpolating between x and y + 550 teta = 0.d0 + k0 = k + do 560 k = 1,nv + if (y(k) .ge. 0.d0) goto 560 + ps = y(k) / (y(k)-xpr(k)) + if (teta .ge. ps) goto 560 + teta = ps + k0 = k + 560 continue + do 570 k = 1,nv + ps = teta*xpr(k) + (1.d0-teta)*y(k) + if (ps .le. dzero) ps = 0.d0 + 570 xpr(k) = ps + if (imp .le. 6) goto 600 + ps1 = 0.d0 + ps2 = 0.d0 + do 580 k = 1,nv + do 580 kk = 1,nv + j1 = max0(jc(k),jc(kk)) + j2 = min0(jc(k),jc(kk)) + jj = (j1-1)*mm1 + j2 + ps1 = ps1 + xpr(k)*xpr(kk)*r(jj) + ps2 = ps2 + y(k)*y(kk)*r(jj) + 580 continue +C +C compressing the corral +C + 600 nv = nv - 1 + incr = 0 + k00 = k0 + w1s = 0.d0 + w2s = 0.d0 + w12s = 0.d0 + l = jc(k0) + if (l .ne. 1) nc = nc - 1 + if (imp .gt. 6) call n1fc1o(io,32,k0,l,i3,i4,i5,y(k0),ps1,ps2,d4) + if (k0 .gt. nv) goto 400 + k1 = k0 - 1 + do 620 k = k0,nv + xpr(k) = xpr(k+1) + if (k0 .eq. 1) goto 620 + do 610 kk = 1,k1 + mek = (kk-1)*mm1 + k + 610 r(mek) = r(mek+1) + 620 jc(k) = jc(k+1) + xpr(nv+1) = 0.d0 + 630 mek = (k0-1)*mm1 + k0 + 1 + ps = r(mek) + ps12 = rr(k0+1) + ps0 = dsqrt(ps*ps+ps12*ps12) + ps = ps / ps0 + ps12 = ps12 / ps0 + rr(k0) = ps0 + if (k0 .eq. nv) goto 400 + k1 = k0 + 1 + mek01 = (k0-1) * mm1 + mek = k0 * mm1 + mekk = mek - mm1 + do 640 k = k1,nv + j1 = mekk + k + j2 = mek + k + r(j1) = ps*r(j1+1) + ps12*r(j2+1) + if (k .gt. k1) r(j2) = ps2 + 640 ps2 = (-ps12)*r(j1+1) + ps*r(j2+1) + r(j2+1) = ps2 + k0 = k0 + 1 + goto 630 +C +C *** finished *** +C + 900 iflag = 0 + do 930 j = 1,ntot + 930 al(j) = 0. + do 940 k = 1,nv + j = jc(k) - 1 + if (j .ne. 0) al(j) = xpr(k) + 940 continue + u = u1 + if (imp .le. 5) return + call n1fc1o(io,34,nc,nv,i3,i4,jc,s2,sp,u1,d4) + return + end diff --git a/modules/optimization/src/fortran/fprf2.lo b/modules/optimization/src/fortran/fprf2.lo new file mode 100755 index 000000000..0a62da22f --- /dev/null +++ b/modules/optimization/src/fortran/fprf2.lo @@ -0,0 +1,12 @@ +# src/fortran/fprf2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fprf2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/frdf1.f b/modules/optimization/src/fortran/frdf1.f new file mode 100755 index 000000000..a33eea3ee --- /dev/null +++ b/modules/optimization/src/fortran/frdf1.f @@ -0,0 +1,101 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine frdf1(prosca,n,ntot,ninf,kgrad, + & al,q,s,poids,aps,anc,mm1,r,e,ic,izs,rzs,dzs) +c + implicit double precision (a-h,o-z) + dimension al(ntot),q(*),poids(ntot),aps(ntot),anc(ntot), + & ic(mm1),s(n),izs(*),dzs(*),e(mm1),r(*) + external prosca + real rzs(*) +c +c this subroutine reduces a nonconvex bundle +c of size ntot in rn +c to a size no greater than ninf +c + if(ntot.le.ninf) go to 900 + if (ninf.gt.0) go to 100 +c +c pure gradient method +c + ntot=0 + kgrad=0 + go to 900 +c +c reduction to the corral + 100 nt1=0 + do 150 j=1,ntot + if(al(j).eq.0.d0 .and. poids(j).ne.0.d0) go to 150 + nt1=nt1+1 + ic(nt1)=j + if(j.eq.nt1) go to 130 + nj=n*(j-1) + nn=n*(nt1-1) + do 110 i=1,n + nn=nn+1 + nj=nj+1 + 110 q(nn)=q(nj) + al(nt1)=al(j) + poids(nt1)=poids(j) + aps(nt1)=aps(j) + anc(nt1)=anc(j) + e(nt1+1)=e(j+1) + 130 if (poids(j).eq.0.) kgrad=nt1 + nn=nt1*mm1+1 + nj=j*mm1+1 + do 140 k=1,nt1 + njk=nj+ic(k) + nn=nn+1 + 140 r(nn)=r(njk) + 150 continue + ntot=nt1 + if(ntot.le.ninf) go to 900 +c +c corral still too large +c save the near +c + call prosca (n,s,s,ps,izs,rzs,dzs) + e(2)=1.d0 + z=0.d0 + z1=0.d0 + z2=0.d0 + do 370 k=1,ntot + z1=z1+al(k)*aps(k) + z2=z2+al(k)*anc(k) + 370 z=z+al(k)*poids(k) + aps(1)=z1 + anc(1)=z2 + poids(1)=z + r(mm1+2)=ps + if (ninf.gt.1) go to 400 + ntot=1 + kgrad=0 + do 380 i=1,n + 380 q(i)=s(i) + go to 900 +c save the gradient + 400 nn=(kgrad-1)*n + do 470 i=1,n + nj=n+i + nn=nn+1 + q(nj)=q(nn) + 470 q(i)=s(i) + call prosca(n,q(n+1),s,ps,izs,rzs,dzs) + e(3)=1.d0 + r(2*mm1+2)=ps + call prosca (n,q(n+1),q(n+1),ps,izs,rzs,dzs) + r(2*mm1+3)=ps + aps(2)=0.d0 + anc(2)=0.d0 + poids(2)=0.d0 + kgrad=2 + ntot=2 + 900 return + end diff --git a/modules/optimization/src/fortran/frdf1.lo b/modules/optimization/src/fortran/frdf1.lo new file mode 100755 index 000000000..74619b8ed --- /dev/null +++ b/modules/optimization/src/fortran/frdf1.lo @@ -0,0 +1,12 @@ +# src/fortran/frdf1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/frdf1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fremf2.f b/modules/optimization/src/fortran/fremf2.f new file mode 100755 index 000000000..cbdb185bc --- /dev/null +++ b/modules/optimization/src/fortran/fremf2.f @@ -0,0 +1,88 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fremf2 (prosca,iflag,n,ntot,nta,mm1,p,alfa,e,a,r, + 1 izs,rzs,dzs) +c + implicit double precision (a-h,o-z) + external prosca + dimension p(*),alfa(ntot),izs(*),dzs(*),e(mm1),a(mm1),r(*) + real rzs(*) + + +c +c cette subroutine remplit les donnees pour fprf2 +c (produits scalaires et 2 contraintes lineaires) +c +c de 1 a ntot +1 si iflag=0 +c de nta+1 +1 a ntot +1 sinon +c +c (le +1 est du a l'ecart, place en premier) +c +c p contient les opposes des gradients a la queue leu leu +c -g(1), -g(2),..., -g(ntot) soit ntot*n coordonnees +c + nt1=ntot+1 + nta1=nta+1 + if(iflag.gt.0) go to 50 +c +c remplissage des anciennes donnees +c (produits scalaires, ecart et contrainte d'egalite) +c + do 10 j=1,ntot + jj=(j-1)*mm1+1 + 10 r(jj)=0.d0 + a(1)=1.d0 + e(1)=0.d0 + if (nta1.eq.1) go to 50 + do 30 j=2,nta1 + e(j)=1.d0 + nj=(j-2)*n + mej=(j-1)*mm1 + do 30 i=2,j + ni=(i-2)*n +c +c produit scalaire de g(i-1) avec g(j-1) +c pour j-1=1,nta et i-1=1,j-1 +c + call prosca (n,p(ni+1),p(nj+1),ps,izs,rzs,dzs) + nij=mej+i +c le produit scalaire ci-dessus va dans r((j-1)*mm1+i) + r(nij)=ps + 30 continue +c +c + 50 nta2=nta+2 +c +c remplissage des nouvelles donnees +c + if (nta2.gt.nt1) go to 100 + do 70 kk=nta2,nt1 + mekk=(kk-1)*mm1 + e(kk)=1.d0 + r(mekk+1)=0.d0 + nj=(kk-2)*n + do 70 i=2,kk + ni=(i-2)*n +c +c produit scalaire de g(kk-1) avec g(i-1) +c pour kk-1=nta+1,ntot et i-1=1,kk-1 +c + call prosca (n,p(ni+1),p(nj+1),ps,izs,rzs,dzs) + nij=mekk+i +c le produit scalaire ci-dessus va dans r((kk-1)*mm1+i) + 70 r(nij)=ps +c +c remplissage de la contrainte d'inegalite +c (tout entiere sauf l'ecart) +c + do 80 i=2,nt1 + 80 a(i)=dble(alfa(i-1)) + 100 return + end diff --git a/modules/optimization/src/fortran/fremf2.lo b/modules/optimization/src/fortran/fremf2.lo new file mode 100755 index 000000000..dea697a96 --- /dev/null +++ b/modules/optimization/src/fortran/fremf2.lo @@ -0,0 +1,12 @@ +# src/fortran/fremf2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fremf2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/fuclid.f b/modules/optimization/src/fortran/fuclid.f new file mode 100755 index 000000000..01be630c4 --- /dev/null +++ b/modules/optimization/src/fortran/fuclid.f @@ -0,0 +1,19 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine fuclid (n,x,y,ps,izs,rzs,dzs) +c + implicit double precision (a-h,o-z) + dimension x(n),y(n),izs(*),dzs(*) + real rzs(*) + ps=0.d0 + do 10 i=1,n + 10 ps=ps+x(i)*y(i) + return + end diff --git a/modules/optimization/src/fortran/fuclid.lo b/modules/optimization/src/fortran/fuclid.lo new file mode 100755 index 000000000..bb8a5769f --- /dev/null +++ b/modules/optimization/src/fortran/fuclid.lo @@ -0,0 +1,12 @@ +# src/fortran/fuclid.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fuclid.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/gcbd.f b/modules/optimization/src/fortran/gcbd.f new file mode 100755 index 000000000..dac4aee0c --- /dev/null +++ b/modules/optimization/src/fortran/gcbd.f @@ -0,0 +1,256 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1985 - INRIA - F. BONNANS +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine gcbd(indgc,simul,nomf,n,x,f,g,imp,io,zero, + &napmax,itmax,epsf,epsg,epsx,df0,binf,bsup,nfac, + &vect,nvect,ivect,nivect,izs,rzs,dzs) +c!but +c algorithme de minimisation d une fonction reguliere sous +c contraintes de borne +c!methode +c methode de bfgs a memoire limitee + projection +c!sous programmes (modulopt) +c proj rlbd majysa majz calbx gcp relvar bfgsd shanph +c!liste d' appel +c indgc indicateur de gcbd es +c en entree =1 standard +c =2 dh et indic initialises au debut de trav et itrav +c ifac,f,g initialises +c en sortie +c si < 0 incapacite de calculer un point meilleur que le point initial +c si = 0 arret demande par l utilisateur +c si > 0 on fournit un point meilleur que le point de depart +c = -14 insuffisance memoire +c = -13 indgc non egal a zero ou 1 en entree +c = -12 zero,epsg ou df0 non strict. positifs +c = -11 n,napmax,itmax ou io non strict. positifs +c < -10 parametres d entree non convenables +c = -6 arret lors du calcul de la direction de descente et iter=1 +c = -5 arret lors du calcul de l approximation du hessien iter=1 +c = -3 anomalie de simul : indic negatif en un point ou +c f et g ont ete precedemment calcules +c = -2 echec de la recherche lineaire a la premiere iteration +c = -1 f non definie au point initial +c = 1 arret sur epsg +c = 2 epsf +c = 3 epsx +c = 4 napmax +c = 5 itmax +c = 6 pente dans la direction opposee au gradient trop petite +c = 7 arret lors du calcul de la direction de descente +c = 8 arret lors du calcul de l approximation du hessien +c = 10 arret par echec de la recherche lineaire , cause non precisee +c = 11 idem avec indsim < 0 +c = 12 un pas trop petit proche d un pas trop grand +c ceci peut resulter d une erreur dans le gradient +c = 13 trop grand nombre d appels dans une recherche lineaire +c +c simul subroutine permettant de calculer f et g (norme modulopt) +c n dim de x e +c x variables a optimiser (controle) es +c f valeur du critere s +c g gradient de f s +c imp si =0 pas d impression +c 1 impressions en debut etfin dexecution +c 2 3 lignes a chaque iteration +c >=3 nombreuses impressions e +c io numero fichier sortie e +c zero proche zero machine e +c napmax nombre maximum d appels de simul e +c itmax nombre maximum d iterations de gcbd e +c epsf critere arret sur f e +c epsg arret si sup a norm2(g+)/n e +c epsx vect dim n precision sur x e +c df0>0 decroissance f prevue e +c binf,bsup bornes inf,sup,de dim n e +c nfac nombre de variables non bloquees a l optimum s +c vect,ivect vecteurs de travail de dim nvect,nivect +c izs,rzs,dzs : cf normes modulopt es +c +c! +c signification de quelques variables internes +c +c {y}={g1}-{g0} l (locale) +c {s}={x1}-{x0} l +c {z}=[b]*{s}. [b] est une estimation de hessien l +c ys=<y>*{s} l +c zs=<z>*{s} l +c diag approximation diagonale du hessien es +c si indgc=0 diag initialise a ******************* +c puis remis a jour par bfgs diagonal +c nt: le nombre de deplacements pris en compte l +c index(nt) repere les vect y,s,z l +c wk1,wk2: vecteurs de travail de dim n l +c ibloc vect dim n ; si x(i) est bloque, ibloc(i)=iteration de blocage ; +c si x(i) est libre, ibloc(i)=-1*(iteration de deblocage) +c irit: irit=1, si relachement de vars a l'iter courante, 0 sinon +c ired: ired=1 decision de redemarrage, 0 sinon +c alg(1)=param +c alg(2)=condmax +c alg(6)=eps +c alg(9)=tetaq ( critere de redemarrage) +c ialg(1) correction de powell sur y si (y,s)trop petit +c 0: sans correction de powell +c 1: avec correction +c ialg(2) mise a jour de diag par bfgsd +c 0: pas de remise a jour +c 1: remise a jour de diag par bfgsd +c ialg(3) mise a l'echelle par methode de shanno-phua +c 0: pas de mise a l'echelle +c 1: mise a l'echelle a toutes les iterations +c 2: mise a l'echelle a la 2ieme iteration seulement +c ialg(4): memorisation pour choix iterations +c 0: sans memorisation +c 1: avec memorisation +c ialg(5): memorisation par variable +c 0: sans memorisation +c 1: avec memorisation +c ialg(6): choix des iterations de relachement +c 1: relachement a toutes les iterations +c 2: relachement si decroissance g norme gradient +c 10: relachement si decroissance critere % iter.initcycle +c 11: relachement si decroissance critere % decroissance cycle +c ialg(7): choix des variables a relacher +c 1: methode de bertsekas modifiee +c ialg(8): choix de la direction de descente +c 3: qn sans memoire: nt derniers deplacements +c 4: redemarrage sans accumulation +c 5: redemarrage avec accumulation +c ialg(9): critere de redemarrage +c 2: redemarrage si fact. ou defact. +c 10: decroissance critere % decroissance iter_init du cycle +c 11: decroissance critere % decroissance totale du cycle +c 12: diminution de znglib d un facteur alg(9)=tetaq +c eps0 sert a partitionner les variables +c ceps0 utilise dans le calcul de eps0 +c izag nombre d iterations min pendant lesquelles une var reste bloquee +c nap nombre d appels de simul +c iter iteration courante +c ind indicateur de simul +c icv memoire entree indgc +c np param utilise pour la gestion de vect. nb de vect courant. +c lb param utilise pour la gestion de vect. 1er place libre. +c nb param utilise pour la gestion de vect. +c nb=2 si l'algorithme utilise est qn sans memoire +redem +pas acc +c nb=1 sinon +c + implicit double precision (a-h,o-z) + real rzs(*) + double precision dzs(*) + dimension x(n),g(n),binf(n),bsup(n),epsx(n) + dimension izs(*),vect(nvect),ivect(nivect),ialg(15),alg(15) + character*6 nomf + character bufstr*(4096) + external simul +c +c initialisation des parametres + nt=2 + alg(1)= 1.0d-5 + alg(2)= 1.0d+6 + alg(6)=.50d+0 + alg(9)=.50d+0 +c + ialg(1)=1 + ialg(2)=0 + ialg(3)=2 + ialg(4)=0 + ialg(5)=0 + ialg(6)=2 + ialg(7)=1 + ialg(8)=4 + ialg(9)=12 +c +c---- initial printing + if(imp.gt.0) then + write (bufstr,900) + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + write (bufstr,901) n + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + write (bufstr,902) df0 + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + write (bufstr,903) epsg + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + write (bufstr,904) itmax + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + write (bufstr,905) napmax + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + write (bufstr,906) imp + call basout(io_out, io, bufstr(1:lnblnk(bufstr))) + endif +900 format (" gcdb: entry point") +901 format (5x,"dimension of the problem (n):",i6) +902 format (5x,"expected decrease for f (df0):",d9.2) +903 format (5x,"relative precision on g (epsg):",d9.2) +904 format (5x,"maximal number of iterations (itmax):",i6) +905 format (5x,"maximal number of simulations (napmax):",i6) +906 format (5x,"printing level (imp):",i4) +c +c verification des entrees + ii=min(n,napmax,itmax) + if(ii.gt.0)go to 10 + indgc=-11 + if(imp.gt.0) then + write(bufstr,123) indgc + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + +123 format(' gcbd : return with indgc=',i8) + return +10 aa=min(zero,epsg,df0) + do 11 i=1,n +11 aa=min(aa,epsx(i)) + if(aa.gt.0.0d+0) goto 12 + indgc=-12 + if(imp.gt.0) then + write(bufstr,123) indgc + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + return +12 continue +c +c decoupage de la memoire + ny=1 + ns=nt*n+ny + nz=nt*n+ns + nys=nt*n+nz + nzs=nt+nys + nd=nt+nzs + ng=n+nd + nx2=n+ng + ndir=n+nx2 + ndiag=n+ndir + nfin=n+ndiag +c + if(nfin.gt.nvect) then + write(bufstr,1000) nfin,nvect + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) +1000 format (' gcbd:insufficient memory; nvect=',i5,'should be:', + & i5) + indgc=-14 + return + endif +c + nindic=1 + nindex=n+nindic + nfin=nt+nindex + if(nfin.gt.nivect) then + write(bufstr,2000)nfin,nivect + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) +2000 format (' gcbd:insufficient memory; nivect=',i5,'should be:', + & i5) + indgc=-14 + return + endif +c + call zgcbd(simul,n,binf,bsup,x,f,g,zero,napmax,itmax,indgc,ivect + &(nindic),nfac,imp,io,epsx,epsf,epsg,vect(ndir),df0,vect(ndiag), + &vect(nx2),izs,rzs,dzs,vect(ny),vect(ns),vect(nz),vect(nys), + &vect(nzs),nt,ivect(nindex),vect(nd),vect(ng),alg,ialg,nomf) + return + end diff --git a/modules/optimization/src/fortran/gcbd.lo b/modules/optimization/src/fortran/gcbd.lo new file mode 100755 index 000000000..a948e25c7 --- /dev/null +++ b/modules/optimization/src/fortran/gcbd.lo @@ -0,0 +1,12 @@ +# src/fortran/gcbd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gcbd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/gcp.f b/modules/optimization/src/fortran/gcp.f new file mode 100755 index 000000000..3837683a2 --- /dev/null +++ b/modules/optimization/src/fortran/gcp.f @@ -0,0 +1,119 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine gcp(n,index,indic,np,nt,y,s,z,ys,zs,diag,b,x,d,g,eps) +c +c methode de gradient preconditionne appliquee a l'equation +c [a]*{x}={b}. ici [a] est definie par les vecteurs ({y}(i), +c {s}(i), {z}(i), i=1,np). +c + implicit double precision (a-h,o-z) + dimension x(n),b(n),y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt),diag(n) + dimension g(n),d(n) + integer index(nt),indic(n) +c +c initialisation + eps0=1.e-5 + eps1=1.e-5 + do 100 i=1,n + if(indic(i).gt.0) go to 100 + x(i)=-b(i)/diag(i) +100 continue +c + call calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,g) + do 110 i=1,n + if(indic(i).gt.0) go to 110 + g(i)=g(i)+b(i) +110 continue +c +c ---------- +c iteration 1 +c ------test de convergence + s0=0 + do 120 i=1,n + if(indic(i).gt.0) go to 120 + s0=s0+g(i)*g(i)/diag(i) +120 continue + if(s0.lt.1.0d-18) return + s1=s0 +c ------recherche de la direction de descente + do 130 i=1,n + if(indic(i).gt.0) go to 130 + d(i)=-g(i)/diag(i) +130 continue +c +c ------step length + dg=0. + do 135 i=1,n + if(indic(i).gt.0) go to 135 + dg=dg+d(i)*g(i) +135 continue + call calbx(n,index,indic,nt,np,y,s,ys,z,zs,d,diag,g) + d2a=0 + do 140 i=1,n + if(indic(i).gt.0) go to 140 + d2a=d2a+d(i)*g(i) +140 continue +c + ro=-dg/d2a + do 150 i=1,n + if(indic(i).gt.0) go to 150 + x(i)=x(i)+ro*d(i) +150 continue + call calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,g) + do 170 i=1,n + if(indic(i).gt.0) go to 170 + g(i)=g(i)+b(i) +170 continue +c +c iteration k + iter=0 + itmax=2*np +10 iter=iter +1 + if(iter.gt.itmax)return +c ------test de convergence + s2=0 + do 200 i=1,n + if(indic(i).gt.0) go to 200 + s2=s2+g(i)*g(i)/diag(i) +200 continue + if((s2/s0).lt.eps) return +c ------recherche de la direction de descente + beta=s2/s1 + do 210 i=1,n + if(indic(i).gt.0) go to 210 + d(i)=-g(i)/diag(i)+beta*d(i) +210 continue + s1=s2 +c +c -----step length + dg=0. + do 215 i=1,n + if(indic(i).gt.0) go to 215 + dg=dg+d(i)*g(i) +215 continue + call calbx(n,index,indic,nt,np,y,s,ys,z,zs,d,diag,g) + d2a=0. + do 220 i=1,n + if(indic(i).gt.0) go to 220 + d2a=d2a+d(i)*g(i) +220 continue +c + ro=-dg/d2a + do 230 i=1,n + if(indic(i).gt.0) go to 230 + x(i)=x(i)+ro*d(i) +230 continue + call calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,g) + do 240 i=1,n + if(indic(i).gt.0) go to 240 + g(i)=g(i)+b(i) +240 continue + go to 10 + end diff --git a/modules/optimization/src/fortran/gcp.lo b/modules/optimization/src/fortran/gcp.lo new file mode 100755 index 000000000..4e882788a --- /dev/null +++ b/modules/optimization/src/fortran/gcp.lo @@ -0,0 +1,12 @@ +# src/fortran/gcp.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/gcp.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icscof.f b/modules/optimization/src/fortran/icscof.f new file mode 100755 index 000000000..3864ce178 --- /dev/null +++ b/modules/optimization/src/fortran/icscof.f @@ -0,0 +1,61 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=ICSCOF,SSI=0 +c + subroutine icscof(ico,ntob,nex,nob,yob,ob,cof) +c ce programme est appele par les macros icsua (ico=1) et icsuq +c (ico=2) de icse.bas pour le calcul initial des coefficients +c de ponderation du cout + implicit double precision (a-h,o-z) + dimension yob(nob,ntob),ob(nex,ntob,nob),cof(nob,ntob) +c +c en entree:(pour ico=2) +c +c yob double precision (nob,ntob) +c yob=obs*ytob,avec obs(nob,ny) matrice d'observation et +c ytob(ny,ntob) valeurs calculees de l'etat aux instants +c de mesure +c +c ob double precision (nex,ntob,nob) +c mesures +c +c en sortie: +c +c cof double precision (nob,ntob) +c coefficients de ponderation du cout +c + do 5 i=1,nob + do 5 j=1,ntob +5 cof(i,j)=0.0d+0 +c si ico=1 (macro icsua:ponderation "arithmetique" du cout) +c les coefficients de ponderation du cout cof(nob,ntob) +c sont:cof(i,j)=nex/(|ob(1,j,i)|+..+|ob(nex,j,i)|) + if (ico.eq.1) then + do 10 i=1,nob + do 10 j=1,ntob + do 10 k=1,nex +10 cof(i,j)=cof(i,j)+abs(ob(k,j,i)) + do 15 i=1,nob + do 15 j=1,ntob +15 cof(i,j)=dble(nex)/cof(i,j) +c si ico=2 (macro icsuq:ponderation "quadratique" du cout) +c les coefficients de ponderation du cout cof(nob,ntob) sont: +c cof(i,j)=1/2*[(yob(i,j)-ob(1,j,i))**2+..+(yob(i,j)-ob(nex,j,i))**2] + else + do 20 i=1,nob + do 20 j=1,ntob + do 20 k=1,nex +20 cof(i,j)=cof(i,j)+(yob(i,j)-ob(k,j,i))**2 + do 25 i=1,nob + do 25 j=1,ntob +25 cof(i,j)=0.50d+0/cof(i,j) + endif + return + end diff --git a/modules/optimization/src/fortran/icscof.lo b/modules/optimization/src/fortran/icscof.lo new file mode 100755 index 000000000..4e481c7d8 --- /dev/null +++ b/modules/optimization/src/fortran/icscof.lo @@ -0,0 +1,12 @@ +# src/fortran/icscof.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icscof.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icse.f b/modules/optimization/src/fortran/icse.f new file mode 100755 index 000000000..efe3ffbcb --- /dev/null +++ b/modules/optimization/src/fortran/icse.f @@ -0,0 +1,770 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1987 - INRIA - F. BONNANS +c Copyright (C) 1987 - INRIA - G. LAUNAY +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine icse(ind,nu,u,co,g,itv,rtv,dtv,icsef,icsec2,icsei) +c!but +c Le logiciel ICSE est un outil de resolution de problemes de +c CONTROLE OPTIMAL de systemes decrits par des equations +c differentielles ou algebrico-differentielles, NON LINEAIRES. +c Dans la mesure ou dans la methode d'integration qu'il utilise +c est inconditionnellement stable,il peut aussi etre utilise pour +c resoudre des problemes de controle d'EQUATIONS AUX DERIVEES +c PARTIELLES DYNAMIQUES (reaction-diffusion, par exemple), ou +c plus generalement pour controler des systemes raides. +c Le controle se decompose en une partie independante du temps et +c une partie dependante du temps.Cette structure permet a +c l'utilisateur de resoudre facilement les problemes +c d'IDENTIFICATION DE PARAMETRES d'un systeme dynamique par des +c methodes de MOINDRES CARRES. Diverses facilites sont d'ailleurs +c prevues pour ce cas. +c Dans le cas d'un SYSTEME LINEAIRE,l'integration de l'etat et de +c l'etat adjoint sont effectuees de maniere a tirer parti de la +c linearite de l'equation. +c +c Resolution de problemes de controle ou d'identification de +c parametres de systemes dynamiques du type: +c 0=fi(t,y,u),i<=nea et dyj/dt=fj(t,y,u),nea<j<=ny pour t>=t0 +c et y(t0)=y0 , en notant ny la dimension de l'etat y et +c fk la keme composante de la fonction f +c On effectue un certain nombre (nex) d'experiences identiques +c au cours desquelles certaines donnees sont mesurees. +c Le critere a minimiser est de la forme c(tob,ytob,ob) avec: +c tob(ntob) :instants de mesure +c ytob(ny,ntob) :valeurs de l'etat aux instants de mesure +c ob(nex,ntob,nob):mesures +c L'equation d'etat est discretisee par la methode +c de Crank-Nicolson. +c Le gradient du cout est calcule en utilisant l'etat adjoint du +c systeme discretise. +c +c! DESCRIPTION FORMELLE DES PROBLEMES DE CONTROLE CONSIDERES +c L'equation du systeme est de la forme +c 0 = fi(t,y(t),uc,uv(t)) , i<=nea, +c dyi(t)/dt = fi(t,y(t),uc,uv(t)) , i> nea, +c et +c t0<= t <=tf , y(t0)=y0 . +c avec : +c y(t ) : etat du systeme, +c uc : partie du controle independante du temps +c (controle constant), +c uv : partie du controle dependante du temps +c (controle variable) +c t0, tf : instant initial et instant final, +c y0 : etat initial. Il est soit fixe,soit fonction +c du controle [y0=ei(uc,uv)] +c +c Le critere a minimiser est de la forme : +c +c tp +c ____ +c \ +c | c2(ti,y(ti),uc) . +c /___ +c ti =t1 +c +c Sont resolus, soit des problemes sans contraintes, soit des +c problemes comportant des contraintes de borne sur le controle.On +c peut aussi utiliser ICSE pour resoudre des problemes comportant +c des contraintes sur l'etat, en traitant ces contraintes par +c penalisation ou lagrangien augmente [Ber,82]. +c Les fonctions f,c1,c2,ei et leurs derivees partielles sont +c fournies par l'utilisateur sous forme de subroutines Fortran. +c +c +c +c! OUTILS POUR L'IDENTIFICATION DE PARAMETRES +c Le probleme de l'identification de parametres (ou d'ajustement +c de parametres a des mesures) a les caracteristiques suivantes : +c le critere est fonction seulement de mesures faites a certains +c instants et des valeurs de l'etat a ces instants.Seule la seconde +c partie du cout intervient donc.Les mesures peuvent avoir ete +c obtenues lors de plusieurs experiences.En general,le critere +c est du type MOINDRES CARRES associe a une OBSERVATION LINEAIRE +c .Autrement dit, il est de la forme +c +c nex ntob +c ____ ____ 2 +c 1 \ \ || || +c - | | || obs*y(ti) - z(iex,ti) || , +c 2 /___ /___ || || +c iex=1 ti =t1 +c +c ou obs est la matrice d'observation et z(iex,ti) represente +c l'ensemble des mesures faites lors de l'experience iex, a +c l'instant ti.Dans ce cas,l'utilisateur n'a aucune modification a +c a apporter a la subroutine de calcul de cout de l'exemple de +c demonstration. +c!liste d'appel: +c icse(ind,nu,u,co,g,itv,rtv,dtv) +c en entree: +c +c ind entier egal a 2,3,ou4 +c +c nu entier +c dimension du vecteur des parametres +c +c u double precision (nu) +c vecteur des parametres +c +c en sortie: +c +c co double precision +c cout +c +c g double precision (nu) +c gradient de la fonction de cout c +c +c itv entier (nitv) +c tableau de travail entier +c +c rtv reel (nrtv) +c tableau de travail reel +c +c dtv double precision (ndtv) +c tableau de travail double precision +c +c!subroutines utilisees +c Linpack :dadd,daxpy,dcopy,dmmul,dnrm2,dscal,dset, +c dgefa,dgesl +c :icse0,icse1,icse2,icscof,icsef,icsei +c common/nird/nitv,nrtv,ndtv +c!utilisation +c +c Le probleme a traiter doit etre defini par 3 routines +c fortran ecrites par l'utilisateur : +c +c -Second membre de l'equation d'etat : +c icsef(indf,t,y,uc,uv,f,fy,fu,b,itu,dtu, +c & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, +c & itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c Parametres d'entree : +c indf : vaut 1,2,3 suivant qu'on veut calculer f,fy,fu +c t : instant courant +c y(ny) : etat a un instant donne +c uc(nuc) : controle independant du temps +c uv(nuv) : controle dependant du temps, a l'instant t +c b(ny) : terme constant dans le cas lineaire quadratique +c Parametres de sortie : +c indf : >0 si le calcul s'est correctement effectue,<=0 +c sinon +c f(ny) : second membre +c fy(ny,ny): jacobien de f par rapport a y +c fu(ny,nuc+nuv) : derivee de f par rapport au controle +c Tableaux de travail reserves a l'utilisateur : +c itu(nitu): tableau entier +c dtu(ndtu): tableau double precision +c (nitu et ndtu sont initialises par le common icsez). +c +c -Cout ponctuel : +c icsec2(indc,nu,tob,obs,cof,ytob,ob,u,c2,c2y,g,yob,d,itu,dtu, +c & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, +c & itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c Parametres d'entree : +c indc : 1 si on desire calculer c2,2 si on desire +c calculer c2y,c2u +c tob : instants de mesure +c obs : matrice d'observation +c cof : coefficients de ponderation du cout +c ytob : valeur de l'etat aux instants d'observation +c ob : mesures +c u(nu) : controle.Le controle variable est stocke a la +c suite du controle suite du constant. +c Parametres de sortie : +c indc : comme pour icsec1 +c c2 : cout +c c2y(ny,ntob) : derivee de c2 par rapport a y +c g(nu) : derivee de c2 par rapport a u +c +c -Etat initial (s'il est variable) +c icsei(indi,nui,ui,y0,y0ui,itu,dtu, +c & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, +c & itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c Parametres d'entree : +c indi : 1 si on desire calculer y0, 2 si on desire +c calculer y0ui +c nui : dimension du tableau ui defini ci-dessous, +c ui : partie du controle intervenant dans l'etat initial, +c determinee par iu;vaut uc,uv,ou [uc,uv]. +c +c Parametres de sortie : +c indc : >0 si le calcul s'est correctement effectue,<=0 +c sinon, +c y0 : etat initial, +c y0ui : derivee de l'etat initial par rapport au controle. +c +c +c +c!vue d'ensemble +c Pour utiliser la subroutine icse, il faut disposer d'un +c optimiseur (code d'implementation d'un algorithme d'optimisation) +c a la norme MODULOPT.Il faut ensuite ecrire le programme +c principal, constitue de quatre parties : +c 1. Initialisation des variables du common icsez, +c 2. Initialisation des tableaux itv et dtv et du common nird, +c 3. Appel de l'optimiseur, +c 4. Traitement des resultats. +c +c +c 1. INITIALISATION DU COMMON ICSEZ +c common/icsez/t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, +c itmx,nex,nob,ntob,ntobi,nitu,ndtu +c +c Liste des variables a initialiser : +c t0 : instant initial +c tf : instant final +c dti : premier pas de temps +c dtf : second pas de temps +c ermx : test d'arret absolu sur la valeur du second membre +c dans la resolution de l'equation d'etat +c iu(5) : tableau parametrant le probleme : seuls iu(1:3) +c sont utilises. +c iu(1)=1 si l'etat initial depend du controle constant +c 0 sinon +c iu(2)=1 si l'etat initial depend du controle variable +c 0 sinon +c iu(3)=1 si le second membre depend du controle constant, +c 0 sinon +c +c nuc : dimension du controle constant. +c nuv : dimension du controle variable a un instant donne. +c ilin : indicateur de linearite +c nti : nombre de pas de temps correspondant a dti (premier +c pas de temps) +c ntf : nombre de pas de temps correspondant a dtf (second +c pas de temps) +c ny : dimension de l'etat a un instant donne +c nea : nombre d'equations algebriques (eventuellement nul) +c itmx : nombre maximal d'iterations dans la resolution +c de l'equation d'etat discrete a un pas de temps +c donne +c nex : nombre d'experiences effectuees +c nob : dimension du vecteur des mesures pour une +c experience donnee en un instant donne +c ntob : nombre d'instants de mesure pour une experience donnee +c ntobi : nombre d'instants de mesure correspondant a dti +c (premier pas de temps) +c nitu : longueur de itu,tableau de travail entier reserve +c a l'utilisateur +c ndtu : longueur de dtu, tableau de travail double +c precision reserve a l'utilisateur +c u(nu) : parametres initiaux +c y0(ny) : etat initial +c tob(ntob) : instants de mesure +c binf(nu) : borne inferieures sur les parametres +c bsup(nu) : borne superieures sur les parametres +c obs(nob,ny) : matrice d'observation +c +c Bien noter que +c nu = nuc + nuv*(nti+ntf+1), +c nui= iu(1)*nuc+ui(2)*nuv*(nti+ntf+1) +c et que les dimensions suivantes peuvent etre nulles : +c nuc,nuv,ntf,nea. +c +c +c 2 INITIALISATION DES TABLEAUX ENTIER ET DOUBLE PRECISION. +c Le tableau itv (entier) contient le tableau : +c itu dimension nitu : reserve a l'utilisateur, +c le reste du tableau etant reserve au systeme ICSE. +c +c Le tableau dtv (reel double precision) contient les tableaux : +c dtu dimension ndtu : reserve a l'utilisateur, +c y0 ny : etat initial, +c tob ntob : instants d'observation, +c obs nob,ny : matrice d'observation, +c ob nex,ntob,nob : observations (mesures), +c ech nu : coefficients de mise a l'echelle de +c u, +c cof nob,ntob : coefficients de ponderation du +c cout, +c +c Les dimensions nitu et ndtu sont passees par le common icsez, +c nitv et ndtv sont passees par le common nird. +c +c +c! +c Copyright INRIA + implicit double precision (a-h,o-z) + real rtv + dimension u(nu),g(nu),itv(*),rtv(*),dtv(*),iu(5) + external icsef,icsec2,icsei + character bufstr*(4096) +c + common/icsez/ t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + &itmx,nex,nob,ntob,ntobi,nitu,ndtu + common/nird/nitv,nrtv,ndtv +c +c +c lui et nui servent quand l'etat initial depend du controle + if (iu(2).gt.0) lui=min(nu,1+nuc) + if (iu(1).gt.0) lui=1 + nui=iu(1)*nuc+iu(2)*nuv*(nti+ntf+1) +c +c decoupage de itv +c nitu longueur de itu tableau de travail entier reserve +c a l'utilisateur +c nitvt longueur de itvt tableau de travail entier de +c icse1 et icse2 +c + litu=1 + litvt=litu+nitu +c +c decoupage de dtv +c ndtu longueur de dtu tableau de travail double precision +c reserve a l'utilisateur +c ndtvt longueur de dtvt tableau de travail double precision +c de icse1 et icse2 +c + ldtu=1 + ly0=ldtu+ndtu + ltob=ly0+ny + lobs=ltob+ntob + lob=lobs+nob*ny + lech=lob+nex*ntob*nob + lcof=lech+nu +c ********************** Modif 88 + lb=lcof+nob*ntob + lfy=lb+ny + lfu=lfy+ny*ny + ludep=lfu+ny*(nuc+nuv) + lytot=ludep+nu + lf=lytot+ny*(nti+ntf) + ldtvt=lf+ny +c +c decoupage de itvt pour icse1 +c + lipv1=litvt + mitv1=lipv1+ny-1 +c +c decoupage de itvt pour icse2 +c + litob=litvt + lipv2=litob+ntob + mitv2=lipv2+ny-1 +c + mitv=max(mitv1,mitv2) +c +c decoupage de dtvt pour icse1 +c + ldm=ldtvt + lyold=ldm+ny*ny + lsmold=lyold+ny + lyint=lsmold+ny + lyerr=lyint+ny + ldif1=lyerr+ny + ldif2=ldif1+ny + ldif3=ldif2+ny + mdtv1=ldif3+ny-1 +c +c decoupage de dtvt pour icse2 +c + lytob=ldtvt + lc2y=lytob+ny*ntob + ly0u=lc2y+ny*ntob + ldmy=ly0u+ny*nu + lsmy=ldmy+ny*ny + loldmu=lsmy+ny*ny + ly=loldmu+ny*(nuc+nuv) + loldp=ly+ny + lp=loldp+ny + lp0=lp+ny + lgt=lp0+ny + lyob=lgt+max(nuc+nuv,nui) + ld=lyob+nob*ntob + mdtv2=ld+nob-1 +c + mdtv=max(mdtv1,mdtv2) + if (mitv.gt.nitv.or.mdtv.gt.ndtv) then + if (nitv+ndtv.gt.0) then + write (bufstr,8003) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,8004) mitv,mdtv + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + nitv=mitv + ndtv=mdtv + return + endif + do 10 i=1,nu + dtv(ludep+i-1)=u(i) + u(i)=dtv(lech+i-1)*u(i) +10 continue +c +c etat initial dependant du controle +c + if (iu(1).gt.0) then + indi=1 + call icsei(indi,nui,u(lui),dtv(ly0),dtv(ly0u), + & itv(litu),dtv(ldtu), + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) + if (indi.le.0) then + ind=indi + return + endif + endif +c +c appel de icse1 +c but +c icse1 resout les systemes dynamiques du type: +c 0=fi(t,y,u),i<=nea et dyj/dt=fj(t,y,u),nea<j<=ny pour t>=t0 +c et y(t0)=y0,en notant ny la dimension de l'etat y et +c fk la keme composante de la fonction f +c algorithme +c +c on procede a pas de temps constant:dt suivant deux echelles +c apres p pas,on a obtenu y_p valeur de l'etat a l'instant t_p +c soit y_p= (y_p(1),....,y_p(ny)) +c on veut calculer d(y_p)=y_p+1-y_p +c on note dt=t_(p+1)-t_p et I la matrice diagonale d'ordre ny +c dont les nea premiers coefficients diagonaux valent 0 et les +c autres 1. +c +c prediction: +c I*d(0,y_p)=dt f(t_p,y_p,u) +c +c correction: +c apres q corrections,on approche l'egalite souhaitee: +c (1/dt)I*d(q+1,y_p)=(1/2)[I*f(t_p,y_p,u)+f(t_p+1,y_p+d(q+1,y_p),u)] +c par: +c (1/dt)I*d(q+1,y_p)=(1/2)dfy(t_p,y_p,u)dqp+ +c (1/2)[I*f(t_p,y_p,u)+f(t_p+1,y_p+d(q+1,y_p),u)] +c en notant dqp=d(q+1,y_p)-d(q,y_p) +c soit par: +c ((1/dt)I-(1/2)dfy(t_p,y_p,u))dqp= +c (1/2)[I*f(t_p,y_p,u)+f(t_p+1,y_p+d(q,y_p),u)]-(1/dt)d(q,y_p) +c +c on retient d(y_p)=d(q0,y_p),ou q0 est le premier entier non nul +c tel que la norme l2 de:(1/2)[I*f(t_p,y_p,u)+ +c f(t_p+1,y_p+d(q0,y_p),u)]-(1/dt)d(q0,y_p) +c est inferieure a ermx +c de plus le nombre des corrections ne doit pas depasser: +c itmx +c +c remarque: +c L'erreur de discretisation est en O(dt**2) dans cette methode +c car l'erreur e commise a chaque pas dt est en (dt**3),et si +c l'on prend dt'=(1/s)*dt,l'erreur e' commise a chaque pas dt' +c est e'=(1/s**3)*e;alors pour atteindre tf=nt*dt,il faut +c nt pas dt,d'ou l'erreur E_nt=nt*O(dt**3),et il faut s*nt pas dt' +c d'ou l'erreur E'_nt=s*nt*e'=(1/s**2)*E_nt +c +c liste d'appel: +c icse1(ind,nu,u,icsef,y0,ytot,f,b,fy,fu,ipv1,dm,yold,smold,yint, +c yerr,dif1,dif2,dif3,itu,dtu, +c t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, +c itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c en entree: +c +c ind,u,nu figurent dans la liste d'appel de icse.fortran +c +c icsef nom de subroutine appelee par icse1 +c +c y0 double precision (ny) +c etat initial +c +c b double precision (ny) +c terme constant dans le cas lineaire quadratique +c +c en sortie: +c +c ytot double precision (ny,nti+ntf) +c valeurs calculees de l'etat aux pas de temps +c +c variables internes: +c +c f double precision (ny) +c stockage d'un calcul inutile des seconds membres +c (au cas ou l'on n'utiliserait pas indf) +c +c fy double precision (ny,ny) +c stockage de la derivee des seconds membres +c par rapport a l'etat +c +c fu double precision (ny,nuc+nuv) +c stockage de la derivee des seconds membres +c par rapport aux parametres +c +c ipv1 entier (ny) +c stockage du vecteur des indices des pivots donne par +c dgefa a chaque factorisation du jacobien +c +c dm double precision (ny,ny) +c matrices successives des systemes lineaires +c donnant l'etat discretise +c dm=(1/dt)I-(1/2)dfy +c +c yold double precision (ny) +c valeurs calculees successives de l'etat +c +c smold double precision (ny) +c stockage de I*f(yold) +c +c yint double precision (ny) +c yint=yold+dif1,ou dif1 est l'ecart donne +c par prediction +c +c yerr double precision (ny) +c yerr=yold+dif3,ou dif3 est l'ecart donne +c par correction +c +c dif1 double precision (ny) +c ecart donne par prediction +c +c dif2 double precision (ny) +c stockage des differences entre les ecarts +c consecutifs et des erreurs apres correction +c +c dif3 double precision (ny) +c ecart donne par correction +c +c itu entier (nitu) +c tableau de travail entier reserve a l'utilisateur +c +c dtu double precision (ndtu) +c tableau de travail double precision reserve +c a l'utilisateur +c +c enfin: +c +c kt entier +c indice de comptage des pas de temps +c +c dt double precision +c pas de temps,egal a dti ou a dtf +c +c dtinv double precision +c dtinv=1/dt +c +c t double precision +c instant(a l'instant t on travaille sur [t-dt,t]) +c +c told double precision +c instant anterieur a t:told=t-dt +c +c indf entier +c indicateur figurant dans la liste d'appel de icsef +c +c it entier +c indice de comptage des corrections +c +c err double precision +c norme l2 de dif2 +c + call icse1(ind,nu,u,icsef,dtv(ly0),dtv(lytot),dtv(lf),dtv(lb), + &dtv(lfy),dtv(lfu),itv(lipv1),dtv(ldm),dtv(lyold),dtv(lsmold), + &dtv(lyint),dtv(lyerr),dtv(ldif1),dtv(ldif2),dtv(ldif3), + &itv(litu),dtv(ldtu), + &t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + &itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c + if (ind.le.0) return +c +c appel de icse2 +c but +c icse2 calcule le gradient du cout en utilisant l'etat +c adjoint du systeme discretise +c algorithme +c On procede a pas de temps constant:dt suivant deux echelles +c si nt est le nombre total de pas de temps,notons: +c y_1,...,y_nt les valeurs de la variable d'etat y a chaque pas +c p_1,...,p_nt l'etat adjoint discretise +c avec pour tout l=1,...,nt +c y_l=(y_l(1),...,y_l(ny)) et p_l=(p_l(1),...,p_l(ny)) +c c2 la fonction cout +c Id la matrice identite d'ordre ny +c I la matrice diagonale d'ordre ny dont les nea premiers +c coefficients diagonaux valent 0 et les autres 1 +c (M)t la transposee de la matrice M +c L'etat adjoint discretise est la solution du systeme: +c dc2/dy_nt=(I-(dt/2)dfy(t_nt,y_nt,u))t*p_nt avec +c dt=t_nt-t_(nt-1) +c dc2/dy_k+(Id+(dt/2)dfy(t_k,y_k,u))t*I*p_k+1= +c (I-(dt2new)dfy(t_k,y_k,u))t*p_k pour k=1,...,nt-1 +c avec dc2/dy_l nul quand l n'est pas un indice d'instant de +c mesure +c A chaque pas,apres avoir calcule p_l,on calcule +c la contribution au gradient au pas l+1: +c (dt/2)(dfu(t_l,y_l,u)+dfu(t_l+1,y_l+1,u))t*p_(l+1)) avec +c dt=t_(l+1)-t_l +c qu'on ajoute pour obtenir finalement le gradient en prenant +c si l=1 la contribution: +c ((t_1-t0)/2)(dfu(t0,y0,u)+dfu(t_1,y_1,u))t*p_1. +c L'etat adjoint n'est pas stocke. +c +c liste d'appel: +c icse2(ind,u,nu,co,g,icsef,icsec2,icsei,y0,tob,obs,ob,ytot,f,b, +c fy,fu,ipv2,itob,cof,ytob,c2y,y0u,dmy,smy,oldmu,y,oldp,p,p0,gt, +c yob,d,itu,dtu, +c t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, +c itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c en entree: +c +c ind,u,nu figurent dans la liste d'appel de icse.fortran +c +c icsef nom de subroutine appelee par icse2 +c +c icsec2 nom de subroutine appelee par icse2 +c +c icsei nom de subroutine appelee par icse2 +c +c y0 double precision (ny) +c etat initial +c +c tob double precision (ntob) +c instants de mesure +c +c obs double precision (nob,ny) +c matrice d'observation +c figure dans la liste d'appel de icsec2,qui calcule +c le cout quadratique dans le cas d'un observateur +c lineaire +c +c ob double precision (nex,ntob,nob) +c mesures +c +c ytot double precision (ny,nti+ntf) +c valeurs calculees de l'etat aux pas de temps +c +c b double precision (ny) +c terme constant dans le cas lineaire quadratique +c +c en sortie: +c +c co,g figurent dans la liste d'appel de icse.fortran +c +c variables internes: +c +c f double precision (ny) +c stockage d'un calcul inutile des seconds membres +c (au cas ou l'on n'utiliserait pas indf) +c +c fy double precision (ny,ny) +c stockage de la derivee des seconds membres +c par rapport a l'etat +c +c fu double precision (ny,nuc+nuv) +c stockage de la derivee des seconds membres +c par rapport aux parametres +c +c ipv2 entier (ny) +c stockage du vecteur des indices des pivots donne par +c dgefa a chaque factorisation du jacobien +c +c itob entier (ntob) +c indices des instants de mesure +c +c cof double precision (nob,ntob) +c coefficients de ponderation du cout +c +c ytob double precision (ny,ntob) +c valeurs calculees de l'etat aux instants de mesure +c +c y0u double precision (ny,nui) +c derivee de l'etat initial par rapport au controle +c +c dmy double precision (ny,ny) +c matrices successives des systemes lineaires +c donnant l'etat adjoint discretise +c dmy=I-(dt/2)dfy +c +c smy double precision (ny,ny) +c matrices successives conduisant aux seconds membres +c des systemes lineaires de l'etat adjoint discretise +c +c oldmu double precision (ny,nuc+nuv) +c stockage de df/du a l'instant posterieur +c +c y double precision (ny) +c stockage de la valeur calculee de l'etat a un pas de +c temps +c +c oldp double precision (ny) +c stockage de la valeur calculee de l'etat adjoint au +c pas de temps posterieur +c +c p double precision (ny) +c stockage de la valeur calculee de l'etat adjoint a +c un pas de temps +c +c p0 double precision (ny) +c etape dans le calcul des seconds membres des +c systemes lineaires donnant l'etat adjoint dicretise +c +c gt double precision (nu) +c stockage de la contribution au gradient a chaque +c pas de temps +c +c yob,d figurent dans la liste d'appel de icsec2,qui calcule +c le cout quadratique dans le cas d'un observateur +c lineaire +c +c itu entier (nitu) +c tableau de travail entier reserve a l'utlisateur +c +c dtu double precision (ndtu) +c tableau de travail double precision reserve +c a l'utilisateur +c +c enfin: +c +c kt entier +c indice de comptage des pas de temps +c +c ktob entier +c indice de comptage des instants de mesure +c +c dt double precision +c pas de temps,egal a dti ou a dtf +c +c dt2 double precision +c dt2=dt/2 +c +c dt2new double precision +c dt2 a l'instant posterieur +c +c t double precision +c instant (a l'instant t on travaille sur [t,t+dt]) +c +c c2 double precision +c stockage d'un calcul inutile du cout +c (au cas ou l'on n'utiliserait pas indc) +c +c indf entier +c indicateur figurant dans la liste d'appel de icsef +c +c indi entier +c indicateur figurant dans la liste d'appel de icsei +c +c nui entier +c nombre de parametres dont depend l'etat initial +c (figure dans la liste d'appel de icsei) +c + call icse2(ind,nu,u,co,g,icsef,icsec2,icsei,dtv(ly0),dtv(ltob), + &dtv(lobs),dtv(lob),dtv(lytot),dtv(lf),dtv(lb),dtv(lfy),dtv(lfu), + &itv(lipv2),itv(litob),dtv(lcof),dtv(lytob),dtv(lc2y),dtv(ly0u), + &dtv(ldmy),dtv(lsmy),dtv(loldmu),dtv(ly),dtv(loldp), + &dtv(lp),dtv(lp0),dtv(lgt),dtv(lyob),dtv(ld),itv(litu),dtv(ldtu), + &t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + &itmx,nex,nob,ntob,ntobi,nitu,ndtu) + do 20 i=1,nu + g(i)=dtv(lech+i-1)*g(i) + u(i)=dtv(ludep+i-1) +20 continue + return +c +c format +c + 8003 format(1x,'icse : taille des tableaux itv,dtv insuffisante') + 8004 format(8x,'valeurs minimales ',i6,2x,i6) +c +c fin +c + end diff --git a/modules/optimization/src/fortran/icse.lo b/modules/optimization/src/fortran/icse.lo new file mode 100755 index 000000000..3fb695e10 --- /dev/null +++ b/modules/optimization/src/fortran/icse.lo @@ -0,0 +1,12 @@ +# src/fortran/icse.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icse.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icse0.f b/modules/optimization/src/fortran/icse0.f new file mode 100755 index 000000000..657df5d33 --- /dev/null +++ b/modules/optimization/src/fortran/icse0.f @@ -0,0 +1,52 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine icse0(nu,t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf, + & ny,nea,itmx,nex,nob,ntob,ntobi,nitu,ndtu,nitv,nrtv,ndtv) +c +c programme d'initialisation appele par icse.bas +c initialisation des commons icsez icsez0 et nird +c + implicit double precision (a-h,o-z) + dimension iu(5),iu0(5) + common/icsez/t00,tf0,dti0,dtf0,ermx0,iu0,nuc0,nuv0,ilin0,nti0, + & ntf0,ny0,nea0,itmx0,nex0,nob0,ntob0,ntobi0,nitu0,ndtu0 + common/nird/nitv0,nrtv0,ndtv0 +c + t00=t0 + tf0=tf + dti0=dti + dtf0=dtf + ermx0=ermx + do 10 i=1,5 +10 iu0(i)=iu(i) + nuc0=nuc + nuv0=nuv + ilin0=ilin + nti0=nti + ntf0=ntf + ny0=ny + nea0=nea + itmx0=itmx + nex0=nex + nob0=nob + ntob0=ntob + ntobi0=ntobi + nitu0=nitu + ndtu0=ndtu + nitv0=0 + nrtv0=0 + ndtv0=0 + ind=0 + call icse(ind,nu,zz,zz,zz,zz,zz,zz,zz,zz,zz) + nitv=max(1,nitv0) + nrtv=max(1,nrtv0) + ndtv=max(1,ndtv0) + return + end diff --git a/modules/optimization/src/fortran/icse0.lo b/modules/optimization/src/fortran/icse0.lo new file mode 100755 index 000000000..b9a51bc96 --- /dev/null +++ b/modules/optimization/src/fortran/icse0.lo @@ -0,0 +1,12 @@ +# src/fortran/icse0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icse0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icse1.f b/modules/optimization/src/fortran/icse1.f new file mode 100755 index 000000000..76bc53302 --- /dev/null +++ b/modules/optimization/src/fortran/icse1.f @@ -0,0 +1,232 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=ICSE1,SSI=0 +c + subroutine icse1(ind,nu,u,icsef,y0,ytot,f,b,fy,fu,ipv1, + &dm,yold,smold,yint,yerr,dif1,dif2,dif3,itu,dtu, + &t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + &itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c +c sous programme de icse.fortran:calcul de l'etat +c + implicit double precision (a-h,o-z) + dimension u(nu),y0(ny),ytot(ny,nti+ntf),f(ny),b(ny),fy(ny,ny), + &fu(ny,nuc+nuv),ipv1(ny),dm(ny,ny),yold(ny),smold(ny),yint(ny), + &yerr(ny),dif1(ny),dif2(ny),dif3(ny),itu(nitu),dtu(ndtu),iu(5) + external icsef +c +c Initialisation +c + t=t0 + call dcopy(ny,y0,1,yold,1) +c +c Resolutions successives du systeme d'etat discretise a chaque +c pas de temps +c + do 100 kt=1,nti+ntf +c +c *Calcul,puis factorisation de la matrice dm du systeme: +c on a au depart yold=y_kt-1,etat au pas kt-1;alors +c dm=(1/dt).I-(1/2).dfy(told,yold,u) avec dt=t_kt-t_(kt-1), +c told=t_(kt-1),I designant la matrice diagonale d'ordre ny +c dont les nea premiers coefficients diagonaux valent 0 et les +c autres 1 +c si le systeme est affine avec partie lineaire autonome (ilin=2) +c dm est calculee et factorisee seulement aux premiers pas de +c temps pour dti et dtf,sinon (ilin=0 ou 1) dm est calculee et +c factorisee a chaque pas de temps +c +c stockage de l'instant au pas kt-1 +c + luv=min(nu,nuc+1+(kt-1)*nuv) + told=t +c +c calcul de t=t_kt,dt=t_kt-t_(kt-1),dtinv=1/dt +c + if (kt.le.nti) then + t=kt*dti+t0 + dt=dti + else + t=nti*dti+(kt-nti)*dtf+t0 + dt=dtf + endif + dtinv=1.0d+0/dt +c +c calcul et factorisation de dm=dtinv.I-(1/2).dfy(told,yold,u) +c I designant la matrice diagonale d'ordre ny dont les nea +c premiers coefficients diagonaux valent 0 et les autres 1 +c +c fy=dfy(told,yold,u) n'est calcule que pour kt=1 lorsque +c ilin>1 +c dm=dtinv.I-(1/2).fy n'est calcule que pour kt=1 ou kt=nti+1 +c lorsque ilin>1 +c + if (kt.eq.1.or.kt.eq.nti+1.or.ilin.le.1) then + indf=2 + if (kt.eq.1.or.ilin.le.1) + & call icsef(indf,told,yold,u,u(luv),f,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) + if (indf.le.0) then + ind=indf + return + endif + do 10 i=1,ny + do 10 j=1,ny +10 dm(i,j)=-fy(i,j)/2.0d+0 + do 20 i=1+nea,ny +20 dm(i,i)=dm(i,i)+dtinv + call dgefa(dm,ny,ny,ipv1,info) + endif +c +c *Calcul de l'etat y_kt au pas kt: +c Initialisation du nombre d'iterations dans l'algorithme +c + it=1 +c +c Prediction du deplacement:dif1 (Euler explicite) +c dif1=dt.(I*f(told,yold,u)) +c et stockage de I*f(told,yold,u) dans smold,I designant la +c matrice diagonale d'ordre ny dont les nea premiers +c coefficients diagonaux valent 0 et les autres 1 +c +c si kt=1,smold=f(told,yold,u) +c sinon,smold=f(told,yold,u) a ete calcule au pas kt-1 +c sous le nom dif1=f(t,yerr,u) +c + if (kt.eq.1) then + indf=1 + call icsef(indf,told,yold,u,u(luv),smold,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) + if (indf.le.0) then + ind=indf + return + endif + endif +c +c smold=I*smold,puis dif1=dt.smold +c + if (nea.gt.0) then + do 30 i=1,nea +30 smold(i)=0.0d+0 + endif + call dcopy(ny,smold,1,dif1,1) + call dscal(ny,dt,dif1,1) +c +c Calcul de l'erreur:dif2=(1/2).(smold+f(t,yold+dif1,u))-dif1/dt +c dif2=f(t,yint,u) ou yint=yold+dif1 +c + luv=min(nu,nuc+1+kt*nuv) + call dcopy(ny,yold,1,yint,1) + call dadd(ny,dif1,1,yint,1) + indf=1 + call icsef(indf,t,yint,u,u(luv),dif2,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) + if (indf.le.0) then + ind=indf + return + endif +c +c dif2=(1/2).(smold+dif2) +c + call dadd(ny,smold,1,dif2,1) + call dscal(ny,0.50d+0,dif2,1) +c +c dif2=dif2-dif1/dt +c + call daxpy(ny,-dtinv,dif1,1,dif2,1) +c +c Calcul du nouvel ecart:dif3 +c initialisation:dif3=dif1 +c + call dcopy(ny,dif1,1,dif3,1) +c +c resolution de dm*X=dif2,la solution X s'appelant dif2 +c +50 call dgesl(dm,ny,ny,ipv1,dif2,0) +c +c dif3=dif3+dif2 est le nouvel ecart +c + call dadd(ny,dif2,1,dif3,1) +c +c Calcul de la norme err de l'erreur dif2 apres correction +c dif2=(1/2).(smold+f(t,yold+dif3,u))-I*(dif3/dt) +c I designant la matrice diagonale d'ordre ny dont les nea +c premiers coefficients diagonaux valent 0 et les autres 1 +c +c dif1=f(t,yerr,u) ou yerr=yold+dif3 +c + call dcopy(ny,yold,1,yerr,1) + call dadd(ny,dif3,1,yerr,1) +c +c ermx<0 correspond au fait que l'utilisateur a choisi +c de ne faire qu'une correction sans aucun test sur +c l'erreur + if (ermx.lt.0) go to 55 +c + indf=1 + call icsef(indf,t,yerr,u,u(luv),dif1,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) + if (indf.le.0) then + ind=indf + return + endif +c +c dif2=dif1 +c + call dcopy(ny,dif1,1,dif2,1) +c +c dif2=(1/2).(smold+dif2) +c + call dadd(ny,smold,1,dif2,1) + call dscal(ny,.5d0,dif2,1) +c +c dif2=dif2-I*(dif3/dt) +c + call daxpy(ny-nea,-dtinv,dif3(1+nea),1,dif2(1+nea),1) +c +c err=norme l2 de dif2 +c + err=dnrm2(ny,dif2,1) +c +c Si err>ermx,on corrige a nouveau si possible,c'est a dire +c si it<=itmx +c + if (err.gt.ermx.and.ilin.eq.0) then + it=it+1 + if (it.gt.itmx) then + ind=-1 + print *,' icse : integration de l etat impossible' + return + endif + go to 50 + endif +c +c Si err<=ermx,yold=yerr est y_kt,etat au pas kt +c (on avait calcule yerr=yold+dif3) +c et ytot(.,kt)=yold +c +55 call dcopy(ny,yerr,1,yold,1) + call dcopy(ny,yold,1,ytot(1,kt),1) +c +c smold=dif1 +c (on avait calcule dif1=f(t,yerr,u) qui deviendra +c f(told,yold,u) au pas kt+1) +c + call dcopy(ny,dif1,1,smold,1) +c +c *On passe au pas de temps suivant:kt+1 +c +100 continue + return + end diff --git a/modules/optimization/src/fortran/icse1.lo b/modules/optimization/src/fortran/icse1.lo new file mode 100755 index 000000000..d8797bbb2 --- /dev/null +++ b/modules/optimization/src/fortran/icse1.lo @@ -0,0 +1,12 @@ +# src/fortran/icse1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icse1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icse2.f b/modules/optimization/src/fortran/icse2.f new file mode 100755 index 000000000..1f8ed08fe --- /dev/null +++ b/modules/optimization/src/fortran/icse2.f @@ -0,0 +1,346 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c +C/MEMBR ADD NAME=ICSE2,SSI=0 +c + subroutine icse2(ind,nu,u,co,g,icsef,icsec2,icsei,y0,tob,obs, + &ob,ytot,f,b,fy,fu,ipv2,itob,cof,ytob,c2y,y0u,dmy,smy,oldmu, + &y,oldp,p,p0,gt,yob,d,itu,dtu, + &t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + &itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) +c +c sous programme de icse.fortran:calcul du gradient par +c integration du systeme adjoint +c + implicit double precision (a-h,o-z) + dimension iu(5), u(nu),g(nu),y0(ny),tob(ntob),obs(nob,ny), + &ob(nex,ntob,nob),ytot(ny,nti+ntf),f(ny),b(ny),fy(ny,ny), + &fu(ny,nuc+nuv),ipv2(ny),itob(ntob),cof(nob,ntob),ytob(ny,ntob), + &c2y(ny,ntob),y0u(ny,nu),dmy(ny,ny),smy(ny,ny), + &oldmu(ny,nuc+nuv),y(ny),oldp(ny),p(ny),p0(ny), + >(nu),yob(nob,ntob),d(nob),itu(nitu),dtu(ndtu) + external icsef,icsec2,icsei +c + character*6 nomf,nomc,nomi +c +c Initialisation +c + call dset(nu,0.0d+0,g,1) + call dset(ny,0.0d+0,p,1) + kt=nti+ntf + ktob=ntob +c lui et nui servent quand l'etat initial depend du controle + if (iu(2).gt.0) lui=min(nu,1+nuc) + if (iu(1).gt.0) lui=1 + nui=iu(1)*nuc+iu(2)*nuv*(nti+ntf+1) +c +c +c Calcul de itob,vecteur des indices des instants de mesure +c a partir de tob,vecteur des instants de mesure +c itob(j) est l'entier le plus proche de tob(j)/dt +c + do 1 j=1,ntobi +1 itob(j)=int(((tob(j)-t0)/dti)+0.50d+0) + if (ntobi.lt.ntob) then + itob(ntobi+1)=nti+int(0.50d+0+(tob(ntobi+1)-t0-nti*dti)/dtf) + endif + if (ntobi+1.lt.ntob) then + do 2 j=ntobi+2,ntob +2 itob(j)=itob(ntobi+1)+int(0.50d+0+(tob(j)-tob(ntobi+1))/dtf) + endif +c +c Ecriture de ytob tableau des valeurs de l'etat +c aux instants de mesure +c + do 10 j=1,ntob + do 10 i=1,ny +10 call dcopy(ny,ytot(1,itob(j)),1,ytob(1,j),1) +c +c Si ind=2,on calcule seulement le cout +c Si ind=3,on calcule seulement le gradient +c Si ind=4,on calcule le cout et le gradient +c + if (ind.ne.3) then + indc=1 + call icsec2(indc,nu,tob,obs,cof,ytob,ob,u, + & co,c2y,g,yob,d,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indc.le.0) then + ind=indc + return + endif + endif + if (ind.eq.2) return +c +c Calcul du gradient du cout en utilisant l'etat adjoint +c discretise: +c calcul de la derivee partielle c2y du cout par rapport +c a l'etat +c + indc=2 + call icsec2(indc,nu,tob,obs,cof,ytob,ob,u,co,c2y,g,yob,d,itu, + &dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indc.le.0) then + ind=indc + return + endif +c +c +Evaluations successives de la contribution au gradient +c a chaque pas de temps a l'aide de l'etat adjoint(non stocke) +c + do 100 kt=nti+ntf,1,-1 +c +c *Calcul de l'etat adjoint p_kt au pas kt +c Calcul du second membre p +c Initialisation: +c nt=nti+ntf +c si kt=nt,p est nul +c si kt<nt,on a au depart p=p_kt+1,etat adjoint au pas kt+1; +c on prend p=p0,ou p0=(smy)t*I*p avec smy=Id+(dt/2).dfy(t,y,u) +c avec dt=t_(kt+1)-t_kt,y=y_kt,t=t_kt,I designant la matrice +c diagonale d'ordre ny dont les nea premiers coefficients +c valent 0 et les autres 1 et Id designant la matrice +c identite d'ordre ny; +c si le systeme est affine avec partie lineaire autonome +c (ilin=2) smy est calculee seulement aux premiers pas de temps +c pour dti et dtf,sinon (ilin=0 ou 1) smy est calculee a chaque +c pas de temps +c +c stockage de l'etat adjoint et de dt/2 au pas kt+1 +c + call dcopy(ny,p,1,oldp,1) + luv=min(nu,1+nuc+kt*nuv) +c +c calcul de y=y_kt,dt=t_(kt+1)-t_kt,dt2=dt/2, +c dt2new=(t_kt-t_(kt-1))/2 +c + call dcopy(ny,ytot(1,kt),1,y,1) +c + if (kt.lt.nti) then + t=kt*dti+t0 + dt=dti + else + t=nti*dti+(kt-nti)*dtf+t0 + dt=dtf + endif + dt2=dt/2.0d+0 + if (kt.ne.nti) then + dt2new=dt2 + else + dt2new=dti/2.0d+0 + endif +c +c Dans le cas ilin<=1, +c calcul de fy=dfy(t,y,u) puis de smy=Id+(dt/2).dmy +c lorsque kt<(nti+ntf) +c Sinon (ilin>1),fy=dfy a ete calcule dans icse1 +c +c + if (ilin.le.1) then + indf=2 + call icsef(indf,t,y,u,u(luv),f,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indf.le.0) then + ind=indf + return + endif + endif +c + if (kt.ne.nti+ntf) then + if (ilin.le.1.or.kt.eq.nti+ntf-1.or.kt.eq.nti-1) then + do 30 i=1,ny + do 30 j=1,ny +30 smy(i,j)=dt2*fy(i,j) + do 35 i=1,ny +35 smy(i,i)=1.0d+0+smy(i,i) + endif +c +c calcul de p0=(smy)t*I*p puis p=p0 +c + if (nea.gt.0) then + do 40 i=1,nea +40 p(i)=0.0d+0 + endif + call dmmul(p,1,smy,ny,p0,1,1,ny,ny) +c + call dcopy(ny,p0,1,p,1) + endif +c +c Fin du calcul du second membre p +c si kt=itob(ktob),on ajoute c2y(.,ktob) au second membre p +c + if (ktob.gt.0) then + if (kt.eq.itob(ktob)) then + do 50 i=1,ny +50 p(i)=p(i)+c2y(i,ktob) + ktob=ktob-1 + endif + endif +c +c Calcul et factorisation de la matrice dmy du systeme +c de l'etat adjoint +c dmy=I-dt2new.dfy(t,y,u) avec dt2new=(t_kt-t_(kt-1))/2, +c y=y_kt,t=t_kt,Idesignant la matrice diagonale d'ordre +c ny dont les nea premiers coefficients valent 0 et les +c autres 1; +c si le systeme est affine avec partie lineaire autonome +c (ilin=2) dmy est calculee et factorisee aux premiers +c pas de temps pour dti et dtf,sinon (ilin=0 ou 1) dmy est +c calculee et factorisee a chaque pas de temps +c + if (ilin.le.1.or.kt.eq.nti+ntf.or.kt.eq.nti) then + do 60 i=1,ny + do 60 j=1,ny +60 dmy(i,j)=-dt2new*fy(i,j) + do 65 i=1+nea,ny +65 dmy(i,i)=1.0d+0+dmy(i,i) + call dgefa(dmy,ny,ny,ipv2,info) + endif +c +c Resolution de (dmy)t*X=p,la solution s'appelant p +c p est alors p_kt,etat adjoint au pas kt +c + call dgesl(dmy,ny,ny,ipv2,p,1) +c +c *Calcul du gradient g au pas kt+1 +c calcul de la contribution gt au gradient au pas kt+1: +c gt=(dt/2).(I*dfu(t_kt,y_kt,u)+dfu(t_kt+1,y_kt+1,u))t*p_kt+1 +c avec dt=t_(kt+1)-t_kt,I designant la matrice diagonale +c d'ordre ny dont les nea premiers coefficients valent 0 +c et les autres 1 +c + if (nuv.gt.0.or.iu(3).eq.1) then + indf=3 + call icsef(indf,t,y,u,u(luv),f,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indf.le.0) then + ind=indf + return + endif + if (kt.lt.nti+ntf) then + call dmmul(oldp,1,oldmu,ny,gt,1,1,ny,nuc+nuv) + call dscal(nuc+nuv,dt2,gt,1) +c le gradient g est la somme des contributions + if(iu(3).gt.0) then + call dadd(nuc,gt,1,g,1) + endif + if(nuv.gt.0) then + luv=min(nu,1+nuc+(kt+1)*nuv) + call dadd(nuv,gt(nuc+1),1,g(luv),1) + endif + if (nea.gt.0) then + do 70 i=1,nea +70 oldp(i)=0.0d+0 + endif + call dmmul(oldp,1,fu,ny,gt,1,1,ny,nuc+nuv) + call dscal(nuc+nuv,dt2,gt,1) +c le gradient g est la somme des contributions + if(iu(3).gt.0) then + call dadd(nuc,gt,1,g,1) + endif + if(nuv.gt.0) then + luv=min(nu,1+nuc+kt*nuv) + call dadd(nuv,gt(nuc+1),1,g(luv),1) + endif + endif +c +c stockage de dfu(t_kt,y_kt,u) dans oldmu +c + call dcopy(ny*(nuc+nuv),fu,1,oldmu,1) +c +c *On passe au pas de temps suivant:kt-1,sauf si kt=1,auquel cas +c on calcule la contribution gt au gradient au pas kt=1 et +c on l'ajoute a g;on a: +c gt=(dt/2).(I*dfu(t0,y0,u)+dfu(t_1,y_1,u))t*p_1,avec +c dt=t_1-t0=dti car nti n'est jamais nul par convention +c + if (kt.eq.1) then + t=t0 + dt2=dti/2.0d+0 + call dcopy(ny,y0,1,y,1) + indf=3 + call icsef(indf,t,y,u,u(luv),f,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indf.le.0) then + ind=indf + return + endif + call dmmul(p,1,oldmu,ny,gt,1,1,ny,nuc+nuv) + call dscal(nuc+nuv,dt2,gt,1) +c le gradient g est la somme des contributions + if(iu(3).gt.0) then + call dadd(nuc,gt,1,g,1) + endif + if(nuv.gt.0) then + luv=min(nu,1+nuc+nuv) + call dadd(nuv,gt(nuc+1),1,g(luv),1) + endif + if (nea.gt.0) then + do 90 i=1,nea +90 p(i)=0.0d+0 + endif + call dmmul(p,1,fu,ny,gt,1,1,ny,nuc+nuv) + call dscal(nuc+nuv,dt2,gt,1) +c le gradient g est la somme des contributions + if(iu(3).gt.0) then + call dadd(nuc,gt,1,g,1) + endif + if(nuv.gt.0) then + luv=min(nu,1+nuc) + call dadd(nuv,gt(nuc+1),1,g(luv),1) + endif + endif + endif +100 continue +c +c gradient par rapport au controle initial +c + if(max(iu(1),iu(2)) .gt.0) then +c +c calcul de l'etat adjoint initial p0 +c + indf=2 + call icsef(indf,t,y,u,u(luv),f,fy,fu,b,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indf.eq.0) then + ind=indf + return + endif + do 120 i=1,ny + do 120 j=1,ny +120 smy(i,j)=dt2*fy(i,j) + do 125 i=1,ny +125 smy(i,i)=1.0d+0+smy(i,i) + if (nea.gt.0) then + do 130 i=1,nea +130 p(i)=0.0d+0 + endif + call dmmul(p,1,smy,ny,p0,1,1,ny,ny) +c incrementation du gradient + indi=2 + call icsei(indi,nui,u(lui),y0,y0u,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu,nomf,nomc,nomi) + if (indi.le.0) then + ind=indi + return + endif + call dmmul(p0,1,y0u,ny,gt,1,1,nui,nui) + do 150 i=1,nui +150 g(lui+i-1)=g(lui+i-1)+gt(i) +c + endif + end diff --git a/modules/optimization/src/fortran/icse2.lo b/modules/optimization/src/fortran/icse2.lo new file mode 100755 index 000000000..83d502134 --- /dev/null +++ b/modules/optimization/src/fortran/icse2.lo @@ -0,0 +1,12 @@ +# src/fortran/icse2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icse2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icsec2.f b/modules/optimization/src/fortran/icsec2.f new file mode 100755 index 000000000..6d79ac025 --- /dev/null +++ b/modules/optimization/src/fortran/icsec2.f @@ -0,0 +1,65 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine icsec2(indc,nu,tob,obs,cof,ytob,ob,u, + & c,cy,g,yob,d,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c +c +c critere standard des moindres carres +c +c +c Cout ponctuel : +c Parametres d'entree : +c indc : 1 si on desire calculer c2,2 si on desire +c calculer c2y,c2u +c tob : instants de mesure +c obs : matrice d'observation +c cof : coefficients de ponderation du cout +c ytob : valeur de l'etat aux instants d'observation +c ob : mesures +c u(nu) : controle.Le controle variable est stocke a la +c suite du controle suite du constant. +c Parametres de sortie : +c indc : comme pour icsec1 +c c2 : cout +c c2y(ny,ntob) : derivee de c2 par rapport a y +c g(nu) : derivee de c2 par rapport a u +c + implicit double precision (a-h,o-z) + dimension tob(ntob),obs(nob,ny),cof(nob,ntob),ytob(ny,ntob), + &ob(nex,ntob,nob),u(nu),cy(ny,ntob),g(nu),yob(nob,ntob), + &d(nob),itu(nitu),dtu(ndtu),iu(5) +c +c critere standard des moindres carres +c + call dmmul(obs,nob,ytob,ny,yob,nob,nob,ny,ntob) + if (indc.eq.1) then + c=0.0d+0 + do 12 i=1,nob + do 11 j=1,ntob + do 10 k=1,nex + c=c+0.50d+0*cof(i,j)*(yob(i,j)-ob(k,j,i))**2 + 10 continue + 11 continue + 12 continue + else + do 20 j=1,ntob + do 25 i=1,nob + d(i)=0.0d+0 + do 24 k=1,nex + d(i)=d(i)+cof(i,j)*(yob(i,j)-ob(k,j,i)) + 24 continue + 25 continue + call dmmul(d,1,obs,nob,cy(1,j),1,1,nob,ny) + 20 continue + endif + + end diff --git a/modules/optimization/src/fortran/icsec2.lo b/modules/optimization/src/fortran/icsec2.lo new file mode 100755 index 000000000..e028e622e --- /dev/null +++ b/modules/optimization/src/fortran/icsec2.lo @@ -0,0 +1,12 @@ +# src/fortran/icsec2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icsec2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/icsei.f b/modules/optimization/src/fortran/icsei.f new file mode 100755 index 000000000..bdfd3bdc9 --- /dev/null +++ b/modules/optimization/src/fortran/icsei.f @@ -0,0 +1,33 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine icsei(indi,nui,u,y0,y0u,itu,dtu, + & t0,tf,dti,dtf,ermx,iu,nuc,nuv,ilin,nti,ntf,ny,nea, + & itmx,nex,nob,ntob,ntobi,nitu,ndtu) +c +c calcul de l'etat initial dans ICSE : cas standard : +c controle par l'etat initial +c + implicit double precision (a-h,o-z) + dimension u(nui),y0(ny),y0u(ny,nui),itu(nitu),dtu(ndtu),iu(5) +c + if (indi.eq.1) then + do 10 i=1,ny + y0(i)=u(i) + 10 continue + endif +c + if (indi.eq.2) then +c cas ou y0u est l identite + call dset(ny*nui,0.0d+0,y0u,1) + do 20 i=1,ny + y0u(i,i)=1.0d+0 + 20 continue + endif + end diff --git a/modules/optimization/src/fortran/icsei.lo b/modules/optimization/src/fortran/icsei.lo new file mode 100755 index 000000000..4187511c6 --- /dev/null +++ b/modules/optimization/src/fortran/icsei.lo @@ -0,0 +1,12 @@ +# src/fortran/icsei.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/icsei.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/intreadmps.f b/modules/optimization/src/fortran/intreadmps.f new file mode 100755 index 000000000..80607e23e --- /dev/null +++ b/modules/optimization/src/fortran/intreadmps.f @@ -0,0 +1,469 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c SCILAB function : readmps, fin = 1 + subroutine intreadmps(id) +c + include 'stack.h' +c + integer iadr, sadr + integer topk,rhsk, topf,mode(2) + logical checkrhs,checklhs,getsmat,checkval,getvect + logical listcremat + logical listcresmat,listcrestring + logical opened + + double precision big,dlamch,dlobnd,dupbnd + integer ierr,line + integer irobj,ptr(19) + character*8 namec,nameb,namran,nambnd,nammps + character*2 typrow + character*8 fname +c + iadr(l)=l+l-1 + sadr(l)=(l/2)+1 +c + fname='readmps' +c + rhs = max(0,rhs) +c + lbuf = 1 + topk = top + rhsk = rhs +c + big=dlamch('o') + + if(.not.checklhs(fname,1,1)) return + if(.not.checkrhs(fname,2,3)) return + +c +c checking variable file (number 1) + if(.not.getsmat(fname,top,top-rhs+1,m1,n1,1,1,lr1,nlr1)) return + if(.not.checkval(fname,m1*n1,1)) return + topf=top-rhs+1 +c +c checking variable bnd (number 2) + if(.not.getvect(fname,top,top-rhs+2,it2,m2,n2,lr2,lc2)) return + if(.not.checkval(fname,n2*m2,2)) return + dlobnd=stk(lr2) + dupbnd=stk(lr2+1) + if (rhs.eq.3) then +c . checking variable max (number 3) + if(.not.getvect(fname,top,top-rhs+3,it3,m3,n3,lr3,lc3)) return + if(.not.checkval(fname,n3*m3,3)) return + maxm=stk(lr3) + maxn=stk(lr3+1) + maxnza=stk(lr3+2) + m=maxm + n=maxn + nza=maxnza + else + mode(1)=-1 + mode(2)=0 + call v2unit(topf,mode,lunit,opened,ierr) + if(ierr.gt.0) return + call rdmpsz(lunit,m,n,nza,ierr,typrow,line) + if(ierr.eq.0) then + call clunit(-lunit,buf,mode) + elseif(ierr.eq.1) then + call writebufspa(buf,fname,line) + call clunit(-lunit,buf,mode) + call error(998) + return + elseif(ierr.eq.2) then + call writebufspb(buf,fname,typrow,line) + call clunit(-lunit,buf,mode) + call error(999) + return + endif + maxm=m + maxn=n + maxnza=nza + endif + + mode(1)=-1 + mode(2)=0 + call v2unit(topf,mode,lunit,opened,ierr) + if(ierr.gt.0) return +c + + top=topk-rhs+1 + +c nl number of fields + call mpstyp(nl,'nfield') + call mpstyp(ptr,'ptr') +c +c create tlist structure + call cretlist(top,nl,ll) +c tlist type (vector of strings nl) + l1=iadr(ll) + if(.not.listcresmat(fname,top,1,ll,nl,1,ptr,3,iltyp)) goto 998 + call mpstyp(istk(l1),'create') +c irobj (scalar) + if(.not.listcremat (fname,top,2,ll,0, 1,1,lirobj,lcs)) goto 998 +c namec (string 8) + if(.not.listcrestring(fname,top,3,ll,8,lnamec)) goto 998 +c nameb (string 8) + if(.not.listcrestring(fname,top,4,ll,8,lnameb)) goto 998 +c namran (string 8) + if(.not.listcrestring(fname,top,5,ll,8,lnamran)) goto 998 +c nambnd (string 8) + if(.not.listcrestring(fname,top,6,ll,8,lnambnd)) goto 998 +c nammps (string 8) + if(.not.listcrestring(fname,top,7,ll,8,lnammps)) goto 998 +c rownams (vector of strings mx1) + if(.not.listcresmat(fname,top,8,ll,m,1,8,1,lrownams)) goto 998 +c colnams (vector of strings 1xn) + if(.not.listcresmat(fname,top,9,ll,1,n,8,1,lcolnams)) goto 998 +c rwstat (vector m) + if(.not.listcremat (fname,top,10,ll,0,m,1,lrwstat,lcs)) goto 998 + ilrwstat=iadr(lrwstat) +c rowcod (matrix mx2) + if(.not.listcremat (fname,top,11,ll,0,m,2,lrowcod,lcs)) goto 998 + ilrowcod=iadr(lrowcod) +c colcod (matrix 2xn) + if(.not.listcremat (fname,top,12,ll,0,n,2,lcolcod,lcs)) goto 998 + ilcolcod=iadr(lcolcod) +c rwnmbs (vector nza) + if(.not.listcremat (fname,top,13,ll,0,nza,1,lrwnmbs,lcs)) goto 998 + ilrwnmbs=iadr(lrwnmbs) +c clpnts (vector n) + if(.not.listcremat (fname,top,14,ll,0,1,n+1,lclpnts,lcs)) goto 998 + ilclpnts=iadr(lclpnts) +c acoef (vector nza) + if(.not.listcremat (fname,top,15,ll,0,nza,1,lacoef,lcs)) goto 998 +c rhsb (vector m) + if(.not.listcremat (fname,top,16,ll,0,m,1,lrhsb,lcs)) goto 998 +c ranges (vector m) + if(.not.listcremat (fname,top,17,ll,0,m,1,lranges,lcs)) goto 998 +c bnds (matrix 2xn) + if(.not.listcremat (fname,top,18,ll,0,n,2,lbnds,lcs)) goto 998 +c stavar (column vector n) + if(.not.listcremat (fname,top,19,ll,0,n,1,lstavar,lcs)) goto 998 + ilstavar=iadr(lstavar) + +c work array irow + lirow=iadr(ll) + ll=sadr(lirow+n) +c work array relt + lrelt=ll + ll=ll+n +c rwname +c cstk replaced by istk to avoid argument passing pb with linux +c lrwname=cadr(ll) +c ll=ll+(8*m)/4 + lrwname=iadr(ll) + ll=sadr(lrwname+(8*m)/4+8) +c clname +c cstk replaced by istk to avoid argument passing pb with linux +c lclname=cadr(ll) +c ll=ll+(8*n)/4 + lclname=iadr(ll) + ll=sadr(lclname+(8*m)/4+8) + err=ll-lstk(bot) + if(err.gt.0) then + call error(17) + goto 998 + endif + nameb= ' ' + namec= ' ' + namran=' ' + nambnd=' ' + nammps=' ' + +c cstk(lrwname:) replaced by istk(lrwname) and +c cstk(lclname:) replaced by istk(lclname) to avoid argument +c passing pb with linux + + call rdmps1(ierr,buf,maxm,maxn,maxnza, + x m,n,nza,irobj,big,dlobnd,dupbnd, + x namec,nameb,namran,nambnd,nammps,lunit, + x istk(lrwname),istk(lclname), + x istk(ilstavar),istk(ilrwstat), + x istk(ilrowcod),istk(ilrowcod+m), + x istk(ilcolcod),istk(ilcolcod+n), + x istk(ilrwnmbs),istk(ilclpnts),istk(lirow), + x stk(lacoef),stk(lrhsb),stk(lranges), + x stk(lbnds+n),stk(lbnds),stk(lrelt)) + + + call clunit(-lunit,buf,mode) + if(ierr.ne.0) then + call error(1000+ierr) + return + endif +c +c convert integer data to double + stk(lirobj)=irobj + call int2db(m,istk(ilrowcod+m),-1,stk(lrowcod+m),-1) + call int2db(m,istk(ilrowcod),-1,stk(lrowcod),-1) + + call int2db(n,istk(ilcolcod+n),-1,stk(lcolcod+n),-1) + call int2db(n,istk(ilcolcod),-1,stk(lcolcod),-1) + + call int2db(nza,istk(ilrwnmbs),-1,stk(lrwnmbs),-1) + call int2db(n+1,istk(ilclpnts),-1,stk(lclpnts),-1) + call int2db(m,istk(ilrwstat),-1,stk(lrwstat),-1) + call int2db(n,istk(ilstavar),-1,stk(lstavar),-1) + +c convert strings and put them in proper locations + call cvstr(8,istk(lnamec),namec,0) + call cvstr(8,istk(lnameb),nameb,0) + call cvstr(8,istk(lnamran),namran,0) + call cvstr(8,istk(lnambnd),nambnd,0) + call cvstr(8,istk(lnammps),nammps,0) +c convert vector of strings and put them in proper locations + +c cstk replaced by istk to avoid argument passing pb with linux +c call cvstr(8*m,istk(lrownams),cstk(lrwname:),0) +c call cvstr(8*n,istk(lcolnams),cstk(lclname:),0) + call cvstr(8*m,istk(lrownams),istk(lrwname),0) + call cvstr(8*n,istk(lcolnams),istk(lclname),0) + + return +998 call clunit(-lunit,buf,mode) + return + end +c + subroutine mpstyp(ivt,job) +c definition of first field of tlist's type: mps +c tlist fields are: +c irobj +c namec +c nameb +c namran +c nambnd +c name +c rownames +c colnames +c rowstat +c rowcode +c colcode +c rownmbs +c colpnts +c acoeff +c rhs +c ranges +c bounds +c stavar +c + integer ivt(*),l + character*(*) job +c + if(job.eq.'size') then +c size of the data structure + ivt(1)=136 + elseif(job.eq.'nchar') then +c number of chars defining the type field + ivt(1)=112 + elseif(job.eq.'nfield') then +c number of fields in the tlist + ivt(1)=19 + elseif(job.eq.'ptr') then +c pointers on individual strings + ivt(1)=1 + ivt(2)=4 + ivt(3)=9 + ivt(4)=14 + ivt(5)=19 + ivt(6)=25 + ivt(7)=31 + ivt(8)=35 + ivt(9)=43 + ivt(10)=51 + ivt(11)=58 + ivt(12)=65 + ivt(13)=72 + ivt(14)=79 + ivt(15)=86 + ivt(16)=92 + ivt(17)=95 + ivt(18)=101 + ivt(19)=107 + ivt(20)=113 + else +c Character string Variable header + ivt(1)=10 + ivt(2)=1 + ivt(3)=19 + ivt(4)=0 + ivt(5)=1 + l=24 +c entry (1,1) = "mps" + ivt(l+1)=22 + ivt(l+2)=25 + ivt(l+3)=28 + ivt(6)=ivt(5)+3 + l=l+3 +c entry (2,1) = "irobj" + ivt(l+1)=18 + ivt(l+2)=27 + ivt(l+3)=24 + ivt(l+4)=11 + ivt(l+5)=19 + ivt(7)=ivt(6)+5 + l=l+5 +c entry (3,1) = "namec" + ivt(l+1)=23 + ivt(l+2)=10 + ivt(l+3)=22 + ivt(l+4)=14 + ivt(l+5)=12 + ivt(8)=ivt(7)+5 + l=l+5 +c entry (4,1) = "nameb" + ivt(l+1)=23 + ivt(l+2)=10 + ivt(l+3)=22 + ivt(l+4)=14 + ivt(l+5)=11 + ivt(9)=ivt(8)+5 + l=l+5 +c entry (5,1) = "namran" + ivt(l+1)=23 + ivt(l+2)=10 + ivt(l+3)=22 + ivt(l+4)=27 + ivt(l+5)=10 + ivt(l+6)=23 + ivt(10)=ivt(9)+6 + l=l+6 +c entry (6,1) = "nambnd" + ivt(l+1)=23 + ivt(l+2)=10 + ivt(l+3)=22 + ivt(l+4)=11 + ivt(l+5)=23 + ivt(l+6)=13 + ivt(11)=ivt(10)+6 + l=l+6 +c entry (7,1) = "name" + ivt(l+1)=23 + ivt(l+2)=10 + ivt(l+3)=22 + ivt(l+4)=14 + ivt(12)=ivt(11)+4 + l=l+4 +c entry (8,1) = "rownames" + ivt(l+1)=27 + ivt(l+2)=24 + ivt(l+3)=32 + ivt(l+4)=23 + ivt(l+5)=10 + ivt(l+6)=22 + ivt(l+7)=14 + ivt(l+8)=28 + ivt(13)=ivt(12)+8 + l=l+8 +c entry (9,1) = "colnames" + ivt(l+1)=12 + ivt(l+2)=24 + ivt(l+3)=21 + ivt(l+4)=23 + ivt(l+5)=10 + ivt(l+6)=22 + ivt(l+7)=14 + ivt(l+8)=28 + ivt(14)=ivt(13)+8 + l=l+8 +c entry (10,1) = "rowstat" + ivt(l+1)=27 + ivt(l+2)=24 + ivt(l+3)=32 + ivt(l+4)=28 + ivt(l+5)=29 + ivt(l+6)=10 + ivt(l+7)=29 + ivt(15)=ivt(14)+7 + l=l+7 +c entry (11,1) = "rowcode" + ivt(l+1)=27 + ivt(l+2)=24 + ivt(l+3)=32 + ivt(l+4)=12 + ivt(l+5)=24 + ivt(l+6)=13 + ivt(l+7)=14 + ivt(16)=ivt(15)+7 + l=l+7 +c entry (12,1) = "colcode" + ivt(l+1)=12 + ivt(l+2)=24 + ivt(l+3)=21 + ivt(l+4)=12 + ivt(l+5)=24 + ivt(l+6)=13 + ivt(l+7)=14 + ivt(17)=ivt(16)+7 + l=l+7 +c entry (13,1) = "rownmbs" + ivt(l+1)=27 + ivt(l+2)=24 + ivt(l+3)=32 + ivt(l+4)=23 + ivt(l+5)=22 + ivt(l+6)=11 + ivt(l+7)=28 + ivt(18)=ivt(17)+7 + l=l+7 +c entry (14,1) = "colpnts" + ivt(l+1)=12 + ivt(l+2)=24 + ivt(l+3)=21 + ivt(l+4)=25 + ivt(l+5)=23 + ivt(l+6)=29 + ivt(l+7)=28 + ivt(19)=ivt(18)+7 + l=l+7 +c entry (15,1) = "acoeff" + ivt(l+1)=10 + ivt(l+2)=12 + ivt(l+3)=24 + ivt(l+4)=14 + ivt(l+5)=15 + ivt(l+6)=15 + ivt(20)=ivt(19)+6 + l=l+6 +c entry (16,1) = "rhs" + ivt(l+1)=27 + ivt(l+2)=17 + ivt(l+3)=28 + ivt(21)=ivt(20)+3 + l=l+3 +c entry (17,1) = "ranges" + ivt(l+1)=27 + ivt(l+2)=10 + ivt(l+3)=23 + ivt(l+4)=16 + ivt(l+5)=14 + ivt(l+6)=28 + ivt(22)=ivt(21)+6 + l=l+6 +c entry (18,1) = "bounds" + ivt(l+1)=11 + ivt(l+2)=24 + ivt(l+3)=30 + ivt(l+4)=23 + ivt(l+5)=13 + ivt(l+6)=28 + ivt(23)=ivt(22)+6 + l=l+6 +c entry (19,1) = "stavar" + ivt(l+1)=28 + ivt(l+2)=29 + ivt(l+3)=10 + ivt(l+4)=31 + ivt(l+5)=10 + ivt(l+6)=27 + ivt(24)=ivt(23)+6 + l=l+6 + endif + return + end + diff --git a/modules/optimization/src/fortran/intreadmps.lo b/modules/optimization/src/fortran/intreadmps.lo new file mode 100755 index 000000000..e3d7fb3b1 --- /dev/null +++ b/modules/optimization/src/fortran/intreadmps.lo @@ -0,0 +1,12 @@ +# src/fortran/intreadmps.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/intreadmps.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/io_f_Import.def b/modules/optimization/src/fortran/io_f_Import.def new file mode 100755 index 000000000..6005615a0 --- /dev/null +++ b/modules/optimization/src/fortran/io_f_Import.def @@ -0,0 +1,7 @@ + LIBRARY io_f.dll + + +EXPORTS +; +;io_f +v2unit_ diff --git a/modules/optimization/src/fortran/linpack_f_Import.def b/modules/optimization/src/fortran/linpack_f_Import.def new file mode 100755 index 000000000..bee720b9f --- /dev/null +++ b/modules/optimization/src/fortran/linpack_f_Import.def @@ -0,0 +1,13 @@ + LIBRARY linpack_f.dll + + +EXPORTS +; +;linpack +dgefa_ +dgesl_ +dpofa_ +dpori_ +dposl_ +icopy_ + diff --git a/modules/optimization/src/fortran/majour.f b/modules/optimization/src/fortran/majour.f new file mode 100755 index 000000000..291cc68cd --- /dev/null +++ b/modules/optimization/src/fortran/majour.f @@ -0,0 +1,144 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine majour(hm,hd,dd,n,hno,ir,indic,eps) +c + implicit double precision (a-h,o-z) + dimension hm(*),hd(n),dd(n) + if(n.eq.1) go to 100 +c + np=n+1 + if(hno.gt.0.0d+0) go to 99 +c + if(hno.eq.0.0d+0) go to 999 + if(ir.eq.0) go to 999 + hon=1.0d+0/hno + ll=1 + if(indic.eq.0) go to 1 +c + do 2 i=1,n + if(hm(ll).eq.0.0d+0) go to 2 + hon=hon+dd(i)**2/hm(ll) + 2 ll=ll+np-i + go to 3 +c + 1 continue + do 4 i=1,n + dd(i)=hd(i) + 4 continue + do 5 i=1,n + iplus=i+1 + del=dd(i) + if(hm(ll).gt.0.0d+0) go to 6 + dd(i)=0.0d+0 + ll=ll+np-i + go to 5 + 6 continue + hon=hon+del**2/hm(ll) + if(i.eq.n) go to 7 + do 8 j=iplus,n + ll=ll+1 + 8 dd(j)=dd(j)-del*hm(ll) + 7 ll=ll+1 + 5 continue +c + 3 continue + if(ir.le.0) go to 9 + if(hon.gt.0.0d+0) go to 10 + if ((indic-1) .le. 0) then + goto 99 + else + goto 11 + endif + 9 continue + hon=0.0d+0 + ir=-ir-1 + go to 11 + 10 hon=eps/hno + if(eps.eq.0.0d+0)ir=ir-1 + 11 continue + mm=1 + honm=hon + do 12 i=1,n + j=np-i + ll=ll-i + if(hm(ll).ne.0.0d+0) honm=hon-dd(j)**2/hm(ll) + dd(j)=hon + 12 hon=honm + go to 13 +c + 99 continue + mm=0 + honm=1.0d+0/hno + 13 continue + ll=1 +c + do 98 i=1,n + iplus=i+1 + del=hd(i) + if(hm(ll).gt.0.0d+0) go to 14 + if(ir.gt.0) go to 15 + if(hno.lt.0.0d+0) go to 15 + if(del.eq.0.0d+0) go to 15 + ir=1-ir + hm(ll)=del**2/honm + if(i.eq.n) go to 999 + do 16 j=iplus,n + ll=ll+1 + 16 hm(ll)=hd(j)/del + go to 999 + 15 continue + hon=honm + ll=ll+np-i + go to 98 + 14 continue + hml=del/hm(ll) + if (mm .le. 0) then + goto 17 + else + goto 18 + endif + 17 hon=honm+del*hml + go to 19 + 18 hon=dd(i) + 19 continue + r=hon/honm + hm(ll)=hm(ll)*r + if(r.eq.0.0d+0) go to 20 + if(i.eq.n)go to 20 + b=hml/hon + if(r.gt.4.0d+0) go to 21 + do 22 j=iplus,n + ll=ll+1 + hd(j)=hd(j)-del*hm(ll) + 22 hm(ll)=hm(ll)+b*hd(j) + go to 23 + 21 gm=honm/hon + do 24 j=iplus,n + ll=ll+1 + y=hm(ll) + hm(ll)=b*hd(j)+y*gm + 24 hd(j)=hd(j)-del*y + 23 continue + honm=hon + ll=ll+1 + 98 continue +c + 20 continue + if(ir.lt.0)ir=-ir + go to 999 + 100 continue + hm(1)=hm(1)+hno *hd(1)**2 + ir=1 + if(hm(1).gt.0.0d+0) go to 999 + hm(1)=0.0d+0 + ir=0 + 999 continue + return + end diff --git a/modules/optimization/src/fortran/majour.lo b/modules/optimization/src/fortran/majour.lo new file mode 100755 index 000000000..9063bfdfe --- /dev/null +++ b/modules/optimization/src/fortran/majour.lo @@ -0,0 +1,12 @@ +# src/fortran/majour.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/majour.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/majysa.f b/modules/optimization/src/fortran/majysa.f new file mode 100755 index 000000000..a87acce23 --- /dev/null +++ b/modules/optimization/src/fortran/majysa.f @@ -0,0 +1,61 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine majysa(n,nt,np,y,s,ys,lb,g,x,g1,x1,index,ialg,nb) +c +c mise a jour des vecteurs ({y}(i),{s}(i),ys(i),i=1,np) + implicit double precision (a-h,o-z) + dimension y(nt,n),s(nt,n),ys(nt),g(n),x(n),g1(n),x1(n) + integer index(n),ialg(15) +c +c -----mise a jour de y(lb, ) , s(lb, ) , ys(lb) + do 100 i=1,n + y(lb,i)=g(i)-g1(i) + s(lb,i)=x(i)-x1(i) +100 continue + ys(lb)=0 + do 200 i=1,n + ys(lb)=ys(lb)+y(lb,i)*s(lb,i) +200 continue +c +c accumulation eventuelle + if(ialg(8).eq.5.and.np.gt.0) then + do 20 i=1,n + y(1,i)=y(1,i) + y(lb,i) + s(1,i)=s(1,i) + s(lb,i) +20 continue + ys(1)=0 + do 30 i=1,n +30 ys(1)=ys(1)+y(1,i)*s(1,i) + endif +c +c +c -----mise a jour de np et index + if(np.lt.nt) then + np = np +1 + index(lb)=np + else + ij=lb + do 300 i=nb,nt + ij=ij+1 + if(ij.gt.nt) ij=nb + index(i)=ij +300 continue + endif +c +c ------chercher la prochaine place libre + if(lb.eq.nt) then + lb=nb + else + lb=lb+1 + endif +c +c -------------- + return + end diff --git a/modules/optimization/src/fortran/majysa.lo b/modules/optimization/src/fortran/majysa.lo new file mode 100755 index 000000000..47d04e54d --- /dev/null +++ b/modules/optimization/src/fortran/majysa.lo @@ -0,0 +1,12 @@ +# src/fortran/majysa.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/majysa.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/majz.f b/modules/optimization/src/fortran/majz.f new file mode 100755 index 000000000..c3e2251c1 --- /dev/null +++ b/modules/optimization/src/fortran/majz.f @@ -0,0 +1,60 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine majz(n,np,nt,y,s,z,ys,zs,diag,index) +c +c mise a jour de ({z}(i),zs(i), i=1,np). +c {z}(i)=[b](i-1)*{s}(i), [b](i) est definie par ({y}(j),{s}(j),{z}(j) +c , j=1,i) et {diag}. +c zs(i)=<z>(i)*{s}(i) +c + implicit double precision (a-h,o-z) + dimension y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt),diag(n) + integer index(nt) +c + l=index(1) + do 100 jj=1,n + z(l,jj)=diag(jj)*s(l,jj) +100 continue +c + zs(l)=0 + do 110 jj=1,n + zs(l)=zs(l)+z(l,jj)*s(l,jj) +110 continue +c +c + if(np.eq.1) return +c + do 200 i=2,np + l=index(i) + do 210 jj=1,n + z(l,jj)=diag(jj)*s(l,jj) +210 continue + do 220 j=1,i-1 + psy=0 + psz=0 + jl=index(j) + do 230 jj=1,n + psy=psy+y(jl,jj)*s(l,jj) + psz=psz+z(jl,jj)*s(l,jj) +230 continue + do 240 jj=1,n + z(l,jj)=z(l,jj)+psy*y(jl,jj)/ys(jl)-psz*z(jl,jj) + & /zs(jl) +240 continue +220 continue +c + zs(l)=0 + do 250 jj=1,n + zs(l)=zs(l)+z(l,jj)*s(l,jj) +250 continue +200 continue +c + return + end diff --git a/modules/optimization/src/fortran/majz.lo b/modules/optimization/src/fortran/majz.lo new file mode 100755 index 000000000..0cef69dd4 --- /dev/null +++ b/modules/optimization/src/fortran/majz.lo @@ -0,0 +1,12 @@ +# src/fortran/majz.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/majz.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/.deps/.dirstamp b/modules/optimization/src/fortran/minpack/.deps/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.deps/.dirstamp diff --git a/modules/optimization/src/fortran/minpack/.dirstamp b/modules/optimization/src/fortran/minpack/.dirstamp new file mode 100755 index 000000000..e69de29bb --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.dirstamp diff --git a/modules/optimization/src/fortran/minpack/.libs/dogleg.o b/modules/optimization/src/fortran/minpack/.libs/dogleg.o Binary files differnew file mode 100755 index 000000000..4cd25d4f4 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/dogleg.o diff --git a/modules/optimization/src/fortran/minpack/.libs/dpmpar.o b/modules/optimization/src/fortran/minpack/.libs/dpmpar.o Binary files differnew file mode 100755 index 000000000..797935082 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/dpmpar.o diff --git a/modules/optimization/src/fortran/minpack/.libs/enorm.o b/modules/optimization/src/fortran/minpack/.libs/enorm.o Binary files differnew file mode 100755 index 000000000..7a1a9c1ee --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/enorm.o diff --git a/modules/optimization/src/fortran/minpack/.libs/fdjac1.o b/modules/optimization/src/fortran/minpack/.libs/fdjac1.o Binary files differnew file mode 100755 index 000000000..4d09f3b13 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/fdjac1.o diff --git a/modules/optimization/src/fortran/minpack/.libs/fdjac2.o b/modules/optimization/src/fortran/minpack/.libs/fdjac2.o Binary files differnew file mode 100755 index 000000000..da6c3dacf --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/fdjac2.o diff --git a/modules/optimization/src/fortran/minpack/.libs/hybrd.o b/modules/optimization/src/fortran/minpack/.libs/hybrd.o Binary files differnew file mode 100755 index 000000000..c0adc0563 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/hybrd.o diff --git a/modules/optimization/src/fortran/minpack/.libs/hybrd1.o b/modules/optimization/src/fortran/minpack/.libs/hybrd1.o Binary files differnew file mode 100755 index 000000000..3d0c9b9d9 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/hybrd1.o diff --git a/modules/optimization/src/fortran/minpack/.libs/hybrj.o b/modules/optimization/src/fortran/minpack/.libs/hybrj.o Binary files differnew file mode 100755 index 000000000..730aef48c --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/hybrj.o diff --git a/modules/optimization/src/fortran/minpack/.libs/hybrj1.o b/modules/optimization/src/fortran/minpack/.libs/hybrj1.o Binary files differnew file mode 100755 index 000000000..5e1eea436 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/hybrj1.o diff --git a/modules/optimization/src/fortran/minpack/.libs/lmder.o b/modules/optimization/src/fortran/minpack/.libs/lmder.o Binary files differnew file mode 100755 index 000000000..cff7c5a07 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/lmder.o diff --git a/modules/optimization/src/fortran/minpack/.libs/lmdif.o b/modules/optimization/src/fortran/minpack/.libs/lmdif.o Binary files differnew file mode 100755 index 000000000..cb64e6af1 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/lmdif.o diff --git a/modules/optimization/src/fortran/minpack/.libs/lmpar.o b/modules/optimization/src/fortran/minpack/.libs/lmpar.o Binary files differnew file mode 100755 index 000000000..76c92f996 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/lmpar.o diff --git a/modules/optimization/src/fortran/minpack/.libs/qform.o b/modules/optimization/src/fortran/minpack/.libs/qform.o Binary files differnew file mode 100755 index 000000000..921996395 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/qform.o diff --git a/modules/optimization/src/fortran/minpack/.libs/qrfac.o b/modules/optimization/src/fortran/minpack/.libs/qrfac.o Binary files differnew file mode 100755 index 000000000..098098106 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/qrfac.o diff --git a/modules/optimization/src/fortran/minpack/.libs/qrsolv.o b/modules/optimization/src/fortran/minpack/.libs/qrsolv.o Binary files differnew file mode 100755 index 000000000..900c04c24 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/qrsolv.o diff --git a/modules/optimization/src/fortran/minpack/.libs/r1mpyq.o b/modules/optimization/src/fortran/minpack/.libs/r1mpyq.o Binary files differnew file mode 100755 index 000000000..17d7d6061 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/r1mpyq.o diff --git a/modules/optimization/src/fortran/minpack/.libs/r1updt.o b/modules/optimization/src/fortran/minpack/.libs/r1updt.o Binary files differnew file mode 100755 index 000000000..0ea9c7a9d --- /dev/null +++ b/modules/optimization/src/fortran/minpack/.libs/r1updt.o diff --git a/modules/optimization/src/fortran/minpack/dogleg.f b/modules/optimization/src/fortran/minpack/dogleg.f new file mode 100755 index 000000000..575d2dd0f --- /dev/null +++ b/modules/optimization/src/fortran/minpack/dogleg.f @@ -0,0 +1,177 @@ + subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) + integer n,lr + double precision delta + double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) +c ********** +c +c subroutine dogleg +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, the +c problem is to determine the convex combination x of the +c gauss-newton and scaled gradient directions that minimizes +c (a*x - b) in the least squares sense, subject to the +c restriction that the euclidean norm of d*x be at most delta. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization of a. that is, if a = q*r, where q has +c orthogonal columns and r is an upper triangular matrix, +c then dogleg expects the full upper triangle of r and +c the first n components of (q transpose)*b. +c +c the subroutine statement is +c +c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an input array of length lr which must contain the upper +c triangular matrix r stored by rows. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c x is an output array of length n which contains the desired +c convex combination of the gauss-newton direction and the +c scaled gradient direction. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dlamch,enorm +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jj,jp1,k,l + double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, + * temp,zero + double precision dlamch,enorm + data one,zero /1.0d0,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dlamch('p') +c +c first, calculate the gauss-newton direction. +c + jj = (n*(n + 1))/2 + 1 + do 50 k = 1, n + j = n - k + 1 + jp1 = j + 1 + jj = jj - k + l = jj + 1 + sum = zero + if (n .lt. jp1) go to 20 + do 10 i = jp1, n + sum = sum + r(l)*x(i) + l = l + 1 + 10 continue + 20 continue + temp = r(jj) + if (temp .ne. zero) go to 40 + l = j + do 30 i = 1, j + temp = dmax1(temp,dabs(r(l))) + l = l + n - i + 30 continue + temp = epsmch*temp + if (temp .eq. zero) temp = epsmch + 40 continue + x(j) = (qtb(j) - sum)/temp + 50 continue +c +c test whether the gauss-newton direction is acceptable. +c + do 60 j = 1, n + wa1(j) = zero + wa2(j) = diag(j)*x(j) + 60 continue + qnorm = enorm(n,wa2) + if (qnorm .le. delta) go to 140 +c +c the gauss-newton direction is not acceptable. +c next, calculate the scaled gradient direction. +c + l = 1 + do 80 j = 1, n + temp = qtb(j) + do 70 i = j, n + wa1(i) = wa1(i) + r(l)*temp + l = l + 1 + 70 continue + wa1(j) = wa1(j)/diag(j) + 80 continue +c +c calculate the norm of the scaled gradient and test for +c the special case in which the scaled gradient is zero. +c + gnorm = enorm(n,wa1) + sgnorm = zero + alpha = delta/qnorm + if (gnorm .eq. zero) go to 120 +c +c calculate the point along the scaled gradient +c at which the quadratic is minimized. +c + do 90 j = 1, n + wa1(j) = (wa1(j)/gnorm)/diag(j) + 90 continue + l = 1 + do 110 j = 1, n + sum = zero + do 100 i = j, n + sum = sum + r(l)*wa1(i) + l = l + 1 + 100 continue + wa2(j) = sum + 110 continue + temp = enorm(n,wa2) + sgnorm = (gnorm/temp)/temp +c +c test whether the scaled gradient direction is acceptable. +c + alpha = zero + if (sgnorm .ge. delta) go to 120 +c +c the scaled gradient direction is not acceptable. +c finally, calculate the point along the dogleg +c at which the quadratic is minimized. +c + bnorm = enorm(n,qtb) + temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) + temp = temp - (delta/qnorm)*(sgnorm/delta)**2 + * + dsqrt((temp-(delta/qnorm))**2 + * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) + alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp + 120 continue +c +c form appropriate convex combination of the gauss-newton +c direction and the scaled gradient direction. +c + temp = (one - alpha)*dmin1(sgnorm,delta) + do 130 j = 1, n + x(j) = temp*wa1(j) + alpha*x(j) + 130 continue + 140 continue + return +c +c last card of subroutine dogleg. +c + end diff --git a/modules/optimization/src/fortran/minpack/dogleg.lo b/modules/optimization/src/fortran/minpack/dogleg.lo new file mode 100755 index 000000000..7308c2139 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/dogleg.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/dogleg.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dogleg.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/dpmpar.f b/modules/optimization/src/fortran/minpack/dpmpar.f new file mode 100755 index 000000000..cb6545a92 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/dpmpar.f @@ -0,0 +1,177 @@ + double precision function dpmpar(i) + integer i +c ********** +c +c Function dpmpar +c +c This function provides double precision machine parameters +c when the appropriate set of data statements is activated (by +c removing the c from column 1) and all other data statements are +c rendered inactive. Most of the parameter values were obtained +c from the corresponding Bell Laboratories Port Library function. +c +c The function statement is +c +c double precision function dpmpar(i) +c +c where +c +c i is an integer input variable set to 1, 2, or 3 which +c selects the desired machine parameter. If the machine has +c t base b digits and its smallest and largest exponents are +c emin and emax, respectively, then these parameters are +c +c dpmpar(1) = b**(1 - t), the machine precision, +c +c dpmpar(2) = b**(emin - 1), the smallest magnitude, +c +c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c Argonne National Laboratory. MINPACK Project. November 1996. +c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' +c +c ********** + integer mcheps(4) + integer minmag(4) + integer maxmag(4) + double precision dmach(3) + equivalence (dmach(1),mcheps(1)) + equivalence (dmach(2),minmag(1)) + equivalence (dmach(3),maxmag(1)) +c +c Machine constants for the IBM 360/370 series, +c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, +c the Xerox Sigma 5/7/9 and the Sel systems 85/86. +c +c data mcheps(1),mcheps(2) / z34100000, z00000000 / +c data minmag(1),minmag(2) / z00100000, z00000000 / +c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / +c +c Machine constants for the Honeywell 600/6000 series. +c +c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / +c data minmag(1),minmag(2) / o402400000000, o000000000000 / +c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / +c +c Machine constants for the CDC 6000/7000 series. +c +c data mcheps(1) / 15614000000000000000b / +c data mcheps(2) / 15010000000000000000b / +c +c data minmag(1) / 00604000000000000000b / +c data minmag(2) / 00000000000000000000b / +c +c data maxmag(1) / 37767777777777777777b / +c data maxmag(2) / 37167777777777777777b / +c +c Machine constants for the PDP-10 (KA processor). +c +c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / +c data minmag(1),minmag(2) / "033400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / +c +c Machine constants for the PDP-10 (KI processor). +c +c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / +c data minmag(1),minmag(2) / "000400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / +c +c Machine constants for the PDP-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data mcheps(3),mcheps(4) / 0, 0 / +c +c data minmag(1),minmag(2) / 128, 0 / +c data minmag(3),minmag(4) / 0, 0 / +c +c data maxmag(1),maxmag(2) / 32767, -1 / +c data maxmag(3),maxmag(4) / -1, -1 / +c +c Machine constants for the Burroughs 6700/7700 systems. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o7770000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o7777777777777777 / +c +c Machine constants for the Burroughs 5700 system. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o0000000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o0007777777777777 / +c +c Machine constants for the Burroughs 1700 system. +c +c data mcheps(1) / zcc6800000 / +c data mcheps(2) / z000000000 / +c +c data minmag(1) / zc00800000 / +c data minmag(2) / z000000000 / +c +c data maxmag(1) / zdffffffff / +c data maxmag(2) / zfffffffff / +c +c Machine constants for the Univac 1100 series. +c +c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / +c data minmag(1),minmag(2) / o000040000000, o000000000000 / +c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / +c +c Machine constants for the Data General Eclipse S/200. +c +c Note - it may be appropriate to include the following card - +c static dmach(3) +c +c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ +c data mcheps/32020k,3*0/ +c +c Machine constants for the Harris 220. +c +c data mcheps(1),mcheps(2) / '20000000, '00000334 / +c data minmag(1),minmag(2) / '20000000, '00000201 / +c data maxmag(1),maxmag(2) / '37777777, '37777577 / +c +c Machine constants for the Cray-1. +c +c data mcheps(1) / 0376424000000000000000b / +c data mcheps(2) / 0000000000000000000000b / +c +c data minmag(1) / 0200034000000000000000b / +c data minmag(2) / 0000000000000000000000b / +c +c data maxmag(1) / 0577777777777777777777b / +c data maxmag(2) / 0000007777777777777776b / +c +c Machine constants for the Prime 400. +c +c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / +c data minmag(1),minmag(2) / :10000000000, :00000100000 / +c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / +c +c Machine constants for the VAX-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data minmag(1),minmag(2) / 128, 0 / +c data maxmag(1),maxmag(2) / -32769, -1 / +c +c Machine constants for IEEE machines. +c + data dmach(1) /2.22044604926d-16/ + data dmach(2) /2.22507385852d-308/ + data dmach(3) /1.79769313485d+308/ +c + dpmpar = dmach(i) + return +c +c Last card of function dpmpar. +c + end diff --git a/modules/optimization/src/fortran/minpack/dpmpar.lo b/modules/optimization/src/fortran/minpack/dpmpar.lo new file mode 100755 index 000000000..76667ece2 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/dpmpar.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/dpmpar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/dpmpar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/enorm.f b/modules/optimization/src/fortran/minpack/enorm.f new file mode 100755 index 000000000..2cb5b607e --- /dev/null +++ b/modules/optimization/src/fortran/minpack/enorm.f @@ -0,0 +1,108 @@ + double precision function enorm(n,x) + integer n + double precision x(n) +c ********** +c +c function enorm +c +c given an n-vector x, this function calculates the +c euclidean norm of x. +c +c the euclidean norm is computed by accumulating the sum of +c squares in three different sums. the sums of squares for the +c small and large components are scaled so that no overflows +c occur. non-destructive underflows are permitted. underflows +c and overflows do not occur in the computation of the unscaled +c sum of squares for the intermediate components. +c the definitions of small, intermediate and large components +c depend on two constants, rdwarf and rgiant. the main +c restrictions on these constants are that rdwarf**2 not +c underflow and rgiant**2 not overflow. the constants +c given here are suitable for every known computer. +c +c the function statement is +c +c double precision function enorm(n,x) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i + double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, + * x1max,x3max,zero + data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do 90 i = 1, n + xabs = dabs(x(i)) + if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 + if (xabs .le. rdwarf) go to 30 +c +c sum for large components. +c + if (xabs .le. x1max) go to 10 + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + go to 20 + 10 continue + s1 = s1 + (xabs/x1max)**2 + 20 continue + go to 60 + 30 continue +c +c sum for small components. +c + if (xabs .le. x3max) go to 40 + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + go to 50 + 40 continue + if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 + 50 continue + 60 continue + go to 80 + 70 continue +c +c sum for intermediate components. +c + s2 = s2 + xabs**2 + 80 continue + 90 continue +c +c calculation of norm. +c + if (s1 .eq. zero) go to 100 + enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) + go to 130 + 100 continue + if (s2 .eq. zero) go to 110 + if (s2 .ge. x3max) + * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 .lt. x3max) + * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) + go to 120 + 110 continue + enorm = x3max*dsqrt(s3) + 120 continue + 130 continue + return +c +c last card of function enorm. +c + end diff --git a/modules/optimization/src/fortran/minpack/enorm.lo b/modules/optimization/src/fortran/minpack/enorm.lo new file mode 100755 index 000000000..aa2695c2a --- /dev/null +++ b/modules/optimization/src/fortran/minpack/enorm.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/enorm.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/enorm.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/fdjac1.f b/modules/optimization/src/fortran/minpack/fdjac1.f new file mode 100755 index 000000000..9ac3c0c25 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/fdjac1.f @@ -0,0 +1,152 @@ + subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, + * wa1,wa2) + external fcn + integer n,ldfjac,iflag,ml,mu + double precision epsfcn + double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n) +c ********** +c +c subroutine fdjac1 +c +c this subroutine computes a forward-difference approximation +c to the n by n jacobian matrix associated with a specified +c problem of n functions in n variables. if the jacobian has +c a banded form, then function evaluations are saved by only +c approximating the nonzero terms. +c +c the subroutine statement is +c +c subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, +c wa1,wa2) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of fdjac1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an input array of length n. +c +c fvec is an input array of length n which must contain the +c functions evaluated at x. +c +c fjac is an output n by n array which contains the +c approximation to the jacobian matrix evaluated at x. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c iflag is an integer variable which can be used to terminate +c the execution of fdjac1. see description of fcn. +c +c ml is a nonnegative integer input variable which specifies +c the number of subdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c ml to at least n - 1. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c mu is a nonnegative integer input variable which specifies +c the number of superdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c mu to at least n - 1. +c +c wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at +c least n, then the jacobian is considered dense, and wa2 is +c not referenced. +c +c subprograms called +c +c minpack-supplied ... dlamch +c +c fortran-supplied ... dabs,dmax1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,k,msum + double precision eps,epsmch,h,temp,zero + double precision dlamch + data zero /0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dlamch('p') +c + eps = dsqrt(dmax1(epsfcn,epsmch)) + msum = ml + mu + 1 + if (msum .lt. n) go to 40 +c +c computation of dense approximate jacobian. +c + do 20 j = 1, n + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call fcn(n,x,wa1,iflag) + if (iflag .lt. 0) go to 30 + x(j) = temp + do 10 i = 1, n + fjac(i,j) = (wa1(i) - fvec(i))/h + 10 continue + 20 continue + 30 continue + go to 110 + 40 continue +c +c computation of banded approximate jacobian. +c + do 90 k = 1, msum + do 60 j = k, n, msum + wa2(j) = x(j) + h = eps*dabs(wa2(j)) + if (h .eq. zero) h = eps + x(j) = wa2(j) + h + 60 continue + call fcn(n,x,wa1,iflag) + if (iflag .lt. 0) go to 100 + do 80 j = k, n, msum + x(j) = wa2(j) + h = eps*dabs(wa2(j)) + if (h .eq. zero) h = eps + do 70 i = 1, n + fjac(i,j) = zero + if (i .ge. j - mu .and. i .le. j + ml) + * fjac(i,j) = (wa1(i) - fvec(i))/h + 70 continue + 80 continue + 90 continue + 100 continue + 110 continue + return +c +c last card of subroutine fdjac1. +c + end + diff --git a/modules/optimization/src/fortran/minpack/fdjac1.lo b/modules/optimization/src/fortran/minpack/fdjac1.lo new file mode 100755 index 000000000..2b2dc9c47 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/fdjac1.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/fdjac1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fdjac1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/fdjac2.f b/modules/optimization/src/fortran/minpack/fdjac2.f new file mode 100755 index 000000000..69a376747 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/fdjac2.f @@ -0,0 +1,108 @@ + subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) + external fcn + integer m,n,ldfjac,iflag + double precision epsfcn + double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) +c ********** +c +c subroutine fdjac2 +c +c this subroutine computes a forward-difference approximation +c to the m by n jacobian matrix associated with a specified +c problem of m functions in n variables. +c +c the subroutine statement is +c +c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of fdjac2. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an input array of length n. +c +c fvec is an input array of length m which must contain the +c functions evaluated at x. +c +c fjac is an output m by n array which contains the +c approximation to the jacobian matrix evaluated at x. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c iflag is an integer variable which can be used to terminate +c the execution of fdjac2. see description of fcn. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c wa is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dlamch +c +c fortran-supplied ... dabs,dmax1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j + double precision eps,epsmch,h,temp,zero + double precision dlamch + data zero /0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dlamch('p') +c + eps = dsqrt(dmax1(epsfcn,epsmch)) + do 20 j = 1, n + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call fcn(m,n,x,wa,iflag) + if (iflag .lt. 0) go to 30 + x(j) = temp + do 10 i = 1, m + fjac(i,j) = (wa(i) - fvec(i))/h + 10 continue + 20 continue + 30 continue + return +c +c last card of subroutine fdjac2. +c + end diff --git a/modules/optimization/src/fortran/minpack/fdjac2.lo b/modules/optimization/src/fortran/minpack/fdjac2.lo new file mode 100755 index 000000000..aa99b01b5 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/fdjac2.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/fdjac2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/fdjac2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/hybrd.f b/modules/optimization/src/fortran/minpack/hybrd.f new file mode 100755 index 000000000..5747c9a78 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrd.f @@ -0,0 +1,459 @@ + subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, + * mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, + * qtf,wa1,wa2,wa3,wa4) + integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr + double precision xtol,epsfcn,factor + double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) + external fcn +c ********** +c +c subroutine hybrd +c +c the purpose of hybrd is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn, +c diag,mode,factor,nprint,info,nfev,fjac, +c ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrd. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn is at least maxfev +c by the end of an iteration. +c +c ml is a nonnegative integer input variable which specifies +c the number of subdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c ml to at least n - 1. +c +c mu is a nonnegative integer input variable which specifies +c the number of superdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c mu to at least n - 1. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn has reached or exceeded +c maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dlamch,enorm,fdjac1, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,min0,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dlamch,enorm + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dlamch('p') +c + info = 0 + iflag = 0 + nfev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 + * .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero + * .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c determine the number of calls to fcn needed to compute +c the jacobian matrix. +c + msum = min0(ml+mu+1,n) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, + * wa2) + nfev = nfev + msum + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian approximation +c by forward differences. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,iflag) + return +c +c last card of subroutine hybrd. +c + end diff --git a/modules/optimization/src/fortran/minpack/hybrd.lo b/modules/optimization/src/fortran/minpack/hybrd.lo new file mode 100755 index 000000000..e4e1d7b58 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrd.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/hybrd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hybrd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/hybrd1.f b/modules/optimization/src/fortran/minpack/hybrd1.f new file mode 100755 index 000000000..c0a859275 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrd1.f @@ -0,0 +1,123 @@ + subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) + integer n,info,lwa + double precision tol + double precision x(n),fvec(n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrd1 +c +c the purpose of hybrd1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrd. the user +c must provide a subroutine which calculates the functions. +c the jacobian is then calculated by a forward-difference +c approximation. +c +c the subroutine statement is +c +c subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrd1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn has reached or exceeded +c 200*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(3*n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrd +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint + double precision epsfcn,factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) + * go to 20 +c +c call hybrd. +c + maxfev = 200*(n + 1) + xtol = tol + ml = n - 1 + mu = n - 1 + epsfcn = zero + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + index = 6*n + lr + call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, + * factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, + * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrd1. +c + end diff --git a/modules/optimization/src/fortran/minpack/hybrd1.lo b/modules/optimization/src/fortran/minpack/hybrd1.lo new file mode 100755 index 000000000..0346e4b59 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrd1.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/hybrd1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hybrd1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/hybrj.f b/modules/optimization/src/fortran/minpack/hybrj.f new file mode 100755 index 000000000..bbf9c5888 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrj.f @@ -0,0 +1,441 @@ + subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, + * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, + * wa3,wa4) + integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr + double precision xtol,factor + double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) +c ********** +c +c subroutine hybrj +c +c the purpose of hybrj is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, +c mode,factor,nprint,info,nfev,njev,r,lr,qtf, +c wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. fvec and fjac should not be altered. +c if nprint is not positive, no special calls of fcn +c with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dlamch,enorm, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dlamch,enorm + external fcn + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dlamch('p') +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero + * .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine hybrj. +c + end diff --git a/modules/optimization/src/fortran/minpack/hybrj.lo b/modules/optimization/src/fortran/minpack/hybrj.lo new file mode 100755 index 000000000..5420f00ab --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrj.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/hybrj.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hybrj.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/hybrj1.f b/modules/optimization/src/fortran/minpack/hybrj1.f new file mode 100755 index 000000000..9f51c4965 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrj1.f @@ -0,0 +1,127 @@ + subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + integer n,ldfjac,info,lwa + double precision tol + double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrj1 +c +c the purpose of hybrj1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrj. the user +c must provide a subroutine which calculates the functions +c and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrj +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer j,lr,maxfev,mode,nfev,njev,nprint + double precision factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero + * .or. lwa .lt. (n*(n + 13))/2) go to 20 +c +c call hybrj. +c + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, + * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrj1. +c + end diff --git a/modules/optimization/src/fortran/minpack/hybrj1.lo b/modules/optimization/src/fortran/minpack/hybrj1.lo new file mode 100755 index 000000000..da687fd17 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/hybrj1.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/hybrj1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/hybrj1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/lmder.f b/modules/optimization/src/fortran/minpack/lmder.f new file mode 100755 index 000000000..8797d8bed --- /dev/null +++ b/modules/optimization/src/fortran/minpack/lmder.f @@ -0,0 +1,452 @@ + subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, + * maxfev,diag,mode,factor,nprint,info,nfev,njev, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev + integer ipvt(n) + double precision ftol,xtol,gtol,factor + double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) +c ********** +c +c subroutine lmder +c +c the purpose of lmder is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, +c maxfev,diag,mode,factor,nprint,info,nfev, +c njev,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) +c integer m,n,ldfjac,iflag +c double precision x(n),fvec(m),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmder. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.).100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x, fvec, and fjac +c available for printing. fvec and fjac should not be +c altered. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,lmpar,qrfac +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 40 continue +c +c compute the qr factorization of the jacobian. +c + call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 80 + if (mode .eq. 2) go to 60 + do 50 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 50 continue + 60 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 70 j = 1, n + wa3(j) = diag(j)*x(j) + 70 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 80 continue +c +c form (q transpose)*fvec and store the first n components in +c qtf. +c + do 90 i = 1, m + wa4(i) = fvec(i) + 90 continue + do 130 j = 1, n + if (fjac(j,j) .eq. zero) go to 120 + sum = zero + do 100 i = j, m + sum = sum + fjac(i,j)*wa4(i) + 100 continue + temp = -sum/fjac(j,j) + do 110 i = j, m + wa4(i) = wa4(i) + fjac(i,j)*temp + 110 continue + 120 continue + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + 130 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 170 + do 160 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 150 + sum = zero + do 140 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 140 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 150 continue + 160 continue + 170 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 300 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 190 + do 180 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 180 continue + 190 continue +c +c beginning of the inner loop. +c + 200 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 210 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 210 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 230 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 220 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 220 continue + 230 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 240 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 260 + 240 continue + if (par .ne. zero .and. ratio .lt. p75) go to 250 + delta = pnorm/p5 + par = p5*par + 250 continue + 260 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 290 +c +c successful iteration. update x, fvec, and their norms. +c + do 270 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 270 continue + do 280 i = 1, m + fvec(i) = wa4(i) + 280 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 290 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 300 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 200 +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine lmder. +c + end diff --git a/modules/optimization/src/fortran/minpack/lmder.lo b/modules/optimization/src/fortran/minpack/lmder.lo new file mode 100755 index 000000000..bb7a28e4b --- /dev/null +++ b/modules/optimization/src/fortran/minpack/lmder.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/lmder.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/lmder.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/lmdif.f b/modules/optimization/src/fortran/minpack/lmdif.f new file mode 100755 index 000000000..dd3d4ee25 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/lmdif.f @@ -0,0 +1,454 @@ + subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, + * diag,mode,factor,nprint,info,nfev,fjac,ldfjac, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,maxfev,mode,nprint,info,nfev,ldfjac + integer ipvt(n) + double precision ftol,xtol,gtol,epsfcn,factor + double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) + external fcn +c ********** +c +c subroutine lmdif +c +c the purpose of lmdif is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, +c diag,mode,factor,nprint,info,nfev,fjac, +c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmdif. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn is at least +c maxfev by the end of an iteration. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn has reached or +c exceeded maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c calculate the jacobian matrix. +c + iflag = 2 + call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) + nfev = nfev + n + if (iflag .lt. 0) go to 300 +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) + if (iflag .lt. 0) go to 300 + 40 continue +c +c compute the qr factorization of the jacobian. +c + call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 80 + if (mode .eq. 2) go to 60 + do 50 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 50 continue + 60 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 70 j = 1, n + wa3(j) = diag(j)*x(j) + 70 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 80 continue +c +c form (q transpose)*fvec and store the first n components in +c qtf. +c + do 90 i = 1, m + wa4(i) = fvec(i) + 90 continue + do 130 j = 1, n + if (fjac(j,j) .eq. zero) go to 120 + sum = zero + do 100 i = j, m + sum = sum + fjac(i,j)*wa4(i) + 100 continue + temp = -sum/fjac(j,j) + do 110 i = j, m + wa4(i) = wa4(i) + fjac(i,j)*temp + 110 continue + 120 continue + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + 130 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 170 + do 160 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 150 + sum = zero + do 140 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 140 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 150 continue + 160 continue + 170 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 300 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 190 + do 180 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 180 continue + 190 continue +c +c beginning of the inner loop. +c + 200 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 210 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 210 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 230 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 220 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 220 continue + 230 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 240 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 260 + 240 continue + if (par .ne. zero .and. ratio .lt. p75) go to 250 + delta = pnorm/p5 + par = p5*par + 250 continue + 260 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 290 +c +c successful iteration. update x, fvec, and their norms. +c + do 270 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 270 continue + do 280 i = 1, m + fvec(i) = wa4(i) + 280 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 290 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 300 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 200 +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) + return +c +c last card of subroutine lmdif. +c + end diff --git a/modules/optimization/src/fortran/minpack/lmdif.lo b/modules/optimization/src/fortran/minpack/lmdif.lo new file mode 100755 index 000000000..babcc16e5 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/lmdif.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/lmdif.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/lmdif.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/lmpar.f b/modules/optimization/src/fortran/minpack/lmpar.f new file mode 100755 index 000000000..26c422a79 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/lmpar.f @@ -0,0 +1,264 @@ + subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, + * wa2) + integer n,ldr + integer ipvt(n) + double precision delta,par + double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), + * wa2(n) +c ********** +c +c subroutine lmpar +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, +c the problem is to determine a value for the parameter +c par such that if x solves the system +c +c a*x = b , sqrt(par)*d*x = 0 , +c +c in the least squares sense, and dxnorm is the euclidean +c norm of d*x, then either par is zero and +c +c (dxnorm-delta) .le. 0.1*delta , +c +c or par is positive and +c +c abs(dxnorm-delta) .le. 0.1*delta . +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then lmpar expects +c the full upper triangle of r, the permutation matrix p, +c and the first n components of (q transpose)*b. on output +c lmpar also provides an upper triangular matrix s such that +c +c t t t +c p *(a *a + par*d*d)*p = s *s . +c +c s is employed within lmpar and may be of separate interest. +c +c only a few iterations are generally needed for convergence +c of the algorithm. if, however, the limit of 10 iterations +c is reached, then the output par will contain the best +c value obtained so far. +c +c the subroutine statement is +c +c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, +c wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle +c must contain the full upper triangle of the matrix r. +c on output the full upper triangle is unaltered, and the +c strict lower triangle contains the strict upper triangle +c (transposed) of the upper triangular matrix s. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c par is a nonnegative variable. on input par contains an +c initial estimate of the levenberg-marquardt parameter. +c on output par contains the final estimate. +c +c x is an output array of length n which contains the least +c squares solution of the system a*x = b, sqrt(par)*d*x = 0, +c for the output par. +c +c sdiag is an output array of length n which contains the +c diagonal elements of the upper triangular matrix s. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm,qrsolv +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iter,j,jm1,jp1,k,l,nsing + double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, + * sum,temp,zero + double precision dpmpar,enorm + data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ +c +c dwarf is the smallest positive magnitude. +c + dwarf = dpmpar(2) +c +c compute and store in x the gauss-newton direction. if the +c jacobian is rank-deficient, obtain a least squares solution. +c + nsing = n + do 10 j = 1, n + wa1(j) = qtb(j) + if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 + if (nsing .lt. n) wa1(j) = zero + 10 continue + if (nsing .lt. 1) go to 50 + do 40 k = 1, nsing + j = nsing - k + 1 + wa1(j) = wa1(j)/r(j,j) + temp = wa1(j) + jm1 = j - 1 + if (jm1 .lt. 1) go to 30 + do 20 i = 1, jm1 + wa1(i) = wa1(i) - r(i,j)*temp + 20 continue + 30 continue + 40 continue + 50 continue + do 60 j = 1, n + l = ipvt(j) + x(l) = wa1(j) + 60 continue +c +c initialize the iteration counter. +c evaluate the function at the origin, and test +c for acceptance of the gauss-newton direction. +c + iter = 0 + do 70 j = 1, n + wa2(j) = diag(j)*x(j) + 70 continue + dxnorm = enorm(n,wa2) + fp = dxnorm - delta + if (fp .le. p1*delta) go to 220 +c +c if the jacobian is not rank deficient, the newton +c step provides a lower bound, parl, for the zero of +c the function. otherwise set this bound to zero. +c + parl = zero + if (nsing .lt. n) go to 120 + do 80 j = 1, n + l = ipvt(j) + wa1(j) = diag(l)*(wa2(l)/dxnorm) + 80 continue + do 110 j = 1, n + sum = zero + jm1 = j - 1 + if (jm1 .lt. 1) go to 100 + do 90 i = 1, jm1 + sum = sum + r(i,j)*wa1(i) + 90 continue + 100 continue + wa1(j) = (wa1(j) - sum)/r(j,j) + 110 continue + temp = enorm(n,wa1) + parl = ((fp/delta)/temp)/temp + 120 continue +c +c calculate an upper bound, paru, for the zero of the function. +c + do 140 j = 1, n + sum = zero + do 130 i = 1, j + sum = sum + r(i,j)*qtb(i) + 130 continue + l = ipvt(j) + wa1(j) = sum/diag(l) + 140 continue + gnorm = enorm(n,wa1) + paru = gnorm/delta + if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) +c +c if the input par lies outside of the interval (parl,paru), +c set par to the closer endpoint. +c + par = dmax1(par,parl) + par = dmin1(par,paru) + if (par .eq. zero) par = gnorm/dxnorm +c +c beginning of an iteration. +c + 150 continue + iter = iter + 1 +c +c evaluate the function at the current value of par. +c + if (par .eq. zero) par = dmax1(dwarf,p001*paru) + temp = dsqrt(par) + do 160 j = 1, n + wa1(j) = temp*diag(j) + 160 continue + call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) + do 170 j = 1, n + wa2(j) = diag(j)*x(j) + 170 continue + dxnorm = enorm(n,wa2) + temp = fp + fp = dxnorm - delta +c +c if the function is small enough, accept the current value +c of par. also test for the exceptional cases where parl +c is zero or the number of iterations has reached 10. +c + if (dabs(fp) .le. p1*delta + * .or. parl .eq. zero .and. fp .le. temp + * .and. temp .lt. zero .or. iter .eq. 10) go to 220 +c +c compute the newton correction. +c + do 180 j = 1, n + l = ipvt(j) + wa1(j) = diag(l)*(wa2(l)/dxnorm) + 180 continue + do 210 j = 1, n + wa1(j) = wa1(j)/sdiag(j) + temp = wa1(j) + jp1 = j + 1 + if (n .lt. jp1) go to 200 + do 190 i = jp1, n + wa1(i) = wa1(i) - r(i,j)*temp + 190 continue + 200 continue + 210 continue + temp = enorm(n,wa1) + parc = ((fp/delta)/temp)/temp +c +c depending on the sign of the function, update parl or paru. +c + if (fp .gt. zero) parl = dmax1(parl,par) + if (fp .lt. zero) paru = dmin1(paru,par) +c +c compute an improved estimate for par. +c + par = dmax1(parl,par+parc) +c +c end of an iteration. +c + go to 150 + 220 continue +c +c termination. +c + if (iter .eq. 0) par = zero + return +c +c last card of subroutine lmpar. +c + end diff --git a/modules/optimization/src/fortran/minpack/lmpar.lo b/modules/optimization/src/fortran/minpack/lmpar.lo new file mode 100755 index 000000000..9fd605ceb --- /dev/null +++ b/modules/optimization/src/fortran/minpack/lmpar.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/lmpar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/lmpar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/qform.f b/modules/optimization/src/fortran/minpack/qform.f new file mode 100755 index 000000000..087b2478b --- /dev/null +++ b/modules/optimization/src/fortran/minpack/qform.f @@ -0,0 +1,95 @@ + subroutine qform(m,n,q,ldq,wa) + integer m,n,ldq + double precision q(ldq,m),wa(m) +c ********** +c +c subroutine qform +c +c this subroutine proceeds from the computed qr factorization of +c an m by n matrix a to accumulate the m by m orthogonal matrix +c q from its factored form. +c +c the subroutine statement is +c +c subroutine qform(m,n,q,ldq,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a and the order of q. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c q is an m by m array. on input the full lower trapezoid in +c the first min(m,n) columns of q contains the factored form. +c on output q has been accumulated into a square matrix. +c +c ldq is a positive integer input variable not less than m +c which specifies the leading dimension of the array q. +c +c wa is a work array of length m. +c +c subprograms called +c +c fortran-supplied ... min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jm1,k,l,minmn,np1 + double precision one,sum,temp,zero + data one,zero /1.0d0,0.0d0/ +c +c zero out upper triangle of q in the first min(m,n) columns. +c + minmn = min0(m,n) + if (minmn .lt. 2) go to 30 + do 20 j = 2, minmn + jm1 = j - 1 + do 10 i = 1, jm1 + q(i,j) = zero + 10 continue + 20 continue + 30 continue +c +c initialize remaining columns to those of the identity matrix. +c + np1 = n + 1 + if (m .lt. np1) go to 60 + do 50 j = np1, m + do 40 i = 1, m + q(i,j) = zero + 40 continue + q(j,j) = one + 50 continue + 60 continue +c +c accumulate q from its factored form. +c + do 120 l = 1, minmn + k = minmn - l + 1 + do 70 i = k, m + wa(i) = q(i,k) + q(i,k) = zero + 70 continue + q(k,k) = one + if (wa(k) .eq. zero) go to 110 + do 100 j = k, m + sum = zero + do 80 i = k, m + sum = sum + q(i,j)*wa(i) + 80 continue + temp = sum/wa(k) + do 90 i = k, m + q(i,j) = q(i,j) - temp*wa(i) + 90 continue + 100 continue + 110 continue + 120 continue + return +c +c last card of subroutine qform. +c + end diff --git a/modules/optimization/src/fortran/minpack/qform.lo b/modules/optimization/src/fortran/minpack/qform.lo new file mode 100755 index 000000000..41df3d275 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/qform.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/qform.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qform.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/qrfac.f b/modules/optimization/src/fortran/minpack/qrfac.f new file mode 100755 index 000000000..8c5bad01d --- /dev/null +++ b/modules/optimization/src/fortran/minpack/qrfac.f @@ -0,0 +1,164 @@ + subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) + integer m,n,lda,lipvt + integer ipvt(lipvt) + logical pivot + double precision a(lda,n),rdiag(n),acnorm(n),wa(n) +c ********** +c +c subroutine qrfac +c +c this subroutine uses householder transformations with column +c pivoting (optional) to compute a qr factorization of the +c m by n matrix a. that is, qrfac determines an orthogonal +c matrix q, a permutation matrix p, and an upper trapezoidal +c matrix r with diagonal elements of nonincreasing magnitude, +c such that a*p = q*r. the householder transformation for +c column k, k = 1,2,...,min(m,n), is of the form +c +c t +c i - (1/u(k))*u*u +c +c where u has zeros in the first k-1 positions. the form of +c this transformation and the method of pivoting first +c appeared in the corresponding linpack subroutine. +c +c the subroutine statement is +c +c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a contains the matrix for +c which the qr factorization is to be computed. on output +c the strict upper trapezoidal part of a contains the strict +c upper trapezoidal part of r, and the lower trapezoidal +c part of a contains a factored form of q (the non-trivial +c elements of the u vectors described above). +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c pivot is a logical input variable. if pivot is set true, +c then column pivoting is enforced. if pivot is set false, +c then no column pivoting is done. +c +c ipvt is an integer output array of length lipvt. ipvt +c defines the permutation matrix p such that a*p = q*r. +c column j of p is column ipvt(j) of the identity matrix. +c if pivot is false, ipvt is not referenced. +c +c lipvt is a positive integer input variable. if pivot is false, +c then lipvt may be as small as 1. if pivot is true, then +c lipvt must be at least n. +c +c rdiag is an output array of length n which contains the +c diagonal elements of r. +c +c acnorm is an output array of length n which contains the +c norms of the corresponding columns of the input matrix a. +c if this information is not needed, then acnorm can coincide +c with rdiag. +c +c wa is a work array of length n. if pivot is false, then wa +c can coincide with rdiag. +c +c subprograms called +c +c minpack-supplied ... dlamch,enorm +c +c fortran-supplied ... dmax1,dsqrt,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kmax,minmn + double precision ajnorm,epsmch,one,p05,sum,temp,zero + double precision dlamch,enorm + data one,p05,zero /1.0d0,5.0d-2,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dlamch('p') +c +c compute the initial column norms and initialize several arrays. +c + do 10 j = 1, n + acnorm(j) = enorm(m,a(1,j)) + rdiag(j) = acnorm(j) + wa(j) = rdiag(j) + if (pivot) ipvt(j) = j + 10 continue +c +c reduce a to r with householder transformations. +c + minmn = min0(m,n) + do 110 j = 1, minmn + if (.not.pivot) go to 40 +c +c bring the column of largest norm into the pivot position. +c + kmax = j + do 20 k = j, n + if (rdiag(k) .gt. rdiag(kmax)) kmax = k + 20 continue + if (kmax .eq. j) go to 40 + do 30 i = 1, m + temp = a(i,j) + a(i,j) = a(i,kmax) + a(i,kmax) = temp + 30 continue + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + k = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = k + 40 continue +c +c compute the householder transformation to reduce the +c j-th column of a to a multiple of the j-th unit vector. +c + ajnorm = enorm(m-j+1,a(j,j)) + if (ajnorm .eq. zero) go to 100 + if (a(j,j) .lt. zero) ajnorm = -ajnorm + do 50 i = j, m + a(i,j) = a(i,j)/ajnorm + 50 continue + a(j,j) = a(j,j) + one +c +c apply the transformation to the remaining columns +c and update the norms. +c + jp1 = j + 1 + if (n .lt. jp1) go to 100 + do 90 k = jp1, n + sum = zero + do 60 i = j, m + sum = sum + a(i,j)*a(i,k) + 60 continue + temp = sum/a(j,j) + do 70 i = j, m + a(i,k) = a(i,k) - temp*a(i,j) + 70 continue + if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 + temp = a(j,k)/rdiag(k) + rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) + if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 + rdiag(k) = enorm(m-j,a(jp1,k)) + wa(k) = rdiag(k) + 80 continue + 90 continue + 100 continue + rdiag(j) = -ajnorm + 110 continue + return +c +c last card of subroutine qrfac. +c + end diff --git a/modules/optimization/src/fortran/minpack/qrfac.lo b/modules/optimization/src/fortran/minpack/qrfac.lo new file mode 100755 index 000000000..ceb2589a2 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/qrfac.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/qrfac.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qrfac.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/qrsolv.f b/modules/optimization/src/fortran/minpack/qrsolv.f new file mode 100755 index 000000000..f48954b35 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/qrsolv.f @@ -0,0 +1,193 @@ + subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) + integer n,ldr + integer ipvt(n) + double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) +c ********** +c +c subroutine qrsolv +c +c given an m by n matrix a, an n by n diagonal matrix d, +c and an m-vector b, the problem is to determine an x which +c solves the system +c +c a*x = b , d*x = 0 , +c +c in the least squares sense. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then qrsolv expects +c the full upper triangle of r, the permutation matrix p, +c and the first n components of (q transpose)*b. the system +c a*x = b, d*x = 0, is then equivalent to +c +c t t +c r*z = q *b , p *d*p*z = 0 , +c +c where x = p*z. if this system does not have full rank, +c then a least squares solution is obtained. on output qrsolv +c also provides an upper triangular matrix s such that +c +c t t t +c p *(a *a + d*d)*p = s *s . +c +c s is computed within qrsolv and may be of separate interest. +c +c the subroutine statement is +c +c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle +c must contain the full upper triangle of the matrix r. +c on output the full upper triangle is unaltered, and the +c strict lower triangle contains the strict upper triangle +c (transposed) of the upper triangular matrix s. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c x is an output array of length n which contains the least +c squares solution of the system a*x = b, d*x = 0. +c +c sdiag is an output array of length n which contains the +c diagonal elements of the upper triangular matrix s. +c +c wa is a work array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kp1,l,nsing + double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero + data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ +c +c copy r and (q transpose)*b to preserve input and initialize s. +c in particular, save the diagonal elements of r in x. +c + do 20 j = 1, n + do 10 i = j, n + r(i,j) = r(j,i) + 10 continue + x(j) = r(j,j) + wa(j) = qtb(j) + 20 continue +c +c eliminate the diagonal matrix d using a givens rotation. +c + do 100 j = 1, n +c +c prepare the row of d to be eliminated, locating the +c diagonal element using p from the qr factorization. +c + l = ipvt(j) + if (diag(l) .eq. zero) go to 90 + do 30 k = j, n + sdiag(k) = zero + 30 continue + sdiag(j) = diag(l) +c +c the transformations to eliminate the row of d +c modify only a single element of (q transpose)*b +c beyond the first n, which is initially zero. +c + qtbpj = zero + do 80 k = j, n +c +c determine a givens rotation which eliminates the +c appropriate element in the current row of d. +c + if (sdiag(k) .eq. zero) go to 70 + if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 + cotan = r(k,k)/sdiag(k) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + go to 50 + 40 continue + tan = sdiag(k)/r(k,k) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + 50 continue +c +c compute the modified diagonal element of r and +c the modified element of ((q transpose)*b,0). +c + r(k,k) = cos*r(k,k) + sin*sdiag(k) + temp = cos*wa(k) + sin*qtbpj + qtbpj = -sin*wa(k) + cos*qtbpj + wa(k) = temp +c +c accumulate the tranformation in the row of s. +c + kp1 = k + 1 + if (n .lt. kp1) go to 70 + do 60 i = kp1, n + temp = cos*r(i,k) + sin*sdiag(i) + sdiag(i) = -sin*r(i,k) + cos*sdiag(i) + r(i,k) = temp + 60 continue + 70 continue + 80 continue + 90 continue +c +c store the diagonal element of s and restore +c the corresponding diagonal element of r. +c + sdiag(j) = r(j,j) + r(j,j) = x(j) + 100 continue +c +c solve the triangular system for z. if the system is +c singular, then obtain a least squares solution. +c + nsing = n + do 110 j = 1, n + if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 + if (nsing .lt. n) wa(j) = zero + 110 continue + if (nsing .lt. 1) go to 150 + do 140 k = 1, nsing + j = nsing - k + 1 + sum = zero + jp1 = j + 1 + if (nsing .lt. jp1) go to 130 + do 120 i = jp1, nsing + sum = sum + r(i,j)*wa(i) + 120 continue + 130 continue + wa(j) = (wa(j) - sum)/sdiag(j) + 140 continue + 150 continue +c +c permute the components of z back to components of x. +c + do 160 j = 1, n + l = ipvt(j) + x(l) = wa(j) + 160 continue + return +c +c last card of subroutine qrsolv. +c + end diff --git a/modules/optimization/src/fortran/minpack/qrsolv.lo b/modules/optimization/src/fortran/minpack/qrsolv.lo new file mode 100755 index 000000000..e1d373098 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/qrsolv.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/qrsolv.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qrsolv.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/r1mpyq.f b/modules/optimization/src/fortran/minpack/r1mpyq.f new file mode 100755 index 000000000..ec99b96ce --- /dev/null +++ b/modules/optimization/src/fortran/minpack/r1mpyq.f @@ -0,0 +1,92 @@ + subroutine r1mpyq(m,n,a,lda,v,w) + integer m,n,lda + double precision a(lda,n),v(n),w(n) +c ********** +c +c subroutine r1mpyq +c +c given an m by n matrix a, this subroutine computes a*q where +c q is the product of 2*(n - 1) transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c and gv(i), gw(i) are givens rotations in the (i,n) plane which +c eliminate elements in the i-th and n-th planes, respectively. +c q itself is not given, rather the information to recover the +c gv, gw rotations is supplied. +c +c the subroutine statement is +c +c subroutine r1mpyq(m,n,a,lda,v,w) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a must contain the matrix +c to be postmultiplied by the orthogonal matrix q +c described above. on output a*q has replaced a. +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c v is an input array of length n. v(i) must contain the +c information necessary to recover the givens rotation gv(i) +c described above. +c +c w is an input array of length n. w(i) must contain the +c information necessary to recover the givens rotation gw(i) +c described above. +c +c subroutines called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,nmj,nm1 + double precision cos,one,sin,temp + data one /1.0d0/ +c +c apply the first set of givens rotations to a. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 50 + do 20 nmj = 1, nm1 + j = n - nmj + if (dabs(v(j)) .gt. one) cos = one/v(j) + if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(v(j)) .le. one) sin = v(j) + if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) + do 10 i = 1, m + temp = cos*a(i,j) - sin*a(i,n) + a(i,n) = sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 10 continue + 20 continue +c +c apply the second set of givens rotations to a. +c + do 40 j = 1, nm1 + if (dabs(w(j)) .gt. one) cos = one/w(j) + if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(w(j)) .le. one) sin = w(j) + if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) + do 30 i = 1, m + temp = cos*a(i,j) + sin*a(i,n) + a(i,n) = -sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 30 continue + 40 continue + 50 continue + return +c +c last card of subroutine r1mpyq. +c + end diff --git a/modules/optimization/src/fortran/minpack/r1mpyq.lo b/modules/optimization/src/fortran/minpack/r1mpyq.lo new file mode 100755 index 000000000..94c50a154 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/r1mpyq.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/r1mpyq.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/r1mpyq.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/minpack/r1updt.f b/modules/optimization/src/fortran/minpack/r1updt.f new file mode 100755 index 000000000..a8cdc64a7 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/r1updt.f @@ -0,0 +1,207 @@ + subroutine r1updt(m,n,s,ls,u,v,w,sing) + integer m,n,ls + logical sing + double precision s(ls),u(m),v(n),w(m) +c ********** +c +c subroutine r1updt +c +c given an m by n lower trapezoidal matrix s, an m-vector u, +c and an n-vector v, the problem is to determine an +c orthogonal matrix q such that +c +c t +c (s + u*v )*q +c +c is again lower trapezoidal. +c +c this subroutine determines q as the product of 2*(n - 1) +c transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c where gv(i), gw(i) are givens rotations in the (i,n) plane +c which eliminate elements in the i-th and n-th planes, +c respectively. q itself is not accumulated, rather the +c information to recover the gv, gw rotations is returned. +c +c the subroutine statement is +c +c subroutine r1updt(m,n,s,ls,u,v,w,sing) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of s. +c +c n is a positive integer input variable set to the number +c of columns of s. n must not exceed m. +c +c s is an array of length ls. on input s must contain the lower +c trapezoidal matrix s stored by columns. on output s contains +c the lower trapezoidal matrix produced as described above. +c +c ls is a positive integer input variable not less than +c (n*(2*m-n+1))/2. +c +c u is an input array of length m which must contain the +c vector u. +c +c v is an array of length n. on input v must contain the vector +c v. on output v(i) contains the information necessary to +c recover the givens rotation gv(i) described above. +c +c w is an output array of length m. w(i) contains information +c necessary to recover the givens rotation gw(i) described +c above. +c +c sing is a logical output variable. sing is set true if any +c of the diagonal elements of the output s are zero. otherwise +c sing is set false. +c +c subprograms called +c +c minpack-supplied ... dlamch +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more, +c john l. nazareth +c +c ********** + integer i,j,jj,l,nmj,nm1 + double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, + * zero + double precision dlamch + data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ +c +c giant is the largest magnitude. +c + giant = dlamch('o') +c +c initialize the diagonal element pointer. +c + jj = (n*(2*m - n + 1))/2 - (m - n) +c +c move the nontrivial part of the last column of s into w. +c + l = jj + do 10 i = n, m + w(i) = s(l) + l = l + 1 + 10 continue +c +c rotate the vector v into a multiple of the n-th unit vector +c in such a way that a spike is introduced into w. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 nmj = 1, nm1 + j = n - nmj + jj = jj - (m - j + 1) + w(j) = zero + if (v(j) .eq. zero) go to 50 +c +c determine a givens rotation which eliminates the +c j-th element of v. +c + if (dabs(v(n)) .ge. dabs(v(j))) go to 20 + cotan = v(n)/v(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 30 + 20 continue + tan = v(j)/v(n) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 30 continue +c +c apply the transformation to v and store the information +c necessary to recover the givens rotation. +c + v(n) = sin*v(j) + cos*v(n) + v(j) = tau +c +c apply the transformation to s and extend the spike in w. +c + l = jj + do 40 i = j, m + temp = cos*s(l) - sin*w(i) + w(i) = sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 40 continue + 50 continue + 60 continue + 70 continue +c +c add the spike from the rank 1 update to w. +c + do 80 i = 1, m + w(i) = w(i) + v(n)*u(i) + 80 continue +c +c eliminate the spike. +c + sing = .false. + if (nm1 .lt. 1) go to 140 + do 130 j = 1, nm1 + if (w(j) .eq. zero) go to 120 +c +c determine a givens rotation which eliminates the +c j-th element of the spike. +c + if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 + cotan = s(jj)/w(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 100 + 90 continue + tan = w(j)/s(jj) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 100 continue +c +c apply the transformation to s and reduce the spike in w. +c + l = jj + do 110 i = j, m + temp = cos*s(l) + sin*w(i) + w(i) = -sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 110 continue +c +c store the information necessary to recover the +c givens rotation. +c + w(j) = tau + 120 continue +c +c test for zero diagonal elements in the output s. +c + if (s(jj) .eq. zero) sing = .true. + jj = jj + (m - j + 1) + 130 continue + 140 continue +c +c move w back into the last column of the output s. +c + l = jj + do 150 i = n, m + s(l) = w(i) + l = l + 1 + 150 continue + if (s(jj) .eq. zero) sing = .true. + return +c +c last card of subroutine r1updt. +c + end diff --git a/modules/optimization/src/fortran/minpack/r1updt.lo b/modules/optimization/src/fortran/minpack/r1updt.lo new file mode 100755 index 000000000..eca061813 --- /dev/null +++ b/modules/optimization/src/fortran/minpack/r1updt.lo @@ -0,0 +1,12 @@ +# src/fortran/minpack/r1updt.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/r1updt.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1fc1.f b/modules/optimization/src/fortran/n1fc1.f new file mode 100755 index 000000000..33e76ae30 --- /dev/null +++ b/modules/optimization/src/fortran/n1fc1.f @@ -0,0 +1,67 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1fc1(simul,prosca,n,xn,fn,g,dxmin,df1,epsf,zero,imp, + & io,mode,iter,nsim,memax,iz,rz,dz,izs,rzs,dzs) +C dimension iz=2*(memax+1) +C dimension rz=5*n+(n+4)*memax +C dimension dz=(memax+9)*memax+8 +c + implicit double precision (a-h,o-z) + external simul, prosca + dimension iz(*), rz(*), dz(*), xn(n), g(n), izs(*), dzs(*) + real rzs(*) + dimension i5(1), d3(1), d4(1) +C + if (n.gt.0 .and. df1.gt.0.d0 .and. epsf.ge.0.d0 .and. zero.ge.0.d0 + & .and. iter.ge.0 .and. nsim.ge.0 .and. memax.ge.1 .and. + & dxmin.gt.0.d0) goto 10 + mode = 2 +C appel incoherent + call n1fc1o(io,1,i1,i2,i3,i4,i5,d1,d2,d3,d4) + goto 999 + 10 ns = 1 + ngd = ns + n + nx = ngd + n + nsa = nx + n + ngg = nsa + n + nal = ngg + n + naps = nal + memax + nanc = naps + memax + npoids = nanc + memax + nq = npoids + memax + njc = 1 + nic = njc + memax + 1 + nr = 1 + na = nr + (memax+1)*(memax+1) + ne = na + memax + 1 + nrr = ne + memax + 1 + nxga = nrr + memax + 1 + ny = nxga + memax + 1 + nw1 = ny + memax + 1 + nw2 = nw1 + memax + 1 +C + niz = 2 * (memax+1) + nrz = nq + n*memax - 1 + ndz = nw2 + memax + if (imp .gt. 0) call n1fc1o(io,2,n,memax,niz,nrz,ndz,d1,d2,d3,d4) + do 110 i = 1,niz + 110 iz(i) = 0 + do 120 i = 1,nrz + 120 rz(i) = 0.d0 + do 130 i = 1,ndz + 130 dz(i) = 0.d0 + call n1fc1a(simul,prosca,n,mode,xn,fn,g,df1,epsf,dxmin,imp,zero, + & io,ntot,iter,nsim,memax,rz(ns),rz(ngd),rz(nx),rz(nsa), + & rz(ngg),rz(nal),rz(naps),rz(nanc),rz(npoids),rz(nq), + & iz(njc),iz(nic),dz(nr),dz(na),dz(ne),dz(nrr),dz(nxga), + & dz(ny),dz(nw1),dz(nw2),izs,rzs,dzs) + iz(1) = ntot + 999 return + end diff --git a/modules/optimization/src/fortran/n1fc1.lo b/modules/optimization/src/fortran/n1fc1.lo new file mode 100755 index 000000000..1b935e74a --- /dev/null +++ b/modules/optimization/src/fortran/n1fc1.lo @@ -0,0 +1,12 @@ +# src/fortran/n1fc1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1fc1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1fc1a.f b/modules/optimization/src/fortran/n1fc1a.f new file mode 100755 index 000000000..4eb4cdffc --- /dev/null +++ b/modules/optimization/src/fortran/n1fc1a.f @@ -0,0 +1,306 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1fc1a(simul,prosca,n,mode,xn,fn,g,df0,eps0,dx,imp, + & zero,io,ntot,iter,nsim,memax,s,gd,x,sa,gg,al, + & aps,anc,poids,q,jc,ic,r,a,e,rr,xga,y,w1,w2,izs, + & rzs,dzs) +C +C minimisation d'une fonction hemiderivable par une methode de faisceau. +C la direction est obtenue par projection de l'origine +C sur un polyedre genere par un ensemble de gradients deja calcules +C et la recherche lineaire donne un pas de descente ou un pas nul. +C l'algorithme minimise f a eps0 pres (si convexite) +C ou eps0 est une tolerance donnee par l'utilisateur. +C +C mode +C <=0 mode=indic de simul +C 1 fin normale +C 2 appel incoherent +C 3 reduire l'echelle des x +C 4 max iterations +C 5 max simulations +C 6 impossible d'aller au dela de dx +C 7 fprf2 mis en echec +C 8 on commence a boucler +C imp +C <0 indic=1 toutes les -imp iterations +C 0 pas d'impressions +C 1 impressions initiales et finales +C 2 impressions a chaque convergence +C 3 une impression par iteration +C 4 informations n1fc1 et nlis2 +C >4 debug +C 5 tolerances diverses +C 6 poids +C >6 fprf2 +C -------------------------------------------------- +C fait appel aux subroutines suivantes: +C --------subroutine fprf2 (calcul de la direction) +C --------subroutines fremf2 et ffinf1 (esclaves de fprf2) +C --------subroutine frdf1 (reduction du faisceau) +C --------subroutine nlis2 (recherche lineaire) +C --------subroutine simul (module de simulation) +C --------subroutine prosca (produit de dualite donnant le gradient) +C cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +C cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + implicit double precision (a-h,o-z) + external simul, prosca + dimension xn(n), g(n), izs(*), dzs(*), x(n), gd(n), gg(n) + dimension s(n), sa(n), jc(*), ic(*), r(*), a(*), e(*), rr(*), + & xga(*), y(*), w1(*), w2(*) + dimension q(*), al(memax), aps(memax), anc(memax), poids(memax) + real rzs(*) + dimension i5(1), d3(1), d4(1) +C +C initialisations +C + itmax = iter + iter = 0 + itimp = 0 + napmax = nsim + nsim = 1 + logic = 1 + logic2 = 0 + tmax = 1.d20 + eps = df0 + epsm = eps + df = df0 + mode = 1 + ntot = 0 + iflag = 0 +C +C initialisation du faisceau +C calcul du diametre de l'epure et du test d'arret +C + aps(1) = 0.d0 + anc(1) = 0.d0 + poids(1) = 0.d0 + nta = 0 + kgrad = 1 + memax1 = memax + 1 + do 50 i = 1,n + 50 q(i) = -g(i) + call prosca(n,g,g,ps,izs,rzs,dzs) + if (ps .gt. 0.d0) goto 60 + mode = 2 + if (imp .ne. 0) call n1fc1o(io,3,i1,i2,i3,i4,i5,d1,d2,d3,d4) + goto 900 + 60 diam2 = 100. * df0 * df0 / ps + eta2 = 1.d-2 * eps0 * eps0 / diam2 + ap = zero * df0 / diam2 + if (imp .gt. 2) call n1fc1o(io,4,i1,i2,i3,i4,i5,d1,d2,d3,d4) +C +C boucle +C + 100 iter = iter + 1 + itimp = itimp + 1 + if (iter .lt. itmax) goto 110 + if (imp .gt. 0) call n1fc1o(io,5,iter,i2,i3,i4,i5,d1,d2,d3,d4) + mode = 4 + goto 900 + 110 ntot = ntot + 1 + if (logic .eq. 3) ro = ro * dsqrt(s2) + if (itimp .ne. -imp) goto 200 + itimp = 0 + indic = 1 + call simul(indic,n,xn,f,g,izs,rzs,dzs) +c error in user function + if(indic.eq.0) goto 990 +C +C calcul de la direction +C + 200 eps = dmin1(eps,epsm) + eps = dmax1(eps,eps0) + call fremf2(prosca,iflag,n,ntot,nta,memax1,q,poids,e,a,r,izs,rzs, + & dzs) + call fprf2(iflag,ntot,nv,io,zero,s2,eps,al,imp,u,eta2,memax1,jc, + & ic,r,a,e,rr,xga,y,w1,w2) +C +C fin anormale de fprf2 +C + if (iflag .eq. 0) goto 250 + if (imp .gt. 0) call n1fc1o(io,6,i1,i2,i3,i4,i5,d1,d2,d3,d4) + mode = 7 + goto 900 + 250 nta = ntot + call ffinf1(n,nv,jc,xga,q,s) + u = dmax1(u,0.d0) + s2 = dmax1(s2,0.d0) +C +C tests d'arret (nb. si nr g est interieur a g +C alors nr g est "nul") +C + if (nv .lt. n+2) goto 260 + eta2 = dmax1(eta2,10.d0*s2) + if (imp .ge. 2) call n1fc1o(io,7,i1,i2,i3,i4,i5,eta2,d2,d3,d4) + 260 if (s2 .gt. eta2) goto 300 +C +C calcul de la precision + z = 0.d0 + do 270 k = 1,nv + j = jc(k) - 1 + if (j .gt. 0) z = z + xga(k)*poids(j) + 270 continue + epsm = dmin1(eps,z) + if (imp.ge.2) call n1fc1o(io,8,iter,nsim,i3,i4,i5,fn,epsm,s2,d4) + if (epsm .gt. eps0) goto 280 + mode = 1 + if (imp .gt. 0) call n1fc1o(io,9,i1,i2,i3,i4,i5,d1,d2,d3,d4) + goto 900 +C +C diminution de epsilon + 280 epsm = dmax1(0.1d0*epsm,eps0) + eps = epsm + if (logic .eq. 3) tol = 0.01d0 * eps + iflag = 2 + goto 200 +C +C suite des iterations +C impressions +C + 300 if (imp .gt. 3) call n1fc1o(io,10,i1,i2,i3,i4,i5,d1,d2,d3,d4) + if (imp .gt. 2) call n1fc1o(io,11,iter,nsim,nv,i4,i5,fn,eps,s2,u) + if (imp .ge. 6) call n1fc1o(io,12,ntot,i2,i3,i4,i5,d1,d2,d3,poids) +C test de non-pivotage + if (logic .ne. 3) goto 350 + z = 0.d0 + do 310 i = 1,n + z1 = s(i) - sa(i) + 310 z = z + z1*z1 + if (z .gt. 10.d0*zero*zero*s2) goto 350 + if (imp .gt. 0) call n1fc1o(io,13,i1,i2,i3,i4,i5,d1,d2,d3,d4) + mode = 8 + goto 900 +C +C recherche lineaire +C + 350 iflag = 3 + s3 = s2 + u*eps + if (logic .eq. 3) goto 365 + ro = 2. * df / s3 + tol = 0.01d0 * eps + goto 370 + 365 ro = ro / dsqrt(s2) + tol = dmax1(0.6d0*tol,0.01d0*eps0) + 370 fa = fn + alfa = 0.2d0 + beta = 0.1d0 + fpn = -s3 + if (memax .eq. 1) tol = 0.d0 +C calcul de la resolution minimale, fonction de dx + tmin = 0.d0 + do 372 i = 1,n + 372 tmin = dmax1(tmin,dabs(s(i)/dx)) + tmin = 1.d0 / tmin + if (iter .eq. 1) roa = ro + call nlis2(simul,prosca,n,xn,fn,fpn,ro,tmin,tmax,s,s2,g,gd,alfa, + & beta,imp,io,logic,nsim,napmax,x,tol,ap,tps,tnc,gg,izs, + & rzs,dzs) + if (logic.eq.0 .or. logic.eq.2 .or. logic.eq.3) goto 380 +C sortie par anomalie dans nlis2 + if (imp .le. 0) goto 375 + if (logic.eq.6 .or. logic.lt.0) + & call n1fc1o(io,14,i1,i2,i3,i4,i5,d1,d2,d3,d4) + if (logic .eq. 4) call n1fc1o(io,15,i1,i2,i3,i4,i5,d1,d2,d3,d4) + if (logic .eq. 5) call n1fc1o(io,16,i1,i2,i3,i4,i5,d1,d2,d3,d4) + if (logic .eq. 1) call n1fc1o(io,17,i1,i2,i3,i4,i5,d1,d2,d3,d4) + 375 if (logic .eq. 1) mode = 3 + if (logic .eq. 4) mode = 5 + if (logic .eq. 5) mode = 0 + if (logic .eq. 6) mode = 6 + if (logic .lt. 0) mode = logic + goto 900 + 380 if (logic .ne. 3) goto 385 + do 382 i = 1,n + 382 sa(i) = s(i) + 385 if (iter .gt. 1) goto 390 +C +C 1ere iteration, ajustement de ap, diam et eta + if (logic .eq. 0) tps = (fn-fa) - ro*fpn + ap = zero * zero * dabs(tps) / (s2*ro*ro) + ajust = ro / roa + if (logic .ne. 3) diam2 = diam2 * ajust * ajust + if (logic .ne. 3) eta2 = eta2 / (ajust*ajust) + if (imp .ge. 2) call n1fc1o(io,18,i1,i2,i3,i4,i5,diam2,eta2,ap,d4) + 390 mm = memax - 1 + if (logic .eq. 2) mm = memax - 2 + if (ntot .le. mm) goto 400 +C +C reduction du faisceau pour entrer le nouvel element +C + call frdf1(prosca,n,ntot,mm,kgrad,al,q,s,poids,aps,anc,memax1,r,e, + & ic,izs,rzs,dzs) + iflag = 1 + nta = ntot + if (imp .ge. 2) + & call n1fc1o(io,19,iter,nsim,ntot,i4,i5,fn,d2,d3,d4) +C + 400 if (imp .ge. 5) call n1fc1o(io,20,logic,i2,i3,i4,i5,ro,tps,tnc,d4) + if (logic .eq. 3) goto 500 +C +C iteration de descente +C + iflag = min0(iflag,2) + df = fa - fn + if (ntot .eq. 0) goto 500 +C +C actualisation des poids +C + s3n = ro * dsqrt(s2) + do 430 k = 1,ntot + nk = (k-1)*n + 1 + call prosca(n,q(nk),s,ps,izs,rzs,dzs) + z1 = dabs(aps(k)+(-df+ro*ps)) + z2 = anc(k) + s3n + poids(k) = dmax1(z1,ap*z2*z2) + aps(k) = z1 + anc(k) = z2 + 430 continue +C +C actualisation de eps +C + eps = ro * s3 + kgrad = ntot + 1 +C +C nouvel element du faisceau (pour les trois types de pas) +C + 500 nt1 = ntot + 1 + if (logic .eq. 3) goto 510 + aps(nt1) = 0.d0 + anc(nt1) = 0.d0 + poids(nt1) = 0.d0 + goto 520 + 510 aps(nt1) = tps + anc(nt1) = dsqrt(tnc) + poids(nt1) = dmax1(tps,ap*tnc) + 520 nk = ntot * n + do 530 i = 1,n + nki = nk + i + 530 q(nki) = -g(i) +C +C traitement pour logic=2 (on ajoute encore un gradient) + if (logic .ne. 2) goto 550 + ntot = ntot + 1 + logic = 3 + logic2 = 1 + do 540 i = 1,n + 540 g(i) = gd(i) + goto 390 + 550 logic = logic - logic2 + logic2 = 0 + goto 100 +C +C epilogue +C + 900 if (iter .le. 1) goto 990 + do 910 i = 1,n + 910 g(i) = -s(i) + 990 return + end diff --git a/modules/optimization/src/fortran/n1fc1a.lo b/modules/optimization/src/fortran/n1fc1a.lo new file mode 100755 index 000000000..e789e001a --- /dev/null +++ b/modules/optimization/src/fortran/n1fc1a.lo @@ -0,0 +1,12 @@ +# src/fortran/n1fc1a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1fc1a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1fc1o.f b/modules/optimization/src/fortran/n1fc1o.f new file mode 100755 index 000000000..3ee915753 --- /dev/null +++ b/modules/optimization/src/fortran/n1fc1o.f @@ -0,0 +1,387 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1fc1o(unit,job,i1,i2,i3,i4,i5,d1,d2,d3,d4) +c +c impression des traces +c + implicit double precision (a-h,o-z) + integer unit,lunit,job,i1,i2,i3,i4,i5(*) + dimension d4(*),d3(*) +c + character*120 buf + + lunit=unit +c + buf=' ' + goto(11,12,13,14,15,16,17,18,19,20, + & 21,22,23,24,25,26,27,28,29,30, + & 31,32,33,34,35,36,37,38,39,40, + & 41,42,43,44,45,46,47,48,49,50, + & 51,52,53,54,55,56,57,58,59,60) job +c + 11 continue + call basout(io,lunit,'n1fc1 incorrect call') + goto 100 + 12 continue + n=i1 + memax=i2 + niz=i3 + nrz=i4 + ndz=i5(1) + write (buf,'(''entry in n1fc1 . n='',i4,'' memax='',i3)') n,memax + call basout(io,lunit,buf(1:35)) + write (buf,"(a24,i6,a6,i6,a6,i6,a1)") + & "minimal array sizes: iz(", niz, + & ") rz(", nrz, + & ") dz(", ndz, + & ")" + call basout(io,lunit,buf(1:55)) + goto 100 + 13 continue + call basout(io,lunit,'n1fc1 initial gradient norm is zero') + goto 100 + 14 continue + 1000 format (19h n1fc1 iter nsim,6x,2hfn,11x,3heps,7x,2hs2, + 19x,1hu,5x,2hnv) + goto 100 + 15 continue + iter=i1 + write(buf,'(''n1fc1 end with iter ='',i1)') i1 + call basout(io,lunit,buf(1:30)) + goto 100 + 16 continue + call basout(io,lunit,'n1fc1 Incorrect end of fprf2') + goto 100 + 17 continue + eta2=d1 + write(buf,'(''n1fc1 eta2 assigned to '',d10.3)') eta2 + call basout(io,lunit,buf(1:35)) + goto 100 + 18 continue + iter=i1 + nsim=i2 + fn=d1 + epsm=d2 + s2=d3(1) + write (buf,1018) iter,nsim,fn,epsm,s2 + 1018 format(6h n1fc1,i7,i5,d16.7,16h convergence a,d10.3,5h pres, + 13h (,d9.2,1h)) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 19 continue + call basout(io,lunit,'n1fc1 normal end') + goto 100 + 20 continue + call basout(io,lunit,' ') + goto 100 + 21 continue + iter=i1 + nsim=i2 + nv=i3 + fn=d1 + eps=d2 + s2=d3(1) + u=d4(1) + write (buf,'(''n1fc1 '',1i4,i5,2x,d14.7,3d10.2,i3)') iter, + $ nsim,fn,eps,s2,u,nv + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 22 continue + ntot=i1 + call basout(io,lunit,'n1fc1 ponderation table') + nn=ntot/7 + if(7*nn.lt.ntot) nn=nn+1 + l=0 + do 2201 i=1,nn + ln=min(7,ntot-l) + write (buf,'(7x,7d10.3)') (d4(l+j),j=1,ln) + call basout(io,lunit,buf(1:lnblnk(buf))) + l=l+7 + 2201 continue + 23 continue + call basout(io,lunit,'n1fc1 la direction ne pivote plus') + goto 100 + 24 continue + call basout(io,lunit,'n1fc1 end (dxmin reached)') + goto 100 + 25 continue + call basout(io,lunit,'n1fc1 end (nsim reached)') + goto 100 + 26 continue + call basout(io,lunit,'n1fc1 end (indic=0)') + goto 100 + 27 continue + call basout(io,lunit,'n1fc1 warning txmax reached, reduce scale') + goto 100 + 28 continue + diam1=d1 + eta2=d2 + ap=d3(1) + write (buf,2801) diam1,eta2,ap + 2801 format (6h n1fc1,12x,6hdiam1=,d10.3,4x,5heta2=,d10.3,4x, + 1 3hap=,d10.3) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 29 continue + iter=i1 + nsim=i2 + ntot=i3 + fn=d1 + write (buf,2901) iter,nsim,fn,ntot + 2901 format(6h n1fc1,i7,i5,d16.7,20h faisceau reduit a, + 1 i3,10h gradients) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 30 continue + logic=i1 + ro=d1 + tps=d2 + tnc=d3(1) + write (buf,3001) logic,ro,tps,tnc + 3001 format (6h n1fc1,10x,6hlogic=,i2,4x,3hro=,d10.3, + 1 4x,4htps=,d10.3,4x,4htnc=,d10.3) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 +c ================== +c MESSAGES de frepf2 +c ================== + 31 continue + nt1=i1 + mm1=i2 + deps=d1 + call basout(io,lunit,'a = ') + nn=nt1/10 + if(10*nn.lt.nt1) nn=nn+1 + l=0 + do 3101 i=1,nn + ln=min(10,nt1-l) + write (buf,'(6x,10d10.3)') (d3(l+j),j=1,ln) + call basout(io,lunit,buf(1:lnblnk(buf))) + l=l+10 + 3101 continue + write(buf,'('' epsilon ='',d10.3)') deps + call basout(io,lunit,buf(1:lnblnk(buf))) + + call basout(io,lunit,'(g,g) = ') + do 3103 j=1,nt1 + mej=(j-1)*mm1 + nn=j/10 + if(10*nn.lt.j) nn=nn+1 + l=0 + do 3102 i=1,nn + ln=min(10,j-l) + write (buf,'(6x,10d10.3)') (d4(mej+l+jj),jj=1,ln) + call basout(io,lunit,buf(1:lnblnk(buf))) + l=l+10 + 3102 continue + 3103 continue + goto 100 + 32 continue + nv=i1 + call basout(io,lunit,' initial corral') + write(buf,'(20i6)') (i5(k),k=1,nv) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 33 continue + call basout(io,lunit, + $ ' error from fprf2. old solution already optimal') + goto 100 + 34 continue + call basout(io,lunit,' epsilon smaller than a') + goto 100 + 35 continue + j=i1 + write(buf,'('' start with variables 1 and,'',i4)') j + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 36 continue + nv=i1 + call basout(io,lunit,'x = ') + nn=nv/10 + if(10*nn.lt.nv) nn=nn+1 + l=0 + do 3601 i=1,nn + ln=min(10,nv-l) + write (buf,'(3x,10d10.3)') (d4(l+j),j=1,ln) + call basout(io,lunit,buf(1:lnblnk(buf))) + l=l+10 + 3601 continue + goto 100 + 37 continue + call basout(io,lunit,' fprf2 is apparently looping') + goto 100 + 38 continue + j0=i1 + s2=d1 + sp=d2 + write(buf,3801) s2,j0,sp + 3801 format(7h (s,s)=,d12.4,10h variable,i4, + &2h (,d12.4,12h) coming in.) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 39 continue + s2=d1 + u1=d2 + write(buf,3901) s2,u1 + 3901 format(7h (s,s)=,d12.4,5h u1=,d12.3,23h variable 1 coming in.) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 40 continue + write(buf,'('' duplicate variable '',i3)') j0 + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 41 continue + nv=i1 + mm1=i2 +c d3=rr,d4=r + write(buf,'(''cholesky '',d11.3)') d3(1) + call basout(io,lunit,buf(1:lnblnk(buf))) + if(nv.ge.2) then + do 4103 ll=2,nv + k1=ll-1 + nn=k1/10 + if(10*nn.lt.k1) nn=nn+1 + l=0 + if(nn.gt.1) then + do 4102 i=1,nn-1 + ln=min(10,k1-l) + write (buf,'(3x,10d10.3)') (d4((l+kk-1)*mm1+ll),kk=1,nn) + call basout(io,lunit,buf(1:lnblnk(buf))) + l=l+10 + 4102 continue + endif + write(buf,'(3x,10d10.3)') (d4((l+kk-1)*mm1+ll),kk=1,nn), + $ d3(ll) + call basout(io,lunit,buf(1:lnblnk(buf))) + 4103 continue + endif + goto 100 + 42 continue + k0=i1 + l=i2 + yk0=d1 + ps1=d2 + ps2=d3(1) + write(buf,4201) k0,l,yk0,ps1,ps2 + 4201 format(9h variable,i4,2h (,i4,3h) =,d11.3,11h going out., + & 17h feasible (s,s)=,d11.4,12h unfeasible=,d11.4) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 43 continue + goto 100 + 44 continue + nc=i1 + nv=i2 +c jc=i5 + s2=d1 + sp=d2 + u1=d3(1) + write(buf,4401) nc,nv + call basout(io,lunit,buf(1:lnblnk(buf))) + + write(buf,44010) + call basout(io,lunit,buf(1:lnblnk(buf))) + + write(buf,44011) s2,sp + call basout(io,lunit,buf(1:lnblnk(buf))) + + write(buf,44012) u1 + call basout(io,lunit,buf(1:lnblnk(buf))) + + 4401 format(14h finished with,i3,10h gradients,i3) +44010 format(11h variables.) +44011 format(7h (s,s)=,d11.4,6h test=,d11.4) +44012 format(32h cost of the extra constraint u=,d12.5) + + nn=nv/20 + if(10*nn.lt.nv) nn=nn+1 + l=0 + do 4402 i=1,nn + ln=min(20,nv-l) + write (buf,'(20i6)') (i5(l+k),k=1,ln) + call basout(io,lunit,buf(1:lnblnk(buf))) + l=l+20 + 4402 continue + goto 100 +c ================ +c MESSAGE DE NLIS2 +c ================ + 45 continue + write (buf,4501) + 4501 format (4x,6h nlis2,10x,17htmin force a tmax) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 46 continue + fpn=d1 + tmin=d3(1) + tmax=d4(1) + call basout(io,lunit,' ') + write (buf,4601) fpn,d2,tmin,tmax + 4601 format (4x,9h nlis2 ,4x,4hfpn=,d10.3,4h d2=,d9.2, + 1 7h tmin=,d9.2,6h tmax=,d9.2) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 47 continue + call basout(io,lunit,' ') + write(buf,4701) nap + 4701 format (4x,6h nlis2,3x,i5,22h simulations atteintes) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 48 continue + call basout(io,lunit,'Stop required by user') + goto 100 + 49 continue + indic=i1 + t=d1 + write(buf,4901) t,indic + 4901 format (4x,6h nlis2,36x,1hi,d10.3,7h indic=,i3) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 50 continue + t=d1 + ffn=d2 + fp=d3(1) + write(buf,5001) t,ffn,fp + 5001 format (4x,6h nlis2,36x,1hi,d10.3,2d11.3) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + + 51 continue + write(buf,5101) t,ffn,fp + 5101 format (4x,6h nlis2,d13.3,2d11.3,2h i) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 52 continue + logic=i1 + write(buf,5201) logic + 5201 format (4x,6h nlis2,3x,20hcontrainte implicite,i4,7h active) + call basout(io,lunit,buf(1:lnblnk(buf))) + goto 100 + 53 continue + logic=i1 + call basout(io,lunit,'nlis2 end (tmin reached)') + goto 100 + 54 continue + goto 100 + 55 continue + goto 100 + 56 continue + goto 100 + 57 continue + goto 100 + 58 continue + goto 100 + 59 continue + goto 100 + 60 continue + goto 100 +c + 100 return + end diff --git a/modules/optimization/src/fortran/n1fc1o.lo b/modules/optimization/src/fortran/n1fc1o.lo new file mode 100755 index 000000000..401c563c3 --- /dev/null +++ b/modules/optimization/src/fortran/n1fc1o.lo @@ -0,0 +1,12 @@ +# src/fortran/n1fc1o.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1fc1o.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1gc2.f b/modules/optimization/src/fortran/n1gc2.f new file mode 100755 index 000000000..f97822dd5 --- /dev/null +++ b/modules/optimization/src/fortran/n1gc2.f @@ -0,0 +1,108 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1987 - INRIA - Claude LEMARECHAL +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1gc2 (simul,prosca,n,x,f,g,dxmin,df1,epsrel,imp,io, + / mode,niter,nsim,rz,nrz,izs,rzs,dzs) + implicit double precision (a-h,o-z) +c!but +c minimisation sans contraintes par un algorithme de quasi-Newton +c a memoire limitee +c!commentaires +c le sous-programme n1gc2 (gradient conjugue a encombrement variable) +c est une interface entre le programme appelant et le sous-programme +c n1gc2a, minimiseur proprement dit. +c nrz est la dimension declaree pour le tableau de travail rz. +c rz est subdivise en 4 vecteurs de dimension n +c et un tableau de dimension memh. +c memh est la dimension allouee a la matrice de quasi newton h. +c pour l'usage de la liste d'appel : voir la documentation de n1qn1 +c! + double precision zero, un + parameter ( zero=0.0d+0 , un=1.0d+0 ) +c declaration des tableaux + double precision x(n), g(n), rz(nrz), dzs(*) + real rzs(*) + integer izs(*) +c declaration des scalaires + double precision f, epsrel, dxmin, df1 + integer n, nrz, imp, nsim, mode + integer id, ix, ig, iaux, ih, memh + character bufstr*(4096) +c + external simul, prosca +c + if (imp .gt. 0) then + + write(bufstr,1) n + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write(bufstr,11) nrz,niter,nsim,imp + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write(bufstr,12) epsrel,df1,dxmin + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + endif +1 format(19h entree dans n1gc2:,6x,22hdimension du probleme ,i3) +11 format(2x,4hnrz=,i4,4x,6hniter=,i3,4x,5hnsim=,i4,4x,4himp=,i3) +12 format(2x,7hepsrel=,d9.2,4x,4hdf1=,d9.2,4x,6hdxmin=,d9.2) + if ( n.le.0 .or. niter.le.0 .or. nsim.le.0 .or. + / dxmin.le.zero .or. df1.le.zero + / .or. epsrel.le.zero .or. epsrel.gt.un ) then + mode=2 + if (imp .gt. 0) then + write(bufstr,3) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + endif +c +c calculs des pointeurs destines a subdiviser le tableau rz + id=1 + ix=id +n + ig=ix +n + iaux=ig +n + ih=iaux + n +c +c calcul du nombre de places memoire affectees a h + memh=nrz - 4*n +c + if (memh .le. 0) then + mode=3 + goto 100 + else + continue + endif +c +c appel du sous-programme n1gc2a qui effectue la reelle optimisation + call n1gc2a(simul,prosca,n,x,f,g,dxmin,df1,epsrel,imp,io, + / niter,nsim,mode,memh,rz(id),rz(ix),rz(ig), + / rz(iaux),rz(ih),izs,rzs,dzs) +c +100 if (imp .gt. 0) then + if (mode .eq. 3) then + write(bufstr,2) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + else if (mode .eq. 6) then + write(bufstr,4) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + else + write(io,5)epsrel + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(io,51) niter,nsim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + endif + return +2 format(38h n1gc2 rz insuffisamment dimensionne) +3 format(25h n1gc2 appel incoherent) +4 format(22h n1gc2 fin sur dxmin) +5 format(16h sortie de n1gc2,7x,12hnorme de g =,d16.9) +51 format(9x, 6hniter=,i4,4x,5hnsim=,i5) + end diff --git a/modules/optimization/src/fortran/n1gc2.lo b/modules/optimization/src/fortran/n1gc2.lo new file mode 100755 index 000000000..5d63fd50b --- /dev/null +++ b/modules/optimization/src/fortran/n1gc2.lo @@ -0,0 +1,12 @@ +# src/fortran/n1gc2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1gc2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1gc2a.f b/modules/optimization/src/fortran/n1gc2a.f new file mode 100755 index 000000000..88d230757 --- /dev/null +++ b/modules/optimization/src/fortran/n1gc2a.f @@ -0,0 +1,383 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1gc2a(simul,prosca,n,x,f,g,dx,df1,eps,imp,io, + / niter,nsim,info,memh,d,xx,gg,tabaux,h, + / izs,rzs,dzs) + implicit double precision (a-h,o-z) +c +c parametres + double precision zero , un , deux , ro + parameter ( zero=0.0d+0, un=1.0d+0, deux=2.0d+0, ro=0.20d+0 ) +c declaration des tableaux + double precision x(n),g(n),d(n),xx(n),gg(n),tabaux(n),h(*), + / dzs(*) + real rzs(*) + integer izs(*) +c declaration des scalaires + double precision f, dx, eps, df1 + double precision dg1, dg, alpha, normg0, aux1, aux2, mu, eta, + / omega, normg, gcarre, ggcarr, nu, sigma, sscalg, uscalg, + / sscaek + integer n, memh, imp, io, nsim, niter, info + integer memuti, nrzuti, memsup, m, retour, iter, + / ntotap, nmisaj, i, iu, is, ieta, inu, j, kj, k, kp1 + logical gc, iterqn, intfor, redfor, redem, termi + character bufstr*(4096) +c + external simul, prosca +c +c ************************************************************* +c phase i:determination de la methode ( et de m le cas echeant) +c ************************************************************* +c + memuti=n*(n+1)/2 +c +c memsup est aussi la dimension minimale de la matrice h + memsup=2*n+2 +c + if (memh .ge. memuti) then + gc=.false. + nrzuti=memuti+4*n + if (imp .gt. 1) then + write(bufstr,1) nrzuti + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + else if (memh .lt. memsup) then + info=3 + return + else + gc=.true. +c m est le nombre de mises a jour admissible + m=memh / memsup +c memuti est ici le nombre de places memoire utilisees pour stocker h + memuti=m * memsup + nrzuti=memuti+4*n + if (imp .gt. 1) then + write(bufstr,2) m + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,3) nrzuti + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + endif +1 format(40h methode de quasi-newton. nrz utile=,i7) +2 format(38h methode du gradient conjugue avec,i3) +3 format(14h mises a jour.,11h nrz utile=,i7) +c +c *********************************************** +c phase ii:initialisations propres a l'optimiseur +c *********************************************** +c +c initialisation des compteurs + iter=0 + ntotap=1 +c +c ****************************************************************** +c phase iii:demarrage a partir de x(0) avec descente suivant -(grad) +c ****************************************************************** +c +3000 i=0 + nmisaj=0 +c +c calcul de la direction de descente + do 3100 j=1,n + d(j)=-g(j) +3100 continue +c + call prosca(n,g,d,dg1,izs,rzs,dzs) + normg0=sqrt(abs(dg1)) + if (iter .eq. 1) then + omega=eps * normg0 + endif +c +c ************************************************************ +c phase iv:debut de l'iteration x(i-1) donne x(i) le long de d +c ************************************************************ +c +4000 if (iter .eq. niter) then + info=4 + goto 99999 + endif + iter=iter + 1 + i=i+1 +c +c determination du type de pas + if (gc) then + iterqn=(i .le. m) .and. (2 .le. i) + endif +c +c ******************************* +c phase v:initialisation de alpha +c ******************************* +c + if (iter .eq. 2) then + alpha=deux * df1 /(-dg1) + else if (gc) then + if (i.eq.1) then + alpha=un / normg0 + else + if (iterqn) then + alpha=un + else + alpha=alpha * dg / dg1 + endif + endif + else + alpha=un + endif +c +c *************************** +c phase vi:recherche lineaire +c *************************** +c + dg=dg1 + intfor=( gc .and. (.not.iterqn)).or. ((.not.gc) .and.(i.eq.1)) + do 6000 j=1,n + xx(j)=x(j) + gg(j)=g(j) +6000 continue + call n1gc2b(n,simul,prosca,xx,f,dg,alpha,d,x,g,imp,io,retour, + / ntotap,nsim,intfor,dx,eps,izs,rzs,dzs) +c + if (imp .gt. 3) then + write(bufstr,6003) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if ((retour .eq. 4).or.((retour .eq. 1).and.(i .eq. 1))) then + info=6 + return + else if (retour .eq. 1) then + if (imp .gt. 1) then + write(bufstr,6002) iter,ntotap + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + goto 3000 + else +c calcul de (g,g) + if((i .gt. 1) .and. gc) ggcarr=gcarre + call prosca(n,g,g,gcarre,izs,rzs,dzs) + normg=sqrt(gcarre) + if (imp .gt. 2) then + write(bufstr,6001)iter,ntotap,f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if (retour .eq. 2) then + info=0 + goto 99999 + else if (retour .eq. 3)then + info=5 + goto 99999 + endif + endif +6001 format(4x,6h n1gc2,3x,i4,6h iters,3x,i4,7h simuls,3x,2hf=,d16.9) +6002 format(4x,6h n1gc2,3x,i4,6h iters,3x,i4,7h simuls, + / 33h necessite d'un redemarrage total) +6003 format() +c +c ****************************************************** +c phase vii:test d'arret par obtention de la convergence +c ****************************************************** +c + termi=normg .lt. omega + if (termi) then + info=1 + goto 99999 + else + continue + endif +c +c ******************************************* +c phase viii:test x(i) point de redemarrage? +c ******************************************* +c +c doit on forcer un redemarrage? + redfor=gc .and. ((i .eq. 1) .or. (i .eq. m+n)) + if (redfor) then + redem=.true. + else if (gc .and. .not. iterqn) then + call prosca(n,g,gg,aux1,izs,rzs,dzs) + redem=abs(aux1) .gt. abs(ro * ggcarr) + else + redem=.false. + endif +c +c ******************** +c phase ix:mise a jour +c ******************** +c +c calcul de s stocke dans d et de y stocke dans xx + do 9000 j=1,n + d(j)=alpha * d(j) + xx(j)=g(j)-gg(j) +9000 continue + if (redem) then +c cas ou x(i) est un point de redemarrage + i=1 + nmisaj=1 +c sauvegarde de s qui est actuellement dans d +c u=h*y=y +c nu=(y,hy)=(y,y) +c eta=(s,y) +c calcul des indices + inu=1 + ieta=inu + 1 + iu=ieta + is=iu + n +c + do 9100 j=1,n + h(iu +j)=xx(j) + h(is +j)=d(j) +9100 continue + call prosca(n,xx,xx,nu,izs,rzs,dzs) + h(inu)=nu + call prosca(n,d,xx,eta,izs,rzs,dzs) + h(ieta)=eta +c h1 est maintenant definie +c calcul de h1*g que l'on range dans xx + call fmulb1(n,h,g,xx,tabaux,nmisaj,prosca,izs,rzs,dzs) +c + else if (gc) then +c cas de gc sans redamarrage +c calcul de h*y range dans gg + call fmulb1(n,h,xx,gg,tabaux,nmisaj,prosca,izs,rzs,dzs) +c calculs de nu, eta, sscalg, uscalg + call prosca(n,xx,gg,nu,izs,rzs,dzs) + call prosca(n,d,xx,eta,izs,rzs,dzs) + call prosca(n,d,g,sscalg,izs,rzs,dzs) + call prosca(n,gg,g,uscalg,izs,rzs,dzs) +c calcul de sigma et de mu + sigma=(uscalg -(un + nu / eta)* sscalg) / eta + mu=sscalg /eta +c calcul de h*g que l'on range dans xx + call fmulb1(n,h,g,xx,tabaux,nmisaj,prosca,izs,rzs,dzs) +c calcul de la nouvelle direction de recherche: +c h*g - mu * u - sigma * s + do 9200 j=1,n + xx(j)= xx(j) - mu * gg(j) - sigma * d(j) +9200 continue +c +c cas d'une iteration de type quasi newton + if (iterqn) then + nmisaj=nmisaj + 1 +c sauvegarde des termes utiles pour stocker la matrice mise a jour + inu=inu + memsup + ieta=inu + 1 + iu=ieta + is=iu + n + do 9300 j=1,n + h(iu +j)=gg(j) + h(is +j)=d(j) +9300 continue + h(inu)=nu + h(ieta)=eta + endif +c cas de la methode quasi newton + else +c calcul de eta=(s,y) + call prosca(n,d,xx,eta,izs,rzs,dzs) + if (i .eq. 1) then +c etape initiale calcul de l'approximation initiale de l'inverse de la +c matrice hessienne +c calcul de nu=(y,h0*y)=(y,y) + call prosca(n,xx,xx,nu,izs,rzs,dzs) +c stockage de cette matrice h=(eta / nu) * i + kj=1 + aux1=eta / nu + do 9500 k=1,n + h(kj)=aux1 + kj=kj +1 + kp1=k+1 + if (n .ge. kp1) then + do 9400 j=kp1,n + h(kj)=zero + kj=kj +1 +9400 continue + endif + gg(k)=aux1 * xx(k) +9500 continue + nu=eta + else + call fmuls1(n,h,xx,gg) + call prosca(n,xx,gg,nu,izs,rzs,dzs) + endif +c calcul de la matrice mise a jour (utilisation de la formule bfgs ) +c nu, eta et h*y (stocke dans gg) sont connus + aux1=un + nu / eta + kj=1 + do 9800 k=1,n +c calcul du vecteur contenant la keme colonne de h + lk=k + km1=k-1 + if (k .ge. 2) then + do 9610 l=1,km1 + tabaux(l)=h(lk) + lk=lk + (n-l) +9610 continue + endif + do 9620 l=k,n + tabaux(l)=h(lk) + lk=lk+1 +9620 continue +c + call prosca(n,xx,tabaux,aux2,izs,rzs,dzs) + do 9630 l=1,n + tabaux(l)=zero +9630 continue + tabaux(k)=un + call prosca(n,tabaux,d,sscaek,izs,rzs,dzs) + kj=k-n + do 9700 j=1,k + kj=kj+n-j+1 + h(kj)=h(kj) - ( (aux2 - aux1*sscaek)*d(j) + sscaek*gg(j) )/eta +9700 continue +9800 continue + endif +c +c ***************************************************** +c phase x :calcul de la nouvelle direction de recherche +c ***************************************************** +c + if (gc) then +c xx contient -d + do 10000 j=1,n + d(j)=-xx(j) +10000 continue +c + else +c cas de la methode de quasi newton +c la nouvelle direction d egale -(h * g) + call fmuls1(n,h,g,d) + do 10100 j=1,n + d(j)=-d(j) +10100 continue + endif +c +c test:la direction de recherche est elle bien de descente + call prosca(n,d,g,dg1,izs,rzs,dzs) + if (dg1 .ge. zero) then + info=7 + if (imp .gt. 1) then + write(bufstr,10101) dg1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + goto 99999 + else + goto 4000 + endif +c +c retour au programme appelant +99999 niter=iter + nsim=ntotap + if (i .eq. 0) then + eps=normg0 + else + eps=normg + endif +10101 format(40h n1gc2a erreur dans la hessienne dg=,d9.2) + end diff --git a/modules/optimization/src/fortran/n1gc2a.lo b/modules/optimization/src/fortran/n1gc2a.lo new file mode 100755 index 000000000..fc75bd11e --- /dev/null +++ b/modules/optimization/src/fortran/n1gc2a.lo @@ -0,0 +1,12 @@ +# src/fortran/n1gc2a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1gc2a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1gc2b.f b/modules/optimization/src/fortran/n1gc2b.f new file mode 100755 index 000000000..bfff8cdbf --- /dev/null +++ b/modules/optimization/src/fortran/n1gc2b.f @@ -0,0 +1,185 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1gc2b(n,simul,prosca,xinit,f,dg,alpha,d, + / xfinal,gfinal,imp,io,retour,ntotap,nsim, + / intfor,dx,eps,izs,rzs,dzs) +c + implicit double precision (a-h,o-z) +c parametres + double precision zero , deux , trois + parameter ( zero=0.0d+0 , deux=2.0d+0, trois=3.0d+0 ) + double precision dixiem , petit + parameter ( dixiem=.10d+0 , petit=.00010d+0 ) + double precision unplus , unmoin , envir1 + parameter ( unplus=1.010d+0, unmoin=.990d+0, envir1=.90d+0 ) +c declarations des tableaux + double precision xinit(n),d(n),xfinal(n),gfinal(n),dzs(*) + real rzs(*) + integer izs(*) +c declarations des scalaires + double precision f, finit, dg, alpha, eps, dx, ap, dp, fp, + / aux1, aux2, pas, at, dal, bsup, delta + integer n, imp, io, retour, nsim, ntotap, nappel, indic, j + logical intfor, maxpas, rfinie, accept, encadr, depas + external prosca, simul + character bufstr*(4096) +c +c initialisations + depas=.false. + bsup=zero + finit=f + nappel=0 + ap=zero + fp=finit + dp=dg + if (imp .gt. 3) then + write(bufstr,1) alpha, dg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +c calcul de la longueur du pas + call prosca(n,d,d,pas,izs,rzs,dzs) + pas=sqrt(pas) +c test d'erreur dans la recherche lineaire +1000 continue + if (alpha * pas .le. dx) then + if (imp .gt. 3) then + write(bufstr,1001) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + retour=1 + return + else if (ntotap .eq. nsim) then + retour=3 + return + else + continue + endif +c calcul du nouveau point susceptible d'etre xfinal + do 2000 j=1,n + xfinal(j)=xinit(j) + alpha * d(j) +2000 continue +c calculs de f et g en ce point + indic=4 + call simul(indic,n,xfinal,f,gfinal,izs,rzs,dzs) + nappel=nappel + 1 + ntotap=ntotap + 1 + if (indic .lt. 0) then + depas=.true. + if (imp . gt. 3) then + write(bufstr,2001) alpha,indic + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + delta=alpha - ap + if (delta .le. dx) then + retour=4 + return + else + bsup=alpha + alpha=delta * dixiem + ap + goto 1000 + endif + endif +c calcul de la derivee suivant d au point xfinal + call prosca(n,d,gfinal,dal,izs,rzs,dzs) +c + if (imp .gt. 3) then + aux2=f - finit + write(bufstr,2002) alpha, aux2, dal + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if (indic .eq. 0) then + retour=2 + return + endif + maxpas=(f .gt. finit) .and. (dal .lt. zero) + if (maxpas) then + alpha=alpha / trois + ap=zero + fp=finit + dp=dg + rfinie=.false. +c + else +c test:le nouveau point est il acceptable + aux1=finit + petit * alpha * dg + aux2=abs(dal/dg) + accept=(f .le. aux1) .and. (aux2 .le. envir1) + if (accept) then +c doit on faire une interpolation + rfinie=(nappel .gt. 1) .or. (.not. intfor) .or. (aux2 .le. eps) + else + rfinie=.false. + endif +c + if (.not. rfinie) then +c la recherche lineaire n'est pas finie. interpolation + aux1=dp + dal- trois*(fp-f)/(ap-alpha) + aux2=aux1 * aux1 - dp * dal + if (aux2 .le. zero) then + aux2=zero + else + aux2=sqrt(aux2) + endif + if (dal-dp+ deux * aux2 .eq. zero) then + retour=4 + return + endif + at=alpha - (alpha-ap)*(dal+aux2-aux1)/(dal-dp+ deux * aux2) +c test:le minimum a t-il ete encadre + encadr=(dal/dp) .le. zero + if (encadr) then +c le minimum a ete encadre + if (abs(alpha - ap) .le. dx) then + retour=4 + return + endif + aux1=unplus * min(alpha,ap) + aux2=unmoin * max(alpha,ap) + if ((at .lt. aux1) .or. (at .gt. aux2)) at=(alpha + ap)/deux + else +c le minimum n'a pas ete encadre + aux1=unmoin * min(ap,alpha) + if ((dal .le. zero) .or. (at .le. zero) .or. (at .ge. aux1)) then + aux1=unplus * max(ap,alpha) + if ((dal .gt. zero) .or. (at .le. aux1)) then + if (dal .le. zero) then + at=deux * max(ap,alpha) + else + at=min(ap,alpha) / deux + endif + endif + endif + endif + if ( (depas) .and. (at .ge. bsup)) then + delta=bsup - alpha + if (delta .le. dx) then + retour=4 + return + else + at=alpha + delta * dixiem + endif + endif + ap=alpha + fp=f + dp=dal + alpha=at + endif + endif + if (rfinie) then + retour=0 + return + else + goto 1000 + endif +1 format(7h n1gc2b,6x,5h pas,d10.3,5h dg=,d9.2) +1001 format(21h n1gc2b fin sur dx) +2001 format(7h n1gc2b,20x,d10.3,8h indic=,i3) +2002 format(7h n1gc2b,20x,d10.3,2d11.3) + end diff --git a/modules/optimization/src/fortran/n1gc2b.lo b/modules/optimization/src/fortran/n1gc2b.lo new file mode 100755 index 000000000..4d389778b --- /dev/null +++ b/modules/optimization/src/fortran/n1gc2b.lo @@ -0,0 +1,12 @@ +# src/fortran/n1gc2b.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1gc2b.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1qn1.f b/modules/optimization/src/fortran/n1qn1.f new file mode 100755 index 000000000..e29513d9f --- /dev/null +++ b/modules/optimization/src/fortran/n1qn1.f @@ -0,0 +1,110 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1987 - INRIA - Claude LEMARECHAL +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1qn1 (simul,n,x,f,g,var,eps, + 1 mode,niter,nsim,imp,lp,zm,izs,rzs,dzs) +c +c!but +c minimisation d une fonction reguliere sans contraintes +c!origine +c c. lemarechal, inria, 1987 +c Copyright INRIA +c!methode +c direction de descente calculee par une methode de quasi-newton +c recherche lineaire de type wolfe +c!liste d appel +c simul : point d'entree au module de simulation (cf normes modulopt i) +c n1qn1 appelle toujours simul avec indic = 4 ; le module de +c simulation doit se presenter sous la forme subroutine simul +c (n,x, f, g, izs, rzs, dzs) et e^tre declare en external dans le +c programme appelant n1qn1. +c n (e) : nombre de variables dont depend f. +c x (e-s) : vecteur de dimension n ; en entree le point initial ; +c en sortie : le point final calcule par n1qn1. +c f (e-s) : scalaire ; en entree valeur de f en x (initial), en sortie +c valeur de f en x (final). +c g (e-s) : vecteur de dimension n : en entree valeur du gradient en x +c (initial), en sortie valeur du gradient en x (final). +c var (e) : vecteur strictement positif de dimension n. amplitude de la +c modif souhaitee a la premiere iteration sur x(i).une bonne +c valeur est 10% de la difference (en valeur absolue) avec la +c coordonee x(i) optimale +c eps (e-s) : en entree scalaire definit la precision du test d'arret. +c le programme considere que la convergence est obtenue lorque il lui +c est impossible de diminuer f en attribuant a au moins une coordonnee +c x(i) une variation superieure a eps*var(i). +c en sortie, eps contient le carre de la norme du gradient en x (final). +c mode (e) : definit l approximation initiale du hessien +c =1 n1qn1 l initialise lui-meme +c =2 le hessien est fourni dans zm sous forme compressee (zm +c contient les colonnes de la partie inferieure du hessien) +c niter (e-s) : en entree nombre maximal d'iterations : en sortie nombre +c d'iterations reellement effectuees. +c nsim (e-s) : en entree nombre maximal d'appels a simul (c'est a dire +c avec indic = 4). en sortie le nombre de tels appels reellement faits. +c imp (e) : contro^le les messages d'impression : +c 0 rien n'est imprime +c = 1 impressions initiales et finales +c = 2 une impression par iteration (nombre d'iterations, +c nombre d'appels a simul, valeur courante de f). +c >=3 informations supplementaires sur les recherches +c lineaires ; +c tres utile pour detecter les erreurs dans le gradient. +c lp (e) : le numero du canal de sortie, i.e. les impressions +c commandees par imp sont faites par write (lp, format). +c zm : memoire de travail pour n1qn1 de dimension n*(n+13)/2. +c izs,rzs,dzs memoires reservees au simulateur (cf doc) +c +c! + implicit double precision (a-h,o-z) + dimension x(n),g(n),var(n),zm(*),izs(*),dzs(*) + real rzs(*) + character bufstr*(4096) + external simul + if (imp.gt.0) then + call basout(io, lp, '') + call basout(io, lp, + $ '***** enters -qn code- (without bound cstr)') + + write(bufstr,750)n,eps,imp + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + +750 format('dimension=',i10,', epsq=',e24.16, + $ ', verbosity level: imp=',i10) + + + + write(bufstr,751)niter + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) +751 format('max number of iterations allowed: iter=',i10) + + + write(bufstr,752) nsim + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) +752 format('max number of calls to costf allowed: nap=',i10) + + call basout(io ,lp , + $ '------------------------------------------------') + endif + nd=1+(n*(n+1))/2 + nw=nd+n + nxa=nw+n + nga=nxa+n + nxb=nga+n + ngb=nxb+n + call n1qn1a (simul,n,x,f,g,var,eps,mode, + 1 niter,nsim,imp,lp,zm,zm(nd),zm(nw),zm(nxa),zm(nga), + 2 zm(nxb),zm(ngb),izs,rzs,dzs) + if (imp.gt.0) then + write(bufstr,753) sqrt(eps) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) +753 format('***** leaves -qn code-, gradient norm=',e24.16) + + endif + end diff --git a/modules/optimization/src/fortran/n1qn1.lo b/modules/optimization/src/fortran/n1qn1.lo new file mode 100755 index 000000000..ea8b1ef61 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn1.lo @@ -0,0 +1,12 @@ +# src/fortran/n1qn1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1qn1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1qn1a.f b/modules/optimization/src/fortran/n1qn1a.f new file mode 100755 index 000000000..9901af115 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn1a.f @@ -0,0 +1,326 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1qn1a (simul,n,x,f,g,scale,acc,mode, + 1 niter,nsim,iprint,lp,h,d,w,xa,ga,xb,gb,izs,rzs,dzs) +c + +* A (very) few modifs by Bruno (14 March 2005): I have translated some output +* information in english (but they don't use format instruction +* which is put in the second arg of write). Also for the linear +* search output information I divide by the direction vector norm +* to get the "normalized" directionnal derivative. Note that this is +* just for output (the computing code is normally not modified). + + implicit double precision (a-h,o-z) + dimension x(n),g(n),scale(n),h(*),d(n),w(n), + 1 xa(n),ga(n),xb(n),gb(n),izs(*),dzs(*) + character bufstr*(4096) + real rzs(*) + external simul + double precision dnrm2 ! (blas routine) added by Bruno to get + ! a better information concerning directionnal derivative + integer vfinite ! added by Serge to avoid Inf and Nan's + 1000 format (46h n1qn1 ne peut demarrer (contrainte implicite)) + 1001 format (40h n1qn1 termine par voeu de l'utilisateur) + 1010 format (45h n1qn1 remplace le hessien initial (qui n'est, + 1 20h pas defini positif)/27h par une diagonale positive) + 1023 format (40h n1qn1 bute sur une contrainte implicite) +c +c calcul initial de fonction-gradient +c + indic=4 + call simul (indic,n,x,f,g,izs,rzs,dzs) +c next line added by Serge to avoid Inf and Nan's (04/2007) + if (vfinite(1,f).ne.1.and.vfinite(n,g).ne.1) indic=-1 + if (indic.gt.0) go to 13 + if (iprint.eq.0) go to 12 + if (indic.lt.0) then + write (bufstr,1000) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + if (indic.eq.0) then + write (bufstr,1001) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + 12 acc=0.0d+0 + niter=1 + nsim=1 + return + 13 nfun=1 + iecri=0 + itr=0 + np=n+1 +c initialisation du hessien, en fonction de var + if (mode.ge.2) go to 60 + 20 c=0.0d+0 + do 30 i=1,n + 30 c=max(c,abs(g(i)*scale(i))) + if (c.le.0.0d+0) c=1.0d+0 + k=(n*np)/2 + do 40 i=1,k + 40 h(i)=0.0d+0 + k=1 + do 50 i=1,n + h(k)=0.010d+0*c/(scale(i)*scale(i)) + 50 k=k+np-i + go to 100 +c factorisation du hessien + 60 if (mode.ge.3) go to 80 + k=n + if(n.gt.1) go to 300 + if(h(1).gt.0.0d+0) go to 305 + h(1)=0.0d+0 + k=0 + go to 305 + 300 continue + np=n+1 + ii=1 + do 304 i=2,n + hh=h(ii) + ni=ii+np-i + if(hh.gt.0.0d+0) go to 301 + h(ii)=0.0d+0 + k=k-1 + ii=ni+1 + go to 304 + 301 continue + ip=ii+1 + ii=ni+1 + jk=ii + do 303 ij=ip,ni + v=h(ij)/hh + do 302 ik=ij,ni + h(jk)=h(jk)-h(ik)*v + 302 jk=jk+1 + 303 h(ij)=v + 304 continue + if(h(ii).gt.0.0d+0) go to 305 + h(ii)=0.0d+0 + k=k-1 + 305 continue +c + if (k.ge.n) go to 100 + 70 if (iprint.ne.0) then + write(bufstr,1010) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + go to 20 +c verification que la diagonale est positive + 80 k=1 + do 90 i=1,n + if (h(k).le.0.0d+0) go to 70 + 90 k=k+np-i +c quelques initialisations + 100 dff=0.0d+0 + 110 fa=f + isfv=1 + do 120 i=1,n + xa(i)=x(i) + 120 ga(i)=g(i) +c iteration + 130 itr=itr+1 + ial=0 + if (itr.gt.niter) go to 250 + iecri=iecri+1 + if (iecri.ne.-iprint) go to 140 + iecri=0 + indic=1 + call simul(indic,n,x,f,g,izs,rzs,dzs) +c error in user function + if(indic.eq.0) goto 250 +c calcul de la direction de recherche + 140 do 150 i=1,n + 150 d(i)=-ga(i) + w(1)=d(1) + if(n.gt.1)go to 400 + d(1)=d(1)/h(1) + go to 412 + 400 continue + do 402 i=2,n + ij=i + i1=i-1 + v=d(i) + do 401 j=1,i1 + v=v-h(ij)*d(j) + 401 ij=ij+n-j + w(i)=v + 402 d(i)=v + d(n)=d(n)/h(ij) + np=n+1 + do 411 nip=2,n + i=np-nip + ii=ij-nip + v=d(i)/h(ii) + ip=i+1 + ij=ii + do 410 j=ip,n + ii=ii+1 + 410 v=v-h(ii)*d(j) + 411 d(i)=v + 412 continue +c calcul du pas minimum +c et de la derivee directionnelle initiale + c=0.0d+0 + dga=0.0d+0 + do 160 i=1,n + c=max(c,abs(d(i)/scale(i))) + 160 dga=dga+ga(i)*d(i) +c test si la direction est de descente + if (dga.ge.0.0d+0) go to 240 +c initialisation du pas + stmin=0.0d+0 + stepbd=0.0d+0 + steplb=acc/c + fmin=fa + gmin=dga + step=1.0d+0 + if (dff.le.0.0d+0) step=min(step,1.0d+0/c) + if (dff.gt.0.0d+0) step=min(step,(dff+dff)/(-dga)) + + if (iprint.ge.2) then + write (bufstr,'(A,I4,A,I4,A,G11.4)') ' iter num ',itr, + $ ', nb calls=',nfun,', f=',fa + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + + if (iprint.ge.3) then + write (bufstr,'(A,G11.4)') + $ ' linear search: initial derivative=',dga/dnrm2(n,d,1) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + endif +c boucle de reherche lineaire + 170 c=stmin+step + if (nfun.ge.nsim) go to 250 + nfun=nfun+1 +c calcul de fonction-gradient + do 180 i=1,n + 180 xb(i)=xa(i)+c*d(i) + indic=4 + call simul (indic,n,xb,fb,gb,izs,rzs,dzs) +c next line added by Serge to avoid Inf and Nan's (04/2007) + if (vfinite(1,fb).ne.1.and.vfinite(n,gb).ne.1) indic=-1 +c test sur indic + if (indic.gt.0) goto 185 + if (indic.lt.0) goto 183 + if (iprint.gt.0) then + write (bufstr,1001) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + do 182 i=1,n + x(i)=xb(i) + 182 g(i)=gb(i) + go to 250 + 183 stepbd=step + ial=1 + step=step/10.0d+0 + if (iprint.ge.3) then + write (bufstr,'(A,G11.4,A,I2)') + $ ' step length=',c,', indic=',indic + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + if (stepbd.gt.steplb) goto 170 + if (iprint.ne.0.and.isfv.lt.2) then + write (bufstr,1023) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + goto 240 +c stockage si c'est la plus petite valeur + 185 isfv=min(2,isfv) + if (fb.gt.f) go to 220 + if (fb.lt.f) go to 200 + gl1=0.0d+0 + gl2=0.0d+0 + do 190 i=1,n + gl1=gl1+(scale(i)*g(i))**2 + 190 gl2=gl2+(scale(i)*gb(i))**2 + if (gl2.ge.gl1) go to 220 + 200 isfv=3 + f=fb + do 210 i=1,n + x(i)=xb(i) + 210 g(i)=gb(i) +c calcul de la derivee directionnelle + 220 dgb=0.0d+0 + do 230 i=1,n + 230 dgb=dgb+gb(i)*d(i) + if (iprint.lt.3) goto 231 + s=fb-fa +* a small change (Bruno): to give a better indication about +* the directionnal derivative I scale it by || d || + write (bufstr,'(A,G11.4,A,G11.4,A,G11.4)') + $ ' step length=',c, + $ ', df=',s,', derivative=',dgb/dnrm2(n,d,1) + + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) +c test si la fonction a descendu + 231 if (fb-fa.le.0.10d+0*c*dga) go to 280 + ial=0 +c iteration terminee si le pas est minimum + if (step.gt.steplb) go to 270 + 240 if (isfv.ge.2) go to 110 +c ici, tout est termine + 250 if (iprint.gt.0) then + write (bufstr,'(A,I4,A,I4,A,G11.4)') ' iter num ',itr, + $ ', nb calls=',nfun,', f=',f + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + acc=0.0d+0 + do 260 i=1,n + 260 acc=acc+g(i)*g(i) + niter=itr + nsim=nfun + return +c interpolation cubique + 270 stepbd=step + c=gmin+dgb-3.0d+0*(fb-fmin)/step + if(c.eq.0.0d+0) goto 250 + cc=abs(c)-gmin*(dgb/abs(c)) + cc=sqrt(abs(c))*sqrt(max(0.0d+0,cc)) + c=(c-gmin+cc)/(dgb-gmin+cc+cc) + step=step*max(0.10d+0,c) + go to 170 +c ceci est un pas de descente + 280 if (ial.eq.0) goto 285 + if (stepbd.gt.steplb) go to 285 + if (iprint.ne.0.and.isfv.lt.2) then + write (bufstr,1023) + call basout(io ,lp ,bufstr(1:lnblnk(bufstr))) + endif + go to 240 + 285 stepbd=stepbd-step + stmin=c + fmin=fb + gmin=dgb +c extrapolation + step=9.0d+0*stmin + if (stepbd.gt.0.0d+0) step=0.50d+0*stepbd + c=dga+3.0d+0*dgb-4.0d+0*(fb-fa)/stmin + if (c.gt.0.0d+0) step=min(step,stmin*max(1.0d+0,-dgb/c)) + if (dgb.lt.0.70d+0*dga) go to 170 +c recherche lineaire terminee, test de convergence + isfv=4-isfv + if (stmin+step.le.steplb) go to 240 +c formule de bfgs + ir=-n + do 290 i=1,n + xa(i)=xb(i) + xb(i)=ga(i) + d(i)=gb(i)-ga(i) + 290 ga(i)=gb(i) + call majour(h,xb,w,n,1.0d+0/dga,ir,1,0.0d+0) + ir=-ir + call majour(h,d,d,n,1.0d+0/(stmin*(dgb-dga)),ir,1,0.0d+0) +c test du rang de la nouvelle matrice + if (ir.lt.n) go to 250 +c nouvelle iteration + dff=fa-fb + fa=fb + go to 130 + end diff --git a/modules/optimization/src/fortran/n1qn1a.lo b/modules/optimization/src/fortran/n1qn1a.lo new file mode 100755 index 000000000..ce6ef2a10 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn1a.lo @@ -0,0 +1,12 @@ +# src/fortran/n1qn1a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1qn1a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1qn2.f b/modules/optimization/src/fortran/n1qn2.f new file mode 100755 index 000000000..c14077605 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn2.f @@ -0,0 +1,322 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1988 - INRIA - Jean-Charles GILBERT +c Copyright (C) 1988 - INRIA - Claude LEMARECHAL +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1qn2 (simul,prosca,n,x,f,g,dxmin,df1,epsg,impres,io, + / mode,niter,nsim,dz,ndz,izs,rzs,dzs) +c!But +c Minimisation sans contrainte par un algorithme +c de quasi-Newton a memoire limitee. +c!Origine +c Version 1.0 de n1qn2 (Modulopt, INRIA), septembre 1988. +c!Commentaires +c Ce code est en principe destine aux problemes de grande taille, +c n grand, mais convient egalement pour n quelconque. La methode +c utilisee est du type quasi-Newton (BFGS) a encombrement variable, +c ce qui permet d'utiliser au maximum la memoire declaree dispo- +c nible. On estine que plus la memoire utilisee est importante, plus +c rapide sera la decroissance du critere f. +c!Sous-routines appelees +c n1qn2: routine-chapeau qui structure la memoire declaree dispo- +c nible et appelle n1qn2a, +c n1qn2a: optimiseur proprement dit, +c strang: routine de calcul de la direction de descente, +c nlis0: routine de recherche lineaire. +c +c De son cote, l'utilisateur doit fournir: +c 1) une routine qui appelle le module d'optimisation n1qn2, +c 2) une routine de simulation, appelee simul par n1qn2, qui +c calcule la valeur de f et de son gradient en un point donne, +c 3) une routine, appelee prosca par n1qn2, qui realise le produit +c scalaire de deux vecteurs, ce produit scalaire doit etre +c celui utilise pour calculer le gradient de f dans simul. +c!Liste d'appel +c subroutine n1qn2 (simul,prosca,n,x,f,g,dxmin,df1,epsg,impres,io, +c / mode,niter,nsim,dz,ndz,izs,rzs,dzs) +c +c Dans la description des arguments qui suit, (e) signifie que +c l'argument doit etre initialise avant l'appel de n1qn2, (s) +c signifie que l'argument est une variable n'ayant de signification +c qu'en sortie et (es) = (e)+(s). Les arguments du type (s) et (es) +c sont en general modifies par n1qn2 et ne peuvent donc pas etre +c des constantes. +c +c simul: Nom d'appel de la sous-routine de simulation qui +c qui calcule la valeur de f et de son gradient g +c a l'itere courant. Ce module doit se presenter comme +c suit: +c subroutine simul (indic,n,x,f,g,izs,rzs,dzs). +c Le nom de la sous-routine doit etre declare external +c dans le module appelant n1qn2. Les arguments n, x, f, +c g, izs, rzs et dzs ont la meme signification que ci- +c dessous. N1qn2 appelle simul soit avec indic=1, dans +c ce cas le simulateur fera ce qu'il veut mais ne chan- +c gera pas la valeur des arguments, ou avec indic=4, dans +c cas le simulateur calculera a la fois f et g. +c prosca: Nom d'appel de la sous-routine effectuant le produit +c scalaire de deux vecteurs u et v. Ce module doit se +c presente sous la forme: +c subroutine prosca (n,u,v,ps,izs,rzs,dzs). +c Le nom de la sous-routine doit etre declare external +c dans le module appelant n1qn2. Les argument n, izs, +c rzs et dzs ont la meme signification que ci-dessous. +c Les arguments u, v et ps sont des vecteurs de dimension +c n du type double precision. Ps donne le produit +c scalaire de u et v. +c n(e): Scalaire du type integer. Donne la dimension n de la +c variable x. +c x(es): Vecteur de dimension n du type double precision. En +c entree il faut fournir la valeur du point initial, en +c sortie, c'est le point final calcule par n1qn2. +c f(es): Scalaire du type double precision. En entree, c'est la +c valeur de f en x (initial), valeur que l'on obtiendra +c en appelant le simulateur simul avant d'appeler n1qn2. +c En sortie, c'est la valeur de f en x (final). +c g(es): Vecteur de dimension n du type double precision. +c En entree, il faut fournir la valeur du gradient de f +c en x (initial), valeur que l'on obtiendra en appelant +c le simulateur simul avant d'appeler n1qn2. En sortie en +c mode 1, c'est la valeur du gradient de f en x (final). +c dxmin(e): Scalaire du type double precision, strictement positif. +c Cet argument definit la resolution sur x en norme +c l-infini: deux points dont la distance en norme l- +c infini est superieure a dxmin seront consideres comme +c non distinguables par la routine de recherche lineaire. +c df1(e): Scalaire du type double precision, strictement positif. +c Cet argument donne une estimation de la diminution +c escomptee pour f lors de la premiere iteration. +c epsg(es): Scalaire du type double precision, strictement positif +c et strictement inferieur a 1. Sa valeur en entree, +c determine le test d'arret qui porte sur la norme +c (prosca) du gradient. Le minimiseur considere que la +c convergence est atteinte en x(k) et s'arrete en mode 1 +c si E(k) := |g(k)|/|g(1)| < epsg, ou g(1) et g(k) sont +c les gradients au point d'entree et a l'iteration k, +c respectivement. En sortie, epsg = E(k). +c impres(e): Scalaire du type integer qui controle les sorties. +c <0: Rien n'est imprime et n1qn2 appelle le simulateur +c avec indic=1 toutes les (-impres) iterations. +c =0: Rien n'est imprime. +c >=1: Impressions initiales et finales, messages +c d'erreurs. +c >=3: Une ligne d'impression par iteration donnant +c l'ordre k de l'iteration courante menant de x(k) +c a x(k+1), le nombre d'appels au simulateur avant +c cette iteration, la valeur du critere f et sa +c derivee directionnelle suivant d(k). +c >=4: Impression de nlis0. +c >=5: Impressions supplentaires en fin d'iteration k: +c le test d'arret E(k+1), prosca(y(k),s(k)) qui +c doit etre positif, le facteur de Oren-Spedicato +c et l'angle de la direction de descente d(k) avec +c -g(k). +c io(e): Scalaire du type integer qui sera pris comme numero +c de canal de sortie pour les impressions controlees +c par impres. +c mode(s): Scalaire du type integer donnant le mode de sortie de +c n1qn2. +c <0: Impossibilite de poursuivre la recherche lineaire +c car le simulateur a repondu avec indic<0. Mode +c renvoie cette valeur de indic. +c =0: Arret demande par le simulateur qui a repondu avec +c indic=0. +c =1: Fin normale avec test sur le gradient satisfait. +c =2: Arguments d'entree mal initialises. Il peut s'agir +c de n<=0, niter<=0, nsim<=0, dxmin<=0, epsg<=0, +c epsg>1 ou de nrz<5n+1 (pas assez de memoire +c allouee). +c =3: La recherche lineaire a ete bloquee sur tmax=10^20 +c (mode tres peu probable). +c =4: Nombre maximal d'iterations atteint. +c =5: Nombre maximal de simulations atteint. +c =6: Arret sur dxmin lors de la recherche lineaire. Ce +c mode de sortie peut avoir des origines tres +c diverses. Si le nombre d'essais de pas lors de la +c derniere recherche lineaire est faible, cela peut +c signifier que dxmin a ete pris trop grand. Il peut +c aussi s'agir d'erreurs ou d'imprecision dans le +c calcul du gradient. Dans ce cas, la direction de +c recherche d(k) peut ne plus etre une direction de +c descente de f en x(k), etant donne que n1qn2 +c s'autorise des directions d(k) pouvant faire avec +c -g(k) un angle proche de 90 degres. On veillera +c donc a calculer le gradient avec precision. +c =7: Soit (g,d) soit (y,s) ne sont pas positifs (mode +c de sortie tres improbable). +c niter(es): Scalaire du type integer, strictement positif. En +c entree, c'est le nombre maximal d'iterations admis. +c En sortie, c'est le nombre d'iterations effectuees. +c nsim(es): Scalaire du type integer, strictement positif. En +c entree, c'est le nombre maximal de simulations admis. +c En sortie, c'est le nombre de simulations effectuees. +c rz(s): Vecteur de dimension nrz du type double precision. +c C'est l'adresse d'une zone de travail pour n1qn2. +c nrz(e): Scalaire du type integer, strictement positif, donnant +c la dimension de la zone de travail rz. En plus des +c vecteurs x et g donnes en arguments, n1qn2 a besoin +c d'une zone de travail composee d'au moins trois +c vecteurs de dimension n et chaque mise a jour demandee +c necessite 1 scalaire et 2 vecteurs de dimension n +c supplementaires. Donc si m est le nombre de mises a +c jour desire pour la construction de la metrique +c locale, il faudra prendre +c nrz >= 3*n + m*(2*n+1). +c En fait, le nombre m est determine par n1qn2 qui prend: +c m = partie entiere par defaut de ((nrz-3*n)/(2*n+1)) +c Ce nombre doit etre >= 1. Il faut donc nrz >= 5*n +1, +c sinon n1qn2 s'arrete en mode 2. +c izs, rzs, dzs: Adresses de zones-memoire respectivement du type +c integer, real et double precision. Elles sont reservees +c a l'utilisateur. N1qn2 ne les utilise pas et les +c transmet a simul et prosca. +c! +c----------------------------------------------------------------------- +c +c arguments +c + integer n,impres,io,mode,niter,nsim,ndz,izs(*) + real rzs(*) + double precision x(*),f,g(*),dxmin,df1,epsg,dz(*) + double precision dzs(*) + external simul,prosca +c +c variables locales +c + integer m,ndzu,l1memo,id,igg,iaux,ialpha,iybar,isbar + double precision r1,r2 + double precision ps + character bufstr*(4096) +c +c---- impressions initiales et controle des arguments +c + if (impres.ge.1) then + write (bufstr,900) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9001) n + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9002) dxmin + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9003) df1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9004) epsg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9005) niter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9006) nsim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9006) impres + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +900 format (' n1qn2: point d''entree') +9001 format (5x,'dimension du probleme (n) :',i6) +9002 format (5x,'precision absolue en x (dxmin) :',d9.2) +9003 format (5x,'decroissance attendue pour f (df1) :',d9.2) +9004 format (5x,'precision relative en g (epsg) :',d9.2) +9005 format (5x,'nombre maximal d''iterations (niter) :',i6) +9006 format (5x,'nombre maximal d''appels a simul (nsim) :',i6) +9007 format (5x,'niveau d''impression (impres) :',i4) + if (n.le.0.or.niter.le.0.or.nsim.le.0.or.dxmin.le.0.0d+0 + / .or.epsg.le.0.0d+0.or.epsg.gt.1.0d+0) then + mode=2 + if (impres.ge.1) then + write (bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +901 format (' >>> n1qn2 : appel incoherent') + goto 904 + endif + if (ndz.lt.5*n+1) then + mode=2 + if (impres.ge.1) then + write (bufstr,902) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +902 format (' >>> n1qn2: memoire allouee insuffisante') + goto 904 + endif +c +c---- calcul de m et des pointeurs subdivisant la zone de travail dz +c + ndzu=ndz-3*n + l1memo=2*n+1 + m=ndzu/l1memo + ndzu=m*l1memo+3*n + if (impres.ge.1) then + write (bufstr,903) ndz + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9031) ndzu + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9032) m + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +903 format (5x,'memoire allouee (ndz) :',i7) +9031 format (5x,'memoire utilisee :',i7) +9032 format (5x,'nombre de mises a jour :',i6) + id=1 + igg=id+n + iaux=igg+n + ialpha=iaux+n + iybar=ialpha+m + isbar=iybar+n*m +c +c---- appel du code d'optimisation +c + call n1qn2a (simul,prosca,n,x,f,g,dxmin,df1,epsg, + / impres,io,mode,niter,nsim,m, + / dz(id),dz(igg),dz(iaux), + / dz(ialpha),dz(iybar),dz(isbar),izs,rzs,dzs) +c +c---- impressions finales +c +904 continue + if (impres.ge.1) then + write (bufstr,905) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9051) mode + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9052) niter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9053) nsim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9054) epsg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +905 format (1x,79('-')) +9051 format (1x,'n1qn2 : sortie en mode ',i2) +9052 format (5x,'nombre d''iterations : ',i4) +9053 format (5x,'nombre d''appels a simul : ',i6) +9054 format (5x,'precision relative atteinte sur g: ',d9.2) + call prosca (n,x,x,ps,izs,rzs,dzs) + r1=sqrt(ps) + call prosca (n,g,g,ps,izs,rzs,dzs) + r2=sqrt(ps) + if (impres.ge.1) then + write (bufstr,906) r1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9061) f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9062) r2 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + endif +906 format (5x,'norme de x = ',d15.8) +9061 format (5x,'f = ',d15.8) +9062 format (5x,'norme de g = ',d15.8) +c + return + end diff --git a/modules/optimization/src/fortran/n1qn2.lo b/modules/optimization/src/fortran/n1qn2.lo new file mode 100755 index 000000000..16afb11a3 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn2.lo @@ -0,0 +1,12 @@ +# src/fortran/n1qn2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1qn2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1qn2a.f b/modules/optimization/src/fortran/n1qn2a.f new file mode 100755 index 000000000..4d645b446 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn2a.f @@ -0,0 +1,326 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1qn2a (simul,prosca,n,x,f,g,dxmin,df1,epsg, + / impres,io,mode,niter,nsim,m, + / d,gg,aux,alpha,ybar,sbar,izs,rzs,dzs) +c +c---- +c +c code d'optimisation proprement dit +c +c---- +c +c arguments +c + integer n,impres,io,mode,niter,nsim,m,izs(*) + real rzs(*) + double precision x(n),f,g(n),dxmin,df1,epsg,d(n),gg(n),aux(n), + / alpha(m),ybar(n,m),sbar(n,m) + double precision dzs(*) + external simul,prosca +c +c variables locales +c + integer i,iter,moderl,isim,jmin,jmax,indic + real r + double precision d1,t,tmin,tmax,gnorm,eps1,precon,ff + double precision ps,ps2,hp0 + character bufstr*(4096) +c +c---- parametres +c + double precision rm1,rm2 + parameter (rm1=0.90d+0,rm2=0.10d-3) + double precision pi + parameter (pi=3.14159270d+0) +c +c---- initialisation +c + iter=0 + isim=1 + call prosca (n,g,g,ps,izs,rzs,dzs) + gnorm=sqrt(ps) + if (impres.ge.1) then + write (bufstr,900) f,gnorm + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +900 format (5x,'f = ',d15.8, + / /,5x,'norme de g = ',d15.8) +c +c ---- direction de descente initiale +c (avec mise a l'echelle) +c + precon=2.0d+0*df1/gnorm**2 + do 10 i=1,n + d(i)=-g(i)*precon +10 continue + if (impres.ge.5) then + write(bufstr,899) precon + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +899 format (' n1qn2a: direction de descente -g: precon = ',d10.3) + if (impres.eq.3) then + write(bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,9010) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if (impres.eq.4) then + write(bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +c +c ---- initialisation pour nlis0 +c + tmax=1.0d+20 + call prosca (n,d,g,hp0,izs,rzs,dzs) +c +c ---- initialisation pour strang +c + jmin=1 + jmax=0 +c +c---- debut de l'iteration. on cherche x(k+1) de la forme x(k) + t*d, +c avec t > 0. on connait d. +c +c Si impres<0 et l'itération est un multiple de -impres, +c alors on appelle la fonction fournie, avec indic=1. +c +100 iter=iter+1 + if (impres.lt.0) then + if(mod(iter,-impres).eq.0) then + indic=1 + call simul (indic,n,x,f,g,izs,rzs,dzs) +c error in user function + if(indic.eq.0) goto 1000 + endif + endif + if (impres.ge.5) then + write(bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +901 format (1x,79('-')) + if (impres.ge.4) then + write(bufstr,9010) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +9010 format (1x,' ') + if (impres.ge.3) then + write (bufstr,902) iter,isim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,9020) f,hp0 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + endif +902 format (' n1qn2: iter ',i3,', simul ',i3) +9020 format (', f=',d15.8,', h''(0)=',d12.5) + do 101 i=1,n + gg(i)=g(i) +101 continue + ff=f +c +c ---- recherche lineaire et nouveau point x(k+1) +c + if (impres.ge.5) then + write (bufstr,903) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +903 format (/,' n1qn2: recherche lineaire') +c +c ---- calcul de tmin +c + tmin=0.0d+0 + do 200 i=1,n + tmin=max(tmin,abs(d(i))) +200 continue + tmin=dxmin/tmin + t=1.0d+0 + d1=hp0 +c + call nlis0 (n,simul,prosca,x,f,d1,t,tmin,tmax,d,g,rm1,rm2, + / impres,io,moderl,isim,nsim,aux,izs,rzs,dzs) +c +c ---- nlis0 renvoie les nouvelles valeurs de x, f et g +c + if (moderl.ne.0) then + if (moderl.lt.0) then +c +c ---- calcul impossible +c t, g: ou les calculs sont impossible +c x, f: ceux du t_gauche (donc f <= ff) +c + mode=moderl + elseif (moderl.eq.1) then +c +c ---- descente bloquee sur tmax +c [sortie rare (!!) d'apres le code de nlis0] +c + mode=3 + if (impres.ge.1) then + write(bufstr,904) iter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +904 format (/,' >>> n1qn2 (iteration ',i3, + / '): recherche lineaire bloquee sur tmax: ', + / 'reduire l''echelle') + elseif (moderl.eq.4) then +c +c ---- nsim atteint +c x, f: ceux du t_gauche (donc f <= ff) +c + mode=5 + elseif (moderl.eq.5) then +c +c ---- arret demande par l'utilisateur (indic = 0) +c x, f: ceux en sortie du simulateur +c + mode=0 + elseif (moderl.eq.6) then +c +c ---- arret sur dxmin ou appel incoherent +c x, f: ceux du t_gauche (donc f <= ff) +c + mode=6 + endif + goto 1000 + endif +c +c ---- tests d'arret +c + call prosca(n,g,g,ps,izs,rzs,dzs) + eps1=sqrt(ps)/gnorm +c + if (impres.ge.5) then + write (bufstr,905) eps1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +905 format (/,' n1qn2: test d''arret sur g: ',d12.5) + if (eps1.lt.epsg) then + mode=1 + goto 1000 + endif + if (iter.eq.niter) then + mode=4 + if (impres.ge.1) then + write (bufstr,906) iter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +906 format (/,' >>> n1qn2 (iteration ',i3, + / '): nombre maximal d''iterations atteint') + goto 1000 + endif + if (isim.ge.nsim) then + mode=5 + if (impres.ge.1) then + write (bufstr,907) iter,isim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +907 format (/,' >>> n1qn2 (iteration ',i3,'): ',i6, + / ' appels a simul (nombre maximal atteint)') + goto 1000 + endif +c +c ---- mise a jour de la matrice +c + jmax=jmax+1 + if (iter.gt.m) then + jmin=jmin+1 + if (jmin.gt.m) jmin=jmin-m + if (jmax.gt.m) jmax=jmax-m + endif +c +c ---- y, s et (y,s) +c + do 400 i=1,n + sbar(i,jmax)=t*d(i) + ybar(i,jmax)=g(i)-gg(i) +400 continue + call prosca (n,ybar(1,jmax),sbar(1,jmax),d1,izs,rzs,dzs) + if (d1.le.0.0d+0) then + mode=7 + if (impres.ge.1) then + write (bufstr,908) iter,d1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +908 format (/,' >>> n1qn2 (iteration ',i2, + / '): le produit scalaire (y,s) = ',d12.5, + / /,27x,'n''est pas positif') + goto 1000 + endif +c +c ---- precon: facteur de mise a l'echelle +c + call prosca (n,ybar(1,jmax),ybar(1,jmax),ps,izs,rzs,dzs) + precon=d1/ps + if (impres.ge.5) then + write (bufstr,909) d1,precon + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +909 format (/,' n1qn2: mise a jour: (y,s) = ',d10.3, + / ' Oren-Spedicato = ',d10.3) +c +c ---- ybar, sbar +c + d1=sqrt(1.0d+0/d1) + do 410 i=1,n + sbar(i,jmax)=d1*sbar(i,jmax) + ybar(i,jmax)=d1*ybar(i,jmax) +410 continue +c +c ---- calcul de la nouvelle direction de descente d = - h.g +c + do 510 i=1,n + d(i)=-g(i) +510 continue + call strang(prosca,n,m,d,jmin,jmax, + / precon,alpha,ybar,sbar,izs,rzs,dzs) +c +c ---- test: la direction d est-elle de descente ? +c hp0 sera utilise par nlis0 +c + call prosca (n,d,g,hp0,izs,rzs,dzs) + if (hp0.ge.0.0d+0) then + mode=7 + if (impres.ge.1) then + write (bufstr,910) iter,hp0 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +910 format (/,' >>> n1qn2 (iteration ',i2,'): ', + / /,5x,'la direction de recherche d n''est pas de ', + / 'descente: (g,d) = ',d12.5) + goto 1000 + endif + if (impres.ge.5) then + call prosca (n,g,g,ps,izs,rzs,dzs) + ps=sqrt(ps) + call prosca (n,d,d,ps2,izs,rzs,dzs) + ps2=sqrt(ps2) + ps=hp0/ps/ps2 + ps=min(-ps,1.0d+0) + ps=acos(ps) + r=real(ps*180./pi) + write (bufstr,911) r + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +911 format (/,' n1qn2: direction de descente d: ', + / 'angle(-g,d) = ',f5.1,' degres') + endif +c +c---- on poursuit les iterations +c + goto 100 +c +c retour +c +1000 epsg=eps1 + niter=iter + nsim=isim + return + end diff --git a/modules/optimization/src/fortran/n1qn2a.lo b/modules/optimization/src/fortran/n1qn2a.lo new file mode 100755 index 000000000..f1d7afd66 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn2a.lo @@ -0,0 +1,12 @@ +# src/fortran/n1qn2a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1qn2a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1qn3.f b/modules/optimization/src/fortran/n1qn3.f new file mode 100755 index 000000000..f8c51b23d --- /dev/null +++ b/modules/optimization/src/fortran/n1qn3.f @@ -0,0 +1,200 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1qn3 (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1, + / epsg,impres,io,mode,niter,nsim,dz,ndz, + / izs,rzs,dzs) +c +c n1qn3, version 1.0, septembre 1988. +c Jean Charles Gilbert, Claude Lemarechal, INRIA. +c Copyright INRIA +c email: Jean-Charles.Gilbert@inria.fr +c +c Utilise les sous-routines: +c n1qn3a +c ddd2 +c nlis0 + dcube (XII/88) +c +c La sous-routine n1qn3 est une interface entre le programme +c appelant et la sous-routine n1qn3a, le minimiseur proprement dit. +c +c Le module prosca est sense realiser le produit scalaire de deux +c vecteurs de Rn; le module ctonb est sense realiser le changement +c bases: base euclidienne -> base orthonormale (pour le produit +c scalaire prosca); le module ctbas fait la transformation inverse: +c base orthonormale -> base euclidienne. +c +c dz est la zone de travail pour n1qn3a, de dimension ndz. +c Elle est subdivisee en +c 4 vecteurs de dimension n: d,gg,diag,aux +c m scalaires: alpha +c m vecteurs de dimension n: ybar +c m vecteurs de dimension n: sbar +c +c m est alors le plus grand entier tel que +c m*(2*n+1)+4*n .le. ndz, +c soit m := (ndz-4*n) / (2*n+1) +c Il faut avoir m >= 1, donc ndz >= 6n+1. +c +c A chaque iteration la metrique est formee a partir d'une matrice +c diagonale D qui est mise a jour m fois par la formule de BFGS en +c utilisant les m couples {y,s} les plus recents. La matrice +c diagonale est egale apres la premiere iteration a +c (y,s)/|y|**2 * identite (facteur d'Oren-Spedicato) +c et est elle-meme mise a jour a chaque iteration en utilisant la +c formule de BFGS directe diagonalisee adaptee a l'ellipsoide de +c Rayleigh. Si on note +c D[i]:=(De[i],e[i]), y[i]:=(y,e[i]), s[i]:=(s,e[i]), +c ou les e[i] forment une base orthonormale pour le produit scalaire +c (.,.) que realise prosca, la formule de mise a jour de D s'ecrit: +c D[i] := 1 / ( (Dy,y)/(y,s)/D[i] + y[i]**2/(y,s) +c - (Dy,y)*(s[i]/D[i])**2/(y,s)/(D**(-1)s,s) ) +c +c---- +c +c arguments +c + integer n,impres,io,mode,niter,nsim,ndz,izs(1) + real rzs(1) + double precision x(1),f,g(1),dxmin,df1,epsg,dz(1),dzs(1) + external simul,prosca,ctonb,ctcab +c +c variables locales +c + integer ntravu,l1memo,id,igg,iprec,iaux,ialpha,iybar,isbar,m + double precision r1,r2 + double precision ps + character bufstr*(4096) +c +c---- impressions initiales et controle des arguments +c + if (impres.ge.1) then + write (bufstr,900) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,901) n + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,902) dxmin + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,903) df1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,904) epsg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,905) niter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,906) nsim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,907) impres + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +900 format (" n1qn3: entry point") +901 format (5x,"dimension of the problem (n):",i6) +902 format (5x,"absolute precision on x (dxmin):",d9.2) +903 format (5x,"expected decrease for f (df1):",d9.2) +904 format (5x,"relative precision on g (epsg):",d9.2) +905 format (5x,"maximal number of iterations (niter):",i6) +906 format (5x,"maximal number of simulations (nsim):",i6) +907 format (5x,"printing level (impres):",i4) + if (n.le.0.or.niter.le.0.or.nsim.le.0.or.dxmin.le.0.d0 + / .or.epsg.le.0.d0.or.epsg.gt.1.d0) then + mode=2 + if (impres.ge.1) then + write (bufstr,910) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +910 format (" >>> n1qn3: inconsistent call") + return + endif + if (ndz.lt.6*n+1) then + mode=2 + if (impres.ge.1) then + write (bufstr,920) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +920 format (" >>> n1qn3: not enough memory allocated") + goto 940 + endif +c +c---- calcul de m et des pointeurs subdivisant la zone de travail dz +c + ntravu=ndz-4*n + l1memo=2*n+1 + m=ntravu/l1memo + ntravu=m*l1memo+4*n + if (impres.ge.1) then + write (bufstr,930) ndz + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,931) ntravu + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,932) m + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,933) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +930 format (5x,"allocated memory (nrz) :",i7) +931 format (5x,"used memory : ",i7) +932 format (5x,"number of updates : ",i7) +933 format (1x,' ') + id=1 + igg=id+n + iprec=igg+n + iaux=iprec+n + ialpha=iaux+n + iybar=ialpha+m + isbar=iybar+n*m +c +c---- appel du code d"optimisation +c + call n1qn3a (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1,epsg, + / impres,io,mode,niter,nsim,m,dz(id),dz(igg),dz(iprec), + / dz(iaux),dz(ialpha),dz(iybar),dz(isbar),izs,rzs,dzs) +c +c---- impressions finales +c +940 continue + if (impres.ge.1) then + write (bufstr,950) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,951) mode + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,952) niter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,953) nsim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,954) epsg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +950 format (1x,79("-")) +951 format (" n1qn3: output mode is ",i2) +952 format (5x,"number of iterations: ",i4) +953 format (5x,"number of simulations: ",i6) +954 format (5x,"realized relative precision on g: ",d9.2) + + call prosca (n,x,x,ps,izs,rzs,dzs) + r1=sqrt(ps) + call prosca (n,g,g,ps,izs,rzs,dzs) + r2=sqrt(ps) + if (impres.ge.1) then + write (bufstr,960) r1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,961) f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,960) r2 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +960 format (5x,"norm of x = ",d15.8) +961 format (5x,"f = ",d15.8) +962 format (5x,"norm of g = ",d15.8) + return + end diff --git a/modules/optimization/src/fortran/n1qn3.lo b/modules/optimization/src/fortran/n1qn3.lo new file mode 100755 index 000000000..8ba6de5a5 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn3.lo @@ -0,0 +1,12 @@ +# src/fortran/n1qn3.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1qn3.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/n1qn3a.f b/modules/optimization/src/fortran/n1qn3a.f new file mode 100755 index 000000000..7b377ef18 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn3a.f @@ -0,0 +1,391 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine n1qn3a (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1, + / epsg,impres,io,mode,niter,nsim,m,d,gg,diag,aux, + / alpha,ybar,sbar,izs,rzs,dzs) +c---- +c +c Code d'optimisation proprement dit. +c +c---- +c +c arguments +c + integer n,impres,io,mode,niter,nsim,m,izs(1) + real rzs(1) + double precision x(n),f,g(n),dxmin,df1,epsg,d(n),gg(n),diag(n), + / aux(n),alpha(m),ybar(n,m),sbar(n,m),dzs(1) + external simul,prosca,ctonb,ctcab +c +c variables locales +c + integer i,iter,moderl,isim,jmin,jmax,indic + double precision r1,t,tmin,tmax,gnorm,eps1,ff,preco,precos,ys,den, + / dk,dk1,ps,ps2,hp0 + character bufstr*(4096) +c +c parametres +c + double precision rm1,rm2 + parameter (rm1=0.1d-3,rm2=0.9d+0) + double precision pi + parameter (pi=3.1415927d+0) +c +c---- initialisation +c + iter=0 + isim=1 +c + call prosca (n,g,g,ps,izs,rzs,dzs) + gnorm=sqrt(ps) + if (impres.ge.1) then + + write (bufstr,900) f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + + write (bufstr,990) gnorm + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +900 format (5x,"f = ",d15.8) +990 format (5x,"norm of g = ",d15.8) +c +c ---- mise a l'echelle de la premiere direction de descente +c + precos=2.d0*df1/gnorm**2 + do 10 i=1,n + d(i)=-g(i)*precos +10 continue + if (impres.ge.4) then + write(bufstr,899) precos + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +899 format (" n1qn3a: descent direction -g: precon = ",d10.3) + if (impres.eq.3) then + write(bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,9010) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if (impres.eq.4) then + write(bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +c +c ---- initialisation pour nlis0 +c + tmax=1.d+20 + call prosca (n,d,g,hp0,izs,rzs,dzs) +c +c ---- initialisation pour dd +c + jmin=1 + jmax=0 +c +c---- debut de l'iteration. On cherche x(k+1) de la forme x(k) + t*d, +c avec t > 0. On connait d. +c +c Si impres<0 et l'itération est un multiple de -impres, +c alors on appelle la fonction fournie, avec indic=1. +c +100 iter=iter+1 + if (impres.lt.0) then + if(mod(iter,-impres).eq.0) then + indic=1 + call simul (indic,n,x,f,g,izs,rzs,dzs) +c error in user function + if(indic.eq.0) goto 1000 + endif + endif + if (impres.ge.4) then + write(bufstr,901) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +901 format (1x,79("-")) + if (impres.ge.3) then + write(bufstr,9010) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +9010 format (1x,' ') + if (impres.ge.2) then + write (bufstr,902) iter,isim,f,hp0 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +902 format (" n1qn3: iter ",i3,", simul ",i3, + / ", f=",d15.8,", h'(0)=",d12.5) + do 101 i=1,n + gg(i)=g(i) +101 continue + ff=f +c +c ---- recherche lineaire et nouveau point x(k+1) +c + if (impres.ge.4) then + write (bufstr,903) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +903 format (" n1qn3: line search") +c +c ---- calcul de tmin +c + tmin=0.d0 + do 200 i=1,n + tmin=max(tmin,abs(d(i))) +200 continue + tmin=dxmin/tmin + t=1.d0 + r1=hp0 +c + call nlis0 (n,simul,prosca,x,f,r1,t,tmin,tmax,d,g,rm2,rm1, + / impres,io,moderl,isim,nsim,aux,izs,rzs,dzs) +c +c ---- nlis0 renvoie les nouvelles valeurs de x, f et g +c + if (moderl.ne.0) then + if (moderl.lt.0) then +c +c ---- calcul impossible +c t, g: ou les calculs sont impossible +c x, f: ceux du t_gauche (donc f <= ff) +c + mode=moderl + elseif (moderl.eq.1) then +c +c ---- descente bloquee sur tmax +c [sortie rare (!!) d'apres le code de nlis0] +c + mode=3 + if (impres.ge.1) then + write(bufstr,904) iter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +904 format(" >>> n1qn3 (iteration ",i3, + / "): line search blocked on tmax: ", + / "decrease the scaling") + elseif (moderl.eq.4) then +c +c ---- nsim atteint +c x, f: ceux du t_gauche (donc f <= ff) +c + mode=5 + elseif (moderl.eq.5) then +c +c ---- arret demande par l'utilisateur (indic = 0) +c x, f: ceux en sortie du simulateur +c + mode=0 + elseif (moderl.eq.6) then +c +c ---- arret sur dxmin ou appel incoherent +c x, f: ceux du t_gauche (donc f <= ff) +c + mode=6 + endif + goto 1000 + endif +c +c ---- tests d'arret +c + call prosca(n,g,g,ps,izs,rzs,dzs) + eps1=sqrt(ps)/gnorm +c + if (impres.ge.4) then + write (bufstr,905) eps1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +905 format (" n1qn3: stopping criterion on g: ",d12.5) + if (eps1.lt.epsg) then + mode=1 + goto 1000 + endif + if (iter.eq.niter) then + mode=4 + if (impres.ge.1) then + write (bufstr,906) iter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +906 format (" >>> n1qn3 (iteration ",i3, + / "): maximal number of iterations") + goto 1000 + endif + if (isim.gt.nsim) then + mode=5 + if (impres.ge.1) then + write (bufstr,907) iter,isim + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +907 format (" >>> n1qn3 (iteration ",i3,"): ",i6, + / " simulations (maximal number reached)") + goto 1000 + endif +c +c ---- mise a jour de la matrice +c + if (m.gt.0) then + jmax=jmax+1 + if (iter.gt.m) then + jmin=jmin+1 + if (jmin.gt.m) jmin=jmin-m + if (jmax.gt.m) jmax=jmax-m + endif +c +c ---- y, s et (y,s) +c + do 400 i=1,n + sbar(i,jmax)=t*d(i) + ybar(i,jmax)=g(i)-gg(i) +400 continue + if (impres.ge.4) then + call prosca (n,sbar(1,jmax),sbar(1,jmax),ps,izs,rzs,dzs) + dk1=sqrt(ps) + if (iter.gt.1) then + write (bufstr,910) dk1/dk + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +910 format (" n1qn3: convergence rate, s(k)/s(k-1) = ", + / d12.5) + dk=dk1 + endif + call prosca (n,ybar(1,jmax),sbar(1,jmax),ps,izs,rzs,dzs) + ys=ps + if (ys.le.0.d0) then + mode=7 + if (impres.ge.1) then + write (bufstr,908) iter,ys + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +908 format (" >>> n1qn3 (iteration ",i2, + & "): the scalar product (y,s) = ", + & d12.5,27x,"is not positive") + goto 1000 + endif + if (impres.ge.4) then + write(bufstr,909) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +909 format (" n1qn3: matrix update:") +c +c ---- ybar et sbar +c + r1=sqrt(1.d0/ys) + do 410 i=1,n + sbar(i,jmax)=r1*sbar(i,jmax) + ybar(i,jmax)=r1*ybar(i,jmax) +410 continue +c +c ---- calcul de la diagonale de preconditionnement +c + call prosca (n,ybar(1,jmax),ybar(1,jmax),ps,izs,rzs,dzs) + precos=1.d0/ps + if (iter.eq.1) then + do 401 i=1,n + diag(i)=precos +401 continue + else +c +c ---- ajustememt de la diagonale a l'ellipsoide de Rayleigh +c + call ctonb (n,ybar(1,jmax),aux,izs,rzs,dzs) + r1=0.d0 + do 398 i=1,n + r1=r1+diag(i)*aux(i)**2 +398 continue + if (impres.ge.4) then + write (bufstr,915) 1.d0/r1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +915 format(5x,"fitting the ellipsoid: factor ",d10.3) + endif + do 399 i=1,n + diag(i)=diag(i)/r1 +399 continue +c +c ---- mise a jour diagonale +c gg utilise comme vecteur auxiliaire +c + call ctonb (n,sbar(1,jmax),gg,izs,rzs,dzs) + den = 0.d0 + do 402 i=1,n + den = den + gg(i)**2/diag(i) +402 continue + do 403 i=1,n + diag(i)=1.d0/(1.d0/diag(i)+aux(i)**2 + / -(gg(i)/diag(i))**2/den) +403 continue + endif + if (impres.ge.4) then + preco=0.d0 + do 406 i=1,n + preco=preco+diag(i) +406 continue + preco=preco/n + write (bufstr,912) precos,preco + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +912 format (5x,"Oren-Spedicato factor (not used) = ", + / d10.3,5x,"diagonal: average value = ",d10.3) + endif + endif +c +c ---- calcul de la nouvelle direction de descente d = - h.g +c + if (m.eq.0) then + preco=2.d0*(ff-f)/(eps1*gnorm)**2 + do 500 i=1,n + d(i)=-g(i)*preco +500 continue + else + do 510 i=1,n + d(i)=-g(i) +510 continue + call ddd2 (prosca,ctonb,ctcab,n,m,d,aux,jmin,jmax, + / diag,alpha,ybar,sbar,izs,rzs,dzs) + endif +c +c ---- test: la direction d est-elle de descente ? +c hp0 sera utilise par nlis0 +c + call prosca (n,d,g,hp0,izs,rzs,dzs) + if (hp0.ge.0.d+0) then + mode=7 + if (impres.ge.1) then + write (bufstr,913) iter + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,9130) hp0 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +913 format (" >>> n1qn3 (iteration ",i2,"): ") +9130 format (5x," the search direction d is not a", + / "descent direction: (g,d) = ",d12.5) + goto 1000 + endif + if (impres.ge.4) then + call prosca (n,g,g,ps,izs,rzs,dzs) + ps=dsqrt(ps) + call prosca (n,d,d,ps2,izs,rzs,dzs) + ps2=dsqrt(ps2) + ps=hp0/ps/ps2 + ps=dmin1(-ps,1.d+0) + ps=dacos(ps) + r1=ps*180.d0/pi + write (bufstr,914) sngl(r1) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +914 format (" n1qn3: descent direction d: ", + / "angle(-g,d) = ",f5.1," degrees") + endif +c +c---- on poursuit les iterations +c + goto 100 +c +c---- retour +c +1000 niter=iter + nsim=isim + epsg=eps1 + return + end diff --git a/modules/optimization/src/fortran/n1qn3a.lo b/modules/optimization/src/fortran/n1qn3a.lo new file mode 100755 index 000000000..28fd79715 --- /dev/null +++ b/modules/optimization/src/fortran/n1qn3a.lo @@ -0,0 +1,12 @@ +# src/fortran/n1qn3a.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/n1qn3a.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/nlis0.f b/modules/optimization/src/fortran/nlis0.f new file mode 100755 index 000000000..165d5d581 --- /dev/null +++ b/modules/optimization/src/fortran/nlis0.f @@ -0,0 +1,279 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine nlis0 (n,simul,prosca,xn,fn,fpn,t,tmin,tmax,d,g, + / amd,amf,imp,io,logic,nap,napmax,x,izs,rzs,dzs) +c +c nlis0 + minuscules + commentaires +c --------------------------------- +c +c en sortie logic = +c +c 0 descente serieuse +c 1 descente bloquee +c 4 nap > napmax +c 5 retour a l'utilisateur +c 6 fonction et gradient pas d'accord +c < 0 contrainte implicite active +c +c ---- +c +c --- arguments +c + external simul,prosca + integer n,imp,io,logic,nap,napmax,izs(*) + real rzs(*) + double precision xn(n),fn,fpn,t,tmin,tmax,d(n),g(n),amd,amf,x(n) + double precision dzs(*) +c +c --- variables locales +c + integer i,indic,indica,indicd + double precision tesf,tesd,tg,fg,fpg,td,ta,fa,fpa,d2,f,fp,ffn,fd, + / fpd,z,z1,test + character bufstr*(4096) +c + 1000 format (4x,9h nlis0 ,4x,4hfpn=,d10.3,4h d2=,d9.2, + 1 7h tmin=,d9.2,6h tmax=,d9.2) + 1001 format (4x,6h nlis0,3x,12hfin sur tmin,8x, + 1 3hpas,12x,9hfonctions,5x,8hderivees) + 1002 format (4x,6h nlis0,37x,d10.3,2d11.3) + 1003 format (4x,6h nlis0,d14.3,2d11.3) + 1004 format (4x,6h nlis0,37x,d10.3,7h indic=,i3) + 1005 format (4x,6h nlis0,14x,2d18.8,d11.3) + 1006 format (4x,6h nlis0,14x,d18.8,12h indic=,i3) + 1007 format (4x,6h nlis0,10x,17htmin force a tmax) + 1008 format (4x,6h nlis0,10x,16happel incoherent) + if (n.gt.0 .and. fpn.lt.0.d+0 .and. t.gt.0.d+0 + 1 .and. tmax.gt.0.d+0 .and. amf.gt.0.d+0 + 1 .and. amd.gt.amf .and. amd.lt.1.d+0) go to 5 + logic=6 + go to 999 + 5 tesf=amf*fpn + tesd=amd*fpn + td=0.d+0 + tg=0.d+0 + fg=fn + fpg=fpn + ta=0.d+0 + fa=fn + fpa=fpn + call prosca (n,d,d,d2,izs,rzs,dzs) +c +c elimination d'un t initial ridiculement petit +c + if (t.gt.tmin) go to 20 + t=tmin + if (t.le.tmax) go to 20 + if (imp.gt.0) then + write (bufstr,1007) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + tmin=tmax + 20 if (fn+t*fpn.lt.fn+0.9d+0*t*fpn) go to 30 + t=2.d+0*t + go to 20 + 30 indica=1 + logic=0 + if (t.gt.tmax) then + t=tmax + logic=1 + endif + if (imp.ge.3) then + write (bufstr,1000) fpn,d2,tmin,tmax + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +c +c --- nouveau x +c + do 50 i=1,n + x(i)=xn(i)+t*d(i) + 50 continue +c +c --- boucle +c + 100 nap=nap+1 + if(nap.gt.napmax) then + logic=4 + fn=fg + do 120 i=1,n + xn(i)=xn(i)+tg*d(i) + 120 continue + go to 999 + endif + indic=4 +c +c --- appel simulateur +c + call simul(indic,n,x,f,g,izs,rzs,dzs) + if(indic.eq.0) then +c +c --- arret demande par l'utilisateur +c + logic=5 + fn=f + do 170 i=1,n + xn(i)=x(i) + 170 continue + go to 999 + endif + if(indic.lt.0) then +c +c --- les calculs n'ont pas pu etre effectues par le simulateur +c + td=t + indicd=indic + logic=0 + if (imp.ge.3) then + write (bufstr,1004) t,indic + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + t=tg+0.1d+0*(td-tg) + go to 905 + endif +c +c --- les tests elementaires sont faits, on y va +c + call prosca (n,d,g,fp,izs,rzs,dzs) +c +c --- premier test de Wolfe +c + ffn=f-fn + if(ffn.gt.t*tesf) then + td=t + fd=f + fpd=fp + indicd=indic + logic=0 + if(imp.ge.3) then + write (bufstr,1002) t,ffn,fp + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + go to 500 + endif +c +c --- test 1 ok, donc deuxieme test de Wolfe +c + if(imp.ge.3) then + write (bufstr,1003) t,ffn,fp + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if(fp.gt.tesd) then + logic=0 + go to 320 + endif + if (logic.eq.0) go to 350 +c +c --- test 2 ok, donc pas serieux, on sort +c + 320 fn=f + do 330 i=1,n + xn(i)=x(i) + 330 continue + go to 999 +c +c +c + 350 tg=t + fg=f + fpg=fp + if(td.ne.0.d+0) go to 500 +c +c extrapolation +c + ta=t + t=9.d+0*tg + z=fpn+3.d+0*fp-4.d+0*ffn/tg + if(z.gt.0.d+0) t=dmin1(t,tg*dmax1(1.d+0,-fp/z)) + t=tg+t + if(t.lt.tmax) go to 900 + logic=1 + t=tmax + go to 900 +c +c interpolation +c + 500 if(indica.le.0) then + ta=t + t=0.9d+0*tg+0.1d+0*td + go to 900 + endif + z=fp+fpa-3.d+0*(fa-f)/(ta-t) + z1=z*z-fp*fpa + if(z1.lt.0.d+0) then + ta=t + t=0.5d+0*(td+tg) + go to 900 + endif + if(t.lt.ta) z1=z-dsqrt(z1) + if(t.gt.ta) z1=z+dsqrt(z1) + z=fp/(fp+z1) + z=t+z*(ta-t) + ta=t + test=0.1d+0*(td-tg) + t=dmax1(z,tg+test) + t=dmin1(t,td-test) +c +c --- fin de boucle +c - t peut etre bloque sur tmax +c (venant de l'extrapolation avec logic=1) +c + 900 fa=f + fpa=fp + 905 indica=indic +c +c --- faut-il continuer ? +c + if (td.eq.0.d+0) go to 950 + if (td-tg.lt.tmin) go to 920 +c +c --- limite de precision machine (arret de secours) ? +c + do 910 i=1,n + z=xn(i)+t*d(i) + if (z.ne.xn(i).and.z.ne.x(i)) go to 950 + 910 continue +c +c --- arret sur dxmin ou de secours +c + 920 logic=6 +c +c si indicd<0, les derniers calculs n'ont pas pu etre fait par simul +c + if (indicd.lt.0) logic=indicd +c +c si tg=0, xn = xn_depart, +c sinon on prend xn=x_gauche qui fait decroitre f +c + if (tg.eq.0.d+0) go to 940 + fn=fg + do 930 i=1,n + 930 xn(i)=xn(i)+tg*d(i) + 940 if (imp.le.0) go to 999 + write (bufstr,1001) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write (bufstr,1005) tg,fg,fpg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + if (logic.eq.6) then + write (bufstr,1005) td,fd,fpd + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if (logic.eq.7) then + write (bufstr,1006) td,indicd + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + go to 999 +c +c recopiage de x et boucle +c + 950 do 960 i=1,n + 960 x(i)=xn(i)+t*d(i) + go to 100 + 999 return + end diff --git a/modules/optimization/src/fortran/nlis0.lo b/modules/optimization/src/fortran/nlis0.lo new file mode 100755 index 000000000..e2c3ce4a7 --- /dev/null +++ b/modules/optimization/src/fortran/nlis0.lo @@ -0,0 +1,12 @@ +# src/fortran/nlis0.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/nlis0.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/nlis2.f b/modules/optimization/src/fortran/nlis2.f new file mode 100755 index 000000000..b451069e4 --- /dev/null +++ b/modules/optimization/src/fortran/nlis2.f @@ -0,0 +1,284 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine nlis2 (simul,prosca,n,xn,fn,fpn,t,tmin,tmax,d,d2,g,gd, + 1 amd,amf,imp,io,logic,nap,napmax,x,tol,a,tps,tnc,gg,izs,rzs + $ ,dzs) +c +c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c subroutine effectuant une recherche lineaire sur 0 tmax +c partant du point xn dans la direction d. +c sous l'hypothese d'hemiderivabilite, donne +c un pas serieux, bloque, nul ou semi serieux-nul (2 gradients). +c necessite fpn < 0 estimant la derivee a l'origine. +c appelle simul systematiquement avec indic = 4 +c +c logic +c 0 descente serieuse +c 1 descente bloquee +c 2 pas semiserieux-nul +c 3 pas nul, enrichissement du faiseau +c 4 nap > napmax +c 5 retour a l'utilisateur +c 6 non hemi-derivable (au-dela de dx) +c < 0 contrainte implicite active +c +c imp +c =0 pas d'impressions +c >0 message en cas de fin anormale +c >3 informations pour chaque essai de t +c ---------------------------------------- +c fait appel aux subroutines: +c -------simul(indic,n,x,f,g,izs,rzs,dzs) +c -------prosca(n,u,v,ps,izs,rzs,dzs) +c +c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + implicit double precision (a-h,o-z) + external simul,prosca + dimension xn(n),d(n),g(n),x(n),izs(*),dzs(*),gg(n),gd(n) + real rzs(*) + dimension d3(1),d4(1),i5(1) +c +c initialisations +c + tesf=amf*fpn + tesd=amd*fpn + td=0.d0 + tg=0.d0 + fg=fn + fpg=fpn + ta=0.d0 + fa=fn + fpa=fpn + indica=1 + logic=0 +c elimination d'un t initial ridiculement petit + if (t.gt.tmin) go to 20 + t=tmin + if (t.le.tmax) go to 20 + if (imp.gt.0) call n1fc1o(io,35,i1,i2,i3,i4,i5,d1,d2,d3,d4) + tmin=tmax + 20 if (fn+t*fpn.lt.fn+0.9d0*t*fpn) go to 30 + t=2.d0*t + go to 20 +c + 30 if(t.lt.tmax) go to 40 + t=tmax + logic=1 + 40 if (imp.ge.4) call n1fc1o(io,36,i1,i2,i3,i4,i5,fpn,d2,tmin,tmax) + do 50 i=1,n + 50 x(i)=xn(i)+t*d(i) +c +c boucle +c + 100 nap=nap+1 + if(nap.le.napmax) go to 150 +c sortie par maximum de simulations + logic=4 + if(imp.ge.4) call n1fc1o(io,37,nap,i2,i3,i4,i5,d1,d2,d3,d4) + if (tg.eq.0.d0) go to 999 + fn=fg + do 120 i=1,n + g(i)=gg(i) + 120 xn(i)=xn(i)+tg*d(i) + go to 999 + 150 indic=4 + call simul(indic,n,x,f,g,izs,rzs,dzs) + if(indic.ne.0) go to 200 +c +c arret demande par l'utilisateur + logic=5 + fn=f + do 170 i=1,n + 170 xn(i)=x(i) + if(imp.ge.4)call n1fc1o(io,38,i1,i2,i3,i4,i5,d1,d2,d3,d4) + go to 999 +c +c les tests elementaires sont faits, on y va +c tout d'abord, ou en sommes nous ? +c + 200 if(indic.gt.0) go to 210 + td=t + indicd=indic + logic=0 + if (imp.ge.4) call n1fc1o(io,39,indic,i2,i3,i4,i5,t,d2,d3,d4) + t=tg+0.1d0*(td-tg) + go to 905 +c +c calcul de la derivee directionnelle h'(t) + 210 call prosca(n,g,d,fp,izs,rzs,dzs) +c +c test de descente (premiere inegalite pour un pas serieux) + ffn=f-fn + if(ffn.lt.t*tesf) go to 300 + td=t + fd=f + fpd=fp + do 230 i=1,n + 230 gd(i)=g(i) + indicd=indic + logic=0 + if(imp.ge.4) call n1fc1o(io,40,i1,i2,i3,i4,i5,t,ffn,fp,d4) + if(tg.ne.0.) go to 500 +c tests pour un pas nul (si tg=0) + if(fpd.lt.tesd) go to 500 + tps=(fn-f)+td*fpd + tnc=d2*td*td + p=max(a*tnc,tps) + if(p.gt.tol) go to 500 + logic=3 + go to 999 +c +c descente + 300 if(imp.ge.4) call n1fc1o(io,41,i1,i2,i3,i4,i5,t,ffn,fp,d4) +c +c test de derivee (deuxieme inegalite pour un pas serieux) + if(fp.lt.tesd) go to 320 +c +c sortie, le pas est serieux + logic=0 + fn=f + fpn=fp + do 310 i=1,n + 310 xn(i)=x(i) + go to 999 +c + 320 if (logic.eq.0) go to 350 +c +c sortie par descente bloquee + fn=f + fpn=fp + do 330 i=1,n + 330 xn(i)=x(i) + go to 999 +c +c on a une descente + 350 tg=t + fg=f + fpg=fp + do 360 i=1,n + 360 gg(i)=g(i) +c + if(td.ne.0.d0) go to 500 +c extrapolation + ta=t + t=9.d0*tg + z=fpn+3.d0*fp-4.d0*ffn/tg + if(z.gt.0.d0) t=dmin1(t,tg*dmax1(1.d0,-fp/z)) + t=tg+t + if(t.lt.tmax) go to 900 + logic=1 + t=tmax + go to 900 +c +c interpolation +c + 500 if(indica.gt.0 .and. indicd.gt.0) go to 510 + ta=t + t=0.9d0*tg+0.1d0*td + go to 900 + 510 test=0.1d0*(td-tg) +c approximation cubique + ps=fp+fpa-3.d0*(fa-f)/(ta-t) + z1=ps*ps-fp*fpa + if (z1.ge.0.d0) go to 520 + if (fp.lt.0.d0) tc=td + if (fp.ge.0.d0) tc=tg + go to 600 + 520 z1=dsqrt(z1) + if (t-ta.lt.0.d0) z1=-z1 + sign=(t-ta)/dabs(t-ta) + if ((ps+fp)*sign.gt.0.d0) go to 550 + den=2.d0*ps+fp+fpa + anum=z1-fp-ps + if (dabs((t-ta)*anum).ge.(td-tg)*dabs(den)) go to 530 + tc=t+anum*(ta-t)/den + go to 600 + 530 tc=td + go to 600 + 550 tc=t+fp*(ta-t)/(ps+fp+z1) + 600 mc=0 + if (tc.lt.tg) mc=-1 + if (tc.gt.td) mc=1 + tc=max(tc,tg+test) + tc=min(tc,td-test) +c approximation polyhedrique + ps=fpd-fpg + if (ps.ne.0.d0) go to 620 + tp=0.5d0*(td+tg) + go to 650 + 620 tp=((fg-fpg*tg)-(fd-fpd*td))/ps + 650 mp=0 + if (tp.lt.tg) mp=-1 + if (tp.gt.td) mp=1 + tp=max(tp,tg+test) + tp=min(tp,td-test) +c nouveau t par approximation cp complete securisee + ta=t + if (mc.eq.0 .and. mp.eq.0) t=dmin1(tc,tp) + if (mc.eq.0 .and. mp.ne.0) t=tc + if (mc.ne.0 .and. mp.eq.0) t=tp + if (mc.eq.1 .and. mp.eq.1) t=td-test + if (mc.eq.-1 .and. mp.eq.-1) t=tg+test + if (mc*mp.eq.-1) t=0.5d0*(tg+td) +c +c fin de boucle +c + 900 fa=f + fpa=fp + 905 indica=indic +c peut-on faire logic=2 ? + if (td.eq.0.d0) go to 920 + if (indicd.lt.0) go to 920 + if (td-tg.gt.10.d0*tmin) go to 920 + if (fpd.lt.tesd) go to 920 + tps=(fg-fd)+(td-tg)*fpd + tnc=d2*(td-tg)*(td-tg) + p=max(a*tnc,tps) + if(p.gt.tol) go to 920 +c sortie par pas semiserieux-nul + logic=2 + fn=fg + fpn=fpg + t=tg + do 910 i=1,n + xn(i)=xn(i)+tg*d(i) + 910 g(i)=gg(i) + go to 999 +c +c test d'arret sur la proximite de tg et td +c + 920 if (td.eq.0.d0) go to 990 + if (td-tg.le.tmin) go to 950 + do 930 i=1,n + z=xn(i)+t*d(i) + if (z.ne.x(i) .and. z.ne.xn(i)) go to 990 + 930 continue +c arret sur dx ou de secours + 950 logic=6 + if (indicd.lt.0) logic=indicd + if (tg.eq.0.d0) go to 970 + fn=fg + do 960 i=1,n + xn(i)=xn(i)+tg*d(i) + 960 g(i)=gg(i) + 970 if (imp.le.0) go to 999 + if (logic.lt.0) call n1fc1o(io,42,logic,i2,i3,i4,i5,d1,d2,d3,d4) + if (logic.eq.6) call n1fc1o(io,42,logic,i2,i3,i4,i5,d1,d2,d3,d4) + go to 999 +c +c recopiage de x et boucle + 990 do 995 i=1,n + 995 x(i)=xn(i)+t*d(i) + go to 100 +c + 999 return + end diff --git a/modules/optimization/src/fortran/nlis2.lo b/modules/optimization/src/fortran/nlis2.lo new file mode 100755 index 000000000..9035e86c3 --- /dev/null +++ b/modules/optimization/src/fortran/nlis2.lo @@ -0,0 +1,12 @@ +# src/fortran/nlis2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/nlis2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/optimization_f.rc b/modules/optimization/src/fortran/optimization_f.rc new file mode 100755 index 000000000..da00f3953 --- /dev/null +++ b/modules/optimization/src/fortran/optimization_f.rc @@ -0,0 +1,96 @@ +// Microsoft Visual C++ generated resource script. +// + + +#define APSTUDIO_READONLY_SYMBOLS +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 2 resource. +// +//#include "afxres.h" +#define APSTUDIO_HIDDEN_SYMBOLS +#include "windows.h" +///////////////////////////////////////////////////////////////////////////// +#undef APSTUDIO_READONLY_SYMBOLS + +///////////////////////////////////////////////////////////////////////////// +// French (France) resources + +#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_FRA) +#ifdef _WIN32 +LANGUAGE LANG_FRENCH, SUBLANG_FRENCH +#pragma code_page(1252) +#endif //_WIN32 + +#ifdef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// TEXTINCLUDE +// + +1 TEXTINCLUDE +BEGIN + "resource.h\0" +END + +3 TEXTINCLUDE +BEGIN + "\r\n" + "\0" +END + +#endif // APSTUDIO_INVOKED + + +///////////////////////////////////////////////////////////////////////////// +// +// Version +// + +VS_VERSION_INFO VERSIONINFO + FILEVERSION 5,5,2,0 + PRODUCTVERSION 5,5,2,0 + FILEFLAGSMASK 0x17L +#ifdef _DEBUG + FILEFLAGS 0x1L +#else + FILEFLAGS 0x0L +#endif + FILEOS 0x4L + FILETYPE 0x2L + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040c04b0" + BEGIN + VALUE "FileDescription", "optmization_f module" + VALUE "FileVersion", "5, 5, 2, 0" + VALUE "InternalName", "optmization_f module" + VALUE "LegalCopyright", "Copyright (C) 2017" + VALUE "OriginalFilename", "optmization_f.dll" + VALUE "ProductName", "optmization_f module" + VALUE "ProductVersion", "5, 5, 2, 0" + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x40c, 1200 + END +END + +#endif // French (France) resources +///////////////////////////////////////////////////////////////////////////// + + + +#ifndef APSTUDIO_INVOKED +///////////////////////////////////////////////////////////////////////////// +// +// Generated from the TEXTINCLUDE 3 resource. +// + + +///////////////////////////////////////////////////////////////////////////// +#endif // not APSTUDIO_INVOKED + diff --git a/modules/optimization/src/fortran/optimization_f.vfproj b/modules/optimization/src/fortran/optimization_f.vfproj new file mode 100755 index 000000000..b1ee07d7d --- /dev/null +++ b/modules/optimization/src/fortran/optimization_f.vfproj @@ -0,0 +1,220 @@ +<?xml version="1.0" encoding="UTF-8"?> +<VisualStudioProject ProjectType="typeDynamicLibrary" ProjectCreator="Intel Fortran" Keyword="Dll" Version="11.0" ProjectIdGuid="{1D219098-007C-4F76-9AE6-271ABBB7D393}"> + <Platforms> + <Platform Name="Win32"/> + <Platform Name="x64"/></Platforms> + <Configurations> + <Configuration Name="Debug|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="optimization_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib optimization.lib string.lib output_stream.lib io_f.lib elementary_functions.lib elementary_functions_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)String_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|Win32" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="optimization_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib optimization.lib string.lib output_stream.lib io_f.lib elementary_functions.lib elementary_functions_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)String_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X86 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Debug|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" DebugInformationFormat="debugEnabled" Optimization="optimizeDisabled" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDebugDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="optimization_f.def" GenerateDebugInformation="true" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib optimization.lib string.lib output_stream.lib io_f.lib elementary_functions.lib elementary_functions_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration> + <Configuration Name="Release|x64" OutputDirectory="$(SolutionDir)bin\" IntermediateDirectory="$(ProjectDir)$(ConfigurationName)" DeleteExtensionsOnClean="*.obj;*.mod;*.pdb;*.asm;*.map;*.dyn;*.dpi;*.tmp;*.log;*.ilk;*.dll;$(TargetPath)" ConfigurationType="typeDynamicLibrary"> + <Tool Name="VFFortranCompilerTool" SuppressStartupBanner="true" AdditionalIncludeDirectories="../../../core/includes" PreprocessorDefinitions="WIN32;FORDLL" AlternateParameterSyntax="false" F77RuntimeCompatibility="true" FPS4Libs="false" CallingConvention="callConventionCRef" ExternalNameUnderscore="true" ModulePath="$(INTDIR)/" ObjectFile="$(INTDIR)/" RuntimeLibrary="rtMultiThreadedDLL"/> + <Tool Name="VFLinkerTool" OutputFile="$(SolutionDir)bin\$(ProjectName).dll" LinkIncremental="linkIncrementalNo" SuppressStartupBanner="true" ModuleDefinitionFile="optimization_f.def" SubSystem="subSystemWindows" ImportLibrary="$(SolutionDir)bin\$(ProjectName).lib" LinkDLL="true" AdditionalDependencies="../../../../bin/blasplus.lib ../../../../bin/lapack.lib core.lib optimization.lib string.lib output_stream.lib io_f.lib elementary_functions.lib elementary_functions_f.lib linpack_f.lib core_f.lib"/> + <Tool Name="VFResourceCompilerTool"/> + <Tool Name="VFMidlTool" SuppressStartupBanner="true" HeaderFileName="$(InputName).h" TypeLibraryName="$(IntDir)/$(InputName).tlb"/> + <Tool Name="VFCustomBuildTool"/> + <Tool Name="VFPreLinkEventTool" CommandLine="setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .." Description="Build $(ProjectName).def"/> + <Tool Name="VFPreBuildEventTool" CommandLine="lib /DEF:"$(InputDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)string_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(InputDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:X64 /OUT:"$(InputDir)core_f.lib" 1>NUL 2>NUL" Description="Build Dependencies"/> + <Tool Name="VFPostBuildEventTool"/> + <Tool Name="VFManifestTool" SuppressStartupBanner="true"/></Configuration></Configurations> + <Files> + <Filter Name="Header Files" Filter="fi;fd"/> + <Filter Name="Library Dependencies"> + <File RelativePath=".\Core_f_Import.def"/> + <File RelativePath=".\core_import.def"/> + <File RelativePath=".\Elementary_functions_f_Import.def"/> + <File RelativePath=".\Elementary_functions_Import.def"/> + <File RelativePath=".\io_f_Import.def"/> + <File RelativePath=".\linpack_f_Import.def"/> + <File RelativePath=".\Optimization_Import.def"/> + <File RelativePath=".\Output_stream_Import.def"/> + <File RelativePath=".\String_Import.def"/></Filter> + <Filter Name="Resource Files" Filter="rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe"> + <File RelativePath=".\optimization_f.rc"/></Filter> + <Filter Name="Source Files" Filter="f90;for;f;fpp;ftn;def;odl;idl"> + <File RelativePath=".\ajour.f"/> + <File RelativePath=".\bfgsd.f"/> + <File RelativePath="..\..\sci_gateway\fortran\bjlsqrsolv.f"/> + <File RelativePath="..\..\sci_gateway\fortran\bjsolv.f"/> + <File RelativePath="..\..\sci_gateway\fortran\blsqrsolv.f"/> + <File RelativePath="..\..\sci_gateway\fortran\boptim.f"/> + <File RelativePath="..\..\sci_gateway\fortran\bsolv.f"/> + <File RelativePath=".\calbx.f"/> + <File RelativePath=".\calmaj.f"/> + <File RelativePath=".\ctcab.f"/> + <File RelativePath=".\ctonb.f"/> + <File RelativePath=".\dcube.f"/> + <File RelativePath=".\ddd2.f"/> + <File RelativePath=".\minpack\dogleg.f"/> + <File RelativePath=".\minpack\dpmpar.f"/> + <File RelativePath=".\minpack\enorm.f"/> + <File RelativePath="..\..\sci_gateway\fortran\Ex-fsolve.f"/> + <File RelativePath="..\..\sci_gateway\fortran\Ex-lsqrsolve.f"/> + <File RelativePath="..\..\sci_gateway\fortran\Ex-optim.f"/> + <File RelativePath=".\fajc1.f"/> + <File RelativePath=".\fcomp1.f"/> + <File RelativePath=".\fcube.f"/> + <File RelativePath=".\minpack\fdjac1.f"/> + <File RelativePath=".\minpack\fdjac2.f"/> + <File RelativePath=".\ffinf1.f"/> + <File RelativePath=".\fmani1.f"/> + <File RelativePath=".\fmc11a.f"/> + <File RelativePath=".\fmc11b.f"/> + <File RelativePath=".\fmc11e.f"/> + <File RelativePath=".\fmc11z.f"/> + <File RelativePath=".\fmlag1.f"/> + <File RelativePath=".\fmulb1.f"/> + <File RelativePath=".\fmuls1.f"/> + <File RelativePath=".\fprf2.f"/> + <File RelativePath=".\frdf1.f"/> + <File RelativePath=".\fremf2.f"/> + <File RelativePath=".\fuclid.f"/> + <File RelativePath=".\gcbd.f"/> + <File RelativePath=".\gcp.f"/> + <File RelativePath=".\minpack\hybrd.f"/> + <File RelativePath=".\minpack\hybrd1.f"/> + <File RelativePath=".\minpack\hybrj.f"/> + <File RelativePath=".\minpack\hybrj1.f"/> + <File RelativePath=".\icscof.f"/> + <File RelativePath=".\icse.f"/> + <File RelativePath=".\icse0.f"/> + <File RelativePath=".\icse1.f"/> + <File RelativePath=".\icse2.f"/> + <File RelativePath=".\icsec2.f"/> + <File RelativePath=".\icsei.f"/> + <File RelativePath="..\..\sci_gateway\fortran\intlsqrsolve.f"/> + <File RelativePath=".\intreadmps.f"/> + <File RelativePath=".\minpack\lmder.f"/> + <File RelativePath=".\minpack\lmdif.f"/> + <File RelativePath=".\minpack\lmpar.f"/> + <File RelativePath=".\majour.f"/> + <File RelativePath=".\majysa.f"/> + <File RelativePath=".\majz.f"/> + <File RelativePath=".\n1fc1.f"/> + <File RelativePath=".\n1fc1a.f"/> + <File RelativePath=".\n1fc1o.f"/> + <File RelativePath=".\n1gc2.f"/> + <File RelativePath=".\n1gc2a.f"/> + <File RelativePath=".\n1gc2b.f"/> + <File RelativePath=".\n1qn1.f"/> + <File RelativePath=".\n1qn1a.f"/> + <File RelativePath=".\n1qn2.f"/> + <File RelativePath=".\n1qn2a.f"/> + <File RelativePath=".\n1qn3.f"/> + <File RelativePath=".\n1qn3a.f"/> + <File RelativePath=".\nlis0.f"/> + <File RelativePath=".\nlis2.f"/> + <File RelativePath=".\proj.f"/> + <File RelativePath=".\minpack\qform.f"/> + <File RelativePath=".\ql0001.f"/> + <File RelativePath=".\qnbd.f"/> + <File RelativePath=".\qpgen1sci.f"/> + <File RelativePath=".\qpgen2.f"/> + <File RelativePath=".\minpack\qrfac.f"/> + <File RelativePath=".\minpack\qrsolv.f"/> + <File RelativePath=".\minpack\r1mpyq.f"/> + <File RelativePath=".\minpack\r1updt.f"/> + <File RelativePath=".\rdmps1.f"/> + <File RelativePath=".\rdmpsz.f"/> + <File RelativePath=".\rednor.f"/> + <File RelativePath=".\relvar.f"/> + <File RelativePath=".\rlbd.f"/> + <File RelativePath=".\satur.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_fsolve.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_optim.f"/> + <File RelativePath="..\..\sci_gateway\fortran\sci_f_semidef.f"/> + <File RelativePath=".\shanph.f"/> + <File RelativePath=".\strang.f"/> + <File RelativePath=".\writebuf.f"/> + <File RelativePath=".\zgcbd.f"/> + <File RelativePath=".\zqnbd.f"/></Filter> + <File RelativePath="..\..\Makefile.am"/> + <File RelativePath="..\..\sci_gateway\optimization_gateway.xml"/></Files> + <Globals/></VisualStudioProject> diff --git a/modules/optimization/src/fortran/optimization_f2c.vcxproj b/modules/optimization/src/fortran/optimization_f2c.vcxproj new file mode 100755 index 000000000..2d731fe67 --- /dev/null +++ b/modules/optimization/src/fortran/optimization_f2c.vcxproj @@ -0,0 +1,494 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project DefaultTargets="Build" ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup Label="ProjectConfigurations"> + <ProjectConfiguration Include="Debug|Win32"> + <Configuration>Debug</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Debug|x64"> + <Configuration>Debug</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|Win32"> + <Configuration>Release</Configuration> + <Platform>Win32</Platform> + </ProjectConfiguration> + <ProjectConfiguration Include="Release|x64"> + <Configuration>Release</Configuration> + <Platform>x64</Platform> + </ProjectConfiguration> + </ItemGroup> + <PropertyGroup Label="Globals"> + <ProjectName>optimization_f</ProjectName> + <ProjectGuid>{1D219098-007C-4F76-9AE6-271ABBB7D393}</ProjectGuid> + <RootNamespace>optimization_f2c</RootNamespace> + <Keyword>Win32Proj</Keyword> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.Default.props" /> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <WholeProgramOptimization>true</WholeProgramOptimization> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <PropertyGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="Configuration"> + <ConfigurationType>DynamicLibrary</ConfigurationType> + <CharacterSet>Unicode</CharacterSet> + <PlatformToolset>v110</PlatformToolset> + </PropertyGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.props" /> + <ImportGroup Label="ExtensionSettings"> + <Import Project="..\..\..\..\Visual-Studio-settings\f2c.props" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <ImportGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'" Label="PropertySheets"> + <Import Project="$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props" Condition="exists('$(UserRootDir)\Microsoft.Cpp.$(Platform).user.props')" Label="LocalAppDataPlatform" /> + </ImportGroup> + <PropertyGroup Label="UserMacros" /> + <PropertyGroup> + <_ProjectFileVersion>10.0.30319.1</_ProjectFileVersion> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Debug|x64'">true</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|Win32'">false</LinkIncremental> + <OutDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(SolutionDir)bin\</OutDir> + <IntDir Condition="'$(Configuration)|$(Platform)'=='Release|x64'">$(ProjectDir)$(Configuration)\</IntDir> + <LinkIncremental Condition="'$(Configuration)|$(Platform)'=='Release|x64'">false</LinkIncremental> + </PropertyGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|Win32'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)String_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;optimization.lib;string.lib;output_stream.lib;io_f.lib;elementary_functions.lib;elementary_functions_f.lib;linpack_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>optimization_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Debug|x64'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)String_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <Optimization>Disabled</Optimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;_DEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDebugDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;optimization.lib;string.lib;output_stream.lib;io_f.lib;elementary_functions.lib;elementary_functions_f.lib;linpack_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>optimization_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|Win32'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)String_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;optimization.lib;string.lib;output_stream.lib;io_f.lib;elementary_functions.lib;elementary_functions_f.lib;linpack_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>optimization_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX86</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemDefinitionGroup Condition="'$(Configuration)|$(Platform)'=='Release|x64'"> + <PreBuildEvent> + <Message>Build Dependencies</Message> + <Command>lib /DEF:"$(ProjectDir)core_import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)optimization_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)optimization.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)String_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)string.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)Output_stream_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)output_stream.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)io_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)io_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)elementary_functions_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)elementary_functions_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)linpack_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)linpack_f.lib" 1>NUL 2>NUL +lib /DEF:"$(ProjectDir)core_f_Import.def" /SUBSYSTEM:WINDOWS /MACHINE:$(Platform) /OUT:"$(ProjectDir)core_f.lib" 1>NUL 2>NUL</Command> + </PreBuildEvent> + <Midl> + <TargetEnvironment>X64</TargetEnvironment> + </Midl> + <ClCompile> + <WholeProgramOptimization>false</WholeProgramOptimization> + <AdditionalIncludeDirectories>../../../../libs/f2c;%(AdditionalIncludeDirectories)</AdditionalIncludeDirectories> + <PreprocessorDefinitions>WIN32;NDEBUG;_WINDOWS;_USRDLL;OPTIMIZATION_F2C_EXPORTS;FORDLL;%(PreprocessorDefinitions)</PreprocessorDefinitions> + <RuntimeLibrary>MultiThreadedDLL</RuntimeLibrary> + <WarningLevel>Level3</WarningLevel> + <MultiProcessorCompilation>true</MultiProcessorCompilation> + </ClCompile> + <PreLinkEvent> + <Message>Build $(ProjectName).def</Message> + <Command>setlocal EnableDelayedExpansion +cd $(ConfigurationName) +set LIST_OBJ= +for %%f in (*.obj) do set LIST_OBJ=!LIST_OBJ! %%f +"$(SolutionDir)bin\dumpexts" -o $(ProjectName).def $(ProjectName).dll %LIST_OBJ% +copy $(ProjectName).def ..\$(ProjectName).def >nul +del *.def >nul +cd .. +</Command> + </PreLinkEvent> + <Link> + <AdditionalDependencies>core.lib;optimization.lib;string.lib;output_stream.lib;io_f.lib;elementary_functions.lib;elementary_functions_f.lib;linpack_f.lib;core_f.lib;../../../../bin/blasplus.lib;../../../../bin/lapack.lib;../../../../bin/libf2c.lib;%(AdditionalDependencies)</AdditionalDependencies> + <OutputFile>$(SolutionDir)bin\$(ProjectName).dll</OutputFile> + <ModuleDefinitionFile>optimization_f.def</ModuleDefinitionFile> + <GenerateDebugInformation>true</GenerateDebugInformation> + <SubSystem>Windows</SubSystem> + <OptimizeReferences>true</OptimizeReferences> + <EnableCOMDATFolding>true</EnableCOMDATFolding> + <ImportLibrary>$(SolutionDir)bin\$(ProjectName).lib</ImportLibrary> + <TargetMachine>MachineX64</TargetMachine> + <CLRUnmanagedCodeCheck>true</CLRUnmanagedCodeCheck> + <RandomizedBaseAddress>false</RandomizedBaseAddress> + <LinkTimeCodeGeneration>Default</LinkTimeCodeGeneration> + </Link> + </ItemDefinitionGroup> + <ItemGroup> + <ClCompile Include="ajour.c" /> + <ClCompile Include="bfgsd.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\bjlsqrsolv.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\bjsolv.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\blsqrsolv.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\boptim.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\bsolv.c" /> + <ClCompile Include="calbx.c" /> + <ClCompile Include="calmaj.c" /> + <ClCompile Include="ctcab.c" /> + <ClCompile Include="ctonb.c" /> + <ClCompile Include="dcube.c" /> + <ClCompile Include="ddd2.c" /> + <ClCompile Include="minpack\dogleg.c" /> + <ClCompile Include="minpack\dpmpar.c" /> + <ClCompile Include="minpack\enorm.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\Ex-fsolve.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\Ex-lsqrsolve.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\Ex-optim.c" /> + <ClCompile Include="fajc1.c" /> + <ClCompile Include="fcomp1.c" /> + <ClCompile Include="fcube.c" /> + <ClCompile Include="minpack\fdjac1.c" /> + <ClCompile Include="minpack\fdjac2.c" /> + <ClCompile Include="ffinf1.c" /> + <ClCompile Include="fmani1.c" /> + <ClCompile Include="fmc11a.c" /> + <ClCompile Include="fmc11b.c" /> + <ClCompile Include="fmc11e.c" /> + <ClCompile Include="fmc11z.c" /> + <ClCompile Include="fmlag1.c" /> + <ClCompile Include="fmulb1.c" /> + <ClCompile Include="fmuls1.c" /> + <ClCompile Include="fprf2.c" /> + <ClCompile Include="frdf1.c" /> + <ClCompile Include="fremf2.c" /> + <ClCompile Include="fuclid.c" /> + <ClCompile Include="gcbd.c" /> + <ClCompile Include="gcp.c" /> + <ClCompile Include="minpack\hybrd.c" /> + <ClCompile Include="minpack\hybrd1.c" /> + <ClCompile Include="minpack\hybrj.c" /> + <ClCompile Include="minpack\hybrj1.c" /> + <ClCompile Include="icscof.c" /> + <ClCompile Include="icse.c" /> + <ClCompile Include="icse0.c" /> + <ClCompile Include="icse1.c" /> + <ClCompile Include="icse2.c" /> + <ClCompile Include="icsec2.c" /> + <ClCompile Include="icsei.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\intlsqrsolve.c" /> + <ClCompile Include="intreadmps.c" /> + <ClCompile Include="minpack\lmder.c" /> + <ClCompile Include="minpack\lmdif.c" /> + <ClCompile Include="minpack\lmpar.c" /> + <ClCompile Include="majour.c" /> + <ClCompile Include="majysa.c" /> + <ClCompile Include="majz.c" /> + <ClCompile Include="n1fc1.c" /> + <ClCompile Include="n1fc1a.c" /> + <ClCompile Include="n1fc1o.c" /> + <ClCompile Include="n1gc2.c" /> + <ClCompile Include="n1gc2a.c" /> + <ClCompile Include="n1gc2b.c" /> + <ClCompile Include="n1qn1.c" /> + <ClCompile Include="n1qn1a.c" /> + <ClCompile Include="n1qn2.c" /> + <ClCompile Include="n1qn2a.c" /> + <ClCompile Include="n1qn3.c" /> + <ClCompile Include="n1qn3a.c" /> + <ClCompile Include="nlis0.c" /> + <ClCompile Include="nlis2.c" /> + <ClCompile Include="proj.c" /> + <ClCompile Include="minpack\qform.c" /> + <ClCompile Include="ql0001.c" /> + <ClCompile Include="qnbd.c" /> + <ClCompile Include="qpgen1sci.c" /> + <ClCompile Include="qpgen2.c" /> + <ClCompile Include="minpack\qrfac.c" /> + <ClCompile Include="minpack\qrsolv.c" /> + <ClCompile Include="minpack\r1mpyq.c" /> + <ClCompile Include="minpack\r1updt.c" /> + <ClCompile Include="rdmps1.c" /> + <ClCompile Include="rdmpsz.c" /> + <ClCompile Include="rednor.c" /> + <ClCompile Include="relvar.c" /> + <ClCompile Include="rlbd.c" /> + <ClCompile Include="satur.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_fsolve.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_optim.c" /> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_semidef.c" /> + <ClCompile Include="shanph.c" /> + <ClCompile Include="strang.c" /> + <ClCompile Include="writebuf.c" /> + <ClCompile Include="zgcbd.c" /> + <ClCompile Include="zqnbd.c" /> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="ajour.f" /> + <f2c_rule Include="bfgsd.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\bjlsqrsolv.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\bjsolv.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\blsqrsolv.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\boptim.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\bsolv.f" /> + <f2c_rule Include="calbx.f" /> + <f2c_rule Include="calmaj.f" /> + <f2c_rule Include="ctcab.f" /> + <f2c_rule Include="ctonb.f" /> + <f2c_rule Include="dcube.f" /> + <f2c_rule Include="ddd2.f" /> + <f2c_rule Include="minpack\dogleg.f" /> + <f2c_rule Include="minpack\dpmpar.f" /> + <f2c_rule Include="minpack\enorm.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\Ex-fsolve.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\Ex-lsqrsolve.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\Ex-optim.f" /> + <f2c_rule Include="fajc1.f" /> + <f2c_rule Include="fcomp1.f" /> + <f2c_rule Include="fcube.f" /> + <f2c_rule Include="minpack\fdjac1.f" /> + <f2c_rule Include="minpack\fdjac2.f" /> + <f2c_rule Include="ffinf1.f" /> + <f2c_rule Include="fmani1.f" /> + <f2c_rule Include="fmc11a.f" /> + <f2c_rule Include="fmc11b.f" /> + <f2c_rule Include="fmc11e.f" /> + <f2c_rule Include="fmc11z.f" /> + <f2c_rule Include="fmlag1.f" /> + <f2c_rule Include="fmulb1.f" /> + <f2c_rule Include="fmuls1.f" /> + <f2c_rule Include="fprf2.f" /> + <f2c_rule Include="frdf1.f" /> + <f2c_rule Include="fremf2.f" /> + <f2c_rule Include="fuclid.f" /> + <f2c_rule Include="gcbd.f" /> + <f2c_rule Include="gcp.f" /> + <f2c_rule Include="minpack\hybrd.f" /> + <f2c_rule Include="minpack\hybrd1.f" /> + <f2c_rule Include="minpack\hybrj.f" /> + <f2c_rule Include="minpack\hybrj1.f" /> + <f2c_rule Include="icscof.f" /> + <f2c_rule Include="icse.f" /> + <f2c_rule Include="icse0.f" /> + <f2c_rule Include="icse1.f" /> + <f2c_rule Include="icse2.f" /> + <f2c_rule Include="icsec2.f" /> + <f2c_rule Include="icsei.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\intlsqrsolve.f" /> + <f2c_rule Include="minpack\lmder.f" /> + <f2c_rule Include="minpack\lmdif.f" /> + <f2c_rule Include="minpack\lmpar.f" /> + <f2c_rule Include="majour.f" /> + <f2c_rule Include="majysa.f" /> + <f2c_rule Include="majz.f" /> + <f2c_rule Include="n1fc1.f" /> + <f2c_rule Include="n1fc1a.f" /> + <f2c_rule Include="n1fc1o.f" /> + <f2c_rule Include="n1gc2.f" /> + <f2c_rule Include="n1gc2a.f" /> + <f2c_rule Include="n1gc2b.f" /> + <f2c_rule Include="n1qn1.f" /> + <f2c_rule Include="n1qn1a.f" /> + <f2c_rule Include="n1qn2.f" /> + <f2c_rule Include="n1qn2a.f" /> + <f2c_rule Include="n1qn3.f" /> + <f2c_rule Include="n1qn3a.f" /> + <f2c_rule Include="nlis0.f" /> + <f2c_rule Include="nlis2.f" /> + <f2c_rule Include="proj.f" /> + <f2c_rule Include="minpack\qform.f" /> + <f2c_rule Include="ql0001.f" /> + <f2c_rule Include="qnbd.f" /> + <f2c_rule Include="qpgen1sci.f" /> + <f2c_rule Include="qpgen2.f" /> + <f2c_rule Include="minpack\qrfac.f" /> + <f2c_rule Include="minpack\qrsolv.f" /> + <f2c_rule Include="minpack\r1mpyq.f" /> + <f2c_rule Include="minpack\r1updt.f" /> + <f2c_rule Include="rdmps1.f" /> + <f2c_rule Include="rdmpsz.f" /> + <f2c_rule Include="rednor.f" /> + <f2c_rule Include="relvar.f" /> + <f2c_rule Include="rlbd.f" /> + <f2c_rule Include="satur.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_fsolve.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_optim.f" /> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_semidef.f" /> + <f2c_rule Include="shanph.f" /> + <f2c_rule Include="strang.f" /> + <f2c_rule Include="writebuf.f" /> + <f2c_rule Include="zgcbd.f" /> + <f2c_rule Include="zqnbd.f" /> + <f2c_rule Include="intreadmps.f" /> + </ItemGroup> + <ItemGroup> + <None Include="..\..\Makefile.am" /> + <None Include="..\..\sci_gateway\optimization_gateway.xml" /> + <None Include="Core_f_Import.def" /> + <None Include="Elementary_functions_f_Import.def" /> + <None Include="Elementary_functions_Import.def" /> + <None Include="io_f_Import.def" /> + <None Include="core_import.def" /> + <None Include="linpack_f_Import.def" /> + <None Include="optimization_f.def" /> + <None Include="Optimization_Import.def" /> + <None Include="Output_stream_Import.def" /> + <None Include="String_Import.def" /> + </ItemGroup> + <ItemGroup> + <ProjectReference Include="..\..\..\..\tools\Dumpexts\Dumpexts.vcxproj"> + <Project>{3170e4c2-1173-4264-a222-7ee8ccb3ddf7}</Project> + <ReferenceOutputAssembly>false</ReferenceOutputAssembly> + </ProjectReference> + </ItemGroup> + <Import Project="$(VCTargetsPath)\Microsoft.Cpp.targets" /> + <ImportGroup Label="ExtensionTargets"> + <Import Project="..\..\..\..\Visual-Studio-settings\f2c.targets" /> + </ImportGroup> +</Project>
\ No newline at end of file diff --git a/modules/optimization/src/fortran/optimization_f2c.vcxproj.filters b/modules/optimization/src/fortran/optimization_f2c.vcxproj.filters new file mode 100755 index 000000000..ab6953783 --- /dev/null +++ b/modules/optimization/src/fortran/optimization_f2c.vcxproj.filters @@ -0,0 +1,637 @@ +<?xml version="1.0" encoding="utf-8"?> +<Project ToolsVersion="4.0" xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <ItemGroup> + <Filter Include="Source Files"> + <UniqueIdentifier>{4FC737F1-C7A5-4376-A066-2A32D752A2FF}</UniqueIdentifier> + <Extensions>cpp;c;cc;cxx;def;odl;idl;hpj;bat;asm;asmx</Extensions> + </Filter> + <Filter Include="Header Files"> + <UniqueIdentifier>{93995380-89BD-4b04-88EB-625FBE52EBFB}</UniqueIdentifier> + <Extensions>h;hpp;hxx;hm;inl;inc;xsd</Extensions> + </Filter> + <Filter Include="Resource Files"> + <UniqueIdentifier>{67DA6AB6-F800-4c08-8B7A-83BB121AAD01}</UniqueIdentifier> + <Extensions>rc;ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe;resx;tiff;tif;png;wav</Extensions> + </Filter> + <Filter Include="Fortran files"> + <UniqueIdentifier>{22478cf1-68c4-4544-9d95-e0fff23c39d3}</UniqueIdentifier> + </Filter> + <Filter Include="Libraries Dependencies"> + <UniqueIdentifier>{31c8de6b-cb3e-4f3c-8cfe-b8aa84960901}</UniqueIdentifier> + </Filter> + </ItemGroup> + <ItemGroup> + <ClCompile Include="ajour.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="bfgsd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\bjlsqrsolv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\bjsolv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\blsqrsolv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\boptim.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\bsolv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="calbx.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="calmaj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ctcab.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ctonb.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="dcube.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ddd2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\dogleg.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\dpmpar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\enorm.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\Ex-fsolve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\Ex-lsqrsolve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\Ex-optim.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fajc1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fcomp1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fcube.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\fdjac1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\fdjac2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ffinf1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmani1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmc11a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmc11b.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmc11e.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmc11z.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmlag1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmulb1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fmuls1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fprf2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="frdf1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fremf2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="fuclid.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="gcbd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="gcp.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\hybrd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\hybrd1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\hybrj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\hybrj1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icscof.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icse.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icse0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icse1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icse2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icsec2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="icsei.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\intlsqrsolve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="intreadmps.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\lmder.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\lmdif.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\lmpar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="majour.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="majysa.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="majz.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1fc1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1fc1a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1fc1o.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1gc2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1gc2a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1gc2b.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1qn1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1qn1a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1qn2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1qn2a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1qn3.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="n1qn3a.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="nlis0.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="nlis2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="proj.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\qform.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="ql0001.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qnbd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qpgen1sci.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="qpgen2.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\qrfac.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\qrsolv.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\r1mpyq.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="minpack\r1updt.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rdmps1.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rdmpsz.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rednor.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="relvar.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="rlbd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="satur.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_fsolve.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_optim.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="..\..\sci_gateway\fortran\sci_f_semidef.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="shanph.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="strang.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="writebuf.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zgcbd.c"> + <Filter>Source Files</Filter> + </ClCompile> + <ClCompile Include="zqnbd.c"> + <Filter>Source Files</Filter> + </ClCompile> + </ItemGroup> + <ItemGroup> + <f2c_rule Include="ajour.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="bfgsd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\bjlsqrsolv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\bjsolv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\blsqrsolv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\boptim.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\bsolv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="calbx.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="calmaj.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ctcab.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ctonb.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="dcube.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ddd2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\dogleg.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\dpmpar.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\enorm.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\Ex-fsolve.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\Ex-lsqrsolve.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\Ex-optim.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fajc1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fcomp1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fcube.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\fdjac1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\fdjac2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ffinf1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmani1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmc11a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmc11b.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmc11e.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmc11z.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmlag1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmulb1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fmuls1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fprf2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="frdf1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fremf2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="fuclid.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="gcbd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="gcp.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\hybrd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\hybrd1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\hybrj.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\hybrj1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icscof.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icse.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icse0.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icse1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icse2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icsec2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="icsei.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\intlsqrsolve.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\lmder.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\lmdif.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\lmpar.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="majour.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="majysa.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="majz.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1fc1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1fc1a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1fc1o.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1gc2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1gc2a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1gc2b.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1qn1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1qn1a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1qn2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1qn2a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1qn3.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="n1qn3a.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="nlis0.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="nlis2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="proj.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\qform.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="ql0001.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="qnbd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="qpgen1sci.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="qpgen2.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\qrfac.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\qrsolv.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\r1mpyq.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="minpack\r1updt.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rdmps1.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rdmpsz.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rednor.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="relvar.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="rlbd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="satur.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_fsolve.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_optim.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="..\..\sci_gateway\fortran\sci_f_semidef.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="shanph.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="strang.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="writebuf.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="zgcbd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="zqnbd.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + <f2c_rule Include="intreadmps.f"> + <Filter>Fortran files</Filter> + </f2c_rule> + </ItemGroup> + <ItemGroup> + <None Include="..\..\Makefile.am" /> + <None Include="..\..\sci_gateway\optimization_gateway.xml" /> + <None Include="Elementary_functions_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="io_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="core_import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Optimization_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Output_stream_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="String_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Elementary_functions_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="linpack_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="optimization_f.def"> + <Filter>Libraries Dependencies</Filter> + </None> + <None Include="Core_f_Import.def"> + <Filter>Libraries Dependencies</Filter> + </None> + </ItemGroup> +</Project>
\ No newline at end of file diff --git a/modules/optimization/src/fortran/proj.f b/modules/optimization/src/fortran/proj.f new file mode 100755 index 000000000..b3f360fe8 --- /dev/null +++ b/modules/optimization/src/fortran/proj.f @@ -0,0 +1,16 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine proj(n,binf,bsup,x) + implicit double precision (a-h,o-z) + dimension binf(n),bsup(n),x(n) + do 1 i=1,n +1 x(i)=max(binf(i),min(x(i),bsup(i))) + return + end diff --git a/modules/optimization/src/fortran/proj.lo b/modules/optimization/src/fortran/proj.lo new file mode 100755 index 000000000..e41a9fb15 --- /dev/null +++ b/modules/optimization/src/fortran/proj.lo @@ -0,0 +1,12 @@ +# src/fortran/proj.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/proj.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/ql0001.f b/modules/optimization/src/fortran/ql0001.f new file mode 100755 index 000000000..e1560c6e5 --- /dev/null +++ b/modules/optimization/src/fortran/ql0001.f @@ -0,0 +1,1205 @@ + SUBROUTINE QL0001(M,ME,MMAX,N,NMAX,MNN,C,D,A,B,XL,XU, + 1 X,U,IOUT,IFAIL,IPRINT,WAR,LWAR,IWAR,LIWAR,EPS) +c +cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +c +c !!!! NOTICE !!!! +c +c 1. The routines contained in this file are due to Prof. K.Schittkowski +c of the University of Bayreuth, Germany (modification of routines +c due to Prof. MJD Powell at the University of Cambridge). They can +c be freely distributed. +c +c 2. A minor modification was performed at the University of Maryland. +c It is marked in the code by "c umd". +c +c A.L. Tits and J.L. Zhou +c University of Maryland +C +C*********************************************************************** +C +C +C SOLUTION OF QUADRATIC PROGRAMMING PROBLEMS +C +C +C +C QL0001 SOLVES THE QUADRATIC PROGRAMMING PROBLEM +C +C MINIMIZE .5*X'*C*X + D'*X +C SUBJECT TO A(J)*X + B(J) = 0 , J=1,...,ME +C A(J)*X + B(J) >= 0 , J=ME+1,...,M +C XL <= X <= XU +C +C HERE C MUST BE AN N BY N SYMMETRIC AND POSITIVE MATRIX, D AN N-DIMENSIONAL +C VECTOR, A AN M BY N MATRIX AND B AN M-DIMENSIONAL VECTOR. THE ABOVE +C SITUATION IS INDICATED BY IWAR(1)=1. ALTERNATIVELY, I.E. IF IWAR(1)=0, +C THE OBJECTIVE FUNCTION MATRIX CAN ALSO BE PROVIDED IN FACTORIZED FORM. +C IN THIS CASE, C IS AN UPPER TRIANGULAR MATRIX. +C +C THE SUBROUTINE REORGANIZES SOME DATA SO THAT THE PROBLEM CAN BE SOLVED +C BY A MODIFICATION OF AN ALGORITHM PROPOSED BY POWELL (1983). +C +C +C USAGE: +C +C QL0001(M,ME,MMAX,N,NMAX,MNN,C,D,A,B,XL,XU,X,U,IOUT,IFAIL,IPRINT, +C WAR,LWAR,IWAR,LIWAR,EPS) +C +C +C DEFINITION OF THE PARAMETERS: +C +C M : TOTAL NUMBER OF CONSTRAINTS. +C ME : NUMBER OF EQUALITY CONSTRAINTS. +C MMAX : ROW DIMENSION OF A. MMAX MUST BE AT LEAST ONE AND GREATER +C THAN M. +C N : NUMBER OF VARIABLES. +C NMAX : ROW DIMENSION OF C. NMAX MUST BE GREATER OR EQUAL TO N. +C MNN : MUST BE EQUAL TO M + N + N. +C C(NMAX,NMAX): OBJECTIVE FUNCTION MATRIX WHICH SHOULD BE SYMMETRIC AND +C POSITIVE DEFINITE. IF IWAR(1) = 0, C IS SUPPOSED TO BE THE +C CHOLESKEY-FACTOR OF ANOTHER MATRIX, I.E. C IS UPPER +C TRIANGULAR. +C D(NMAX) : CONTAINS THE CONSTANT VECTOR OF THE OBJECTIVE FUNCTION. +C A(MMAX,NMAX): CONTAINS THE DATA MATRIX OF THE LINEAR CONSTRAINTS. +C B(MMAX) : CONTAINS THE CONSTANT DATA OF THE LINEAR CONSTRAINTS. +C XL(N),XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR THE VARIABLES. +C X(N) : ON RETURN, X CONTAINS THE OPTIMAL SOLUTION VECTOR. +C U(MNN) : ON RETURN, U CONTAINS THE LAGRANGE MULTIPLIERS. THE FIRST +C M POSITIONS ARE RESERVED FOR THE MULTIPLIERS OF THE M +C LINEAR CONSTRAINTS AND THE SUBSEQUENT ONES FOR THE +C MULTIPLIERS OF THE LOWER AND UPPER BOUNDS. ON SUCCESSFUL +C TERMINATION, ALL VALUES OF U WITH RESPECT TO INEQUALITIES +C AND BOUNDS SHOULD BE GREATER OR EQUAL TO ZERO. +C IOUT : INTEGER INDICATING THE DESIRED OUTPUT UNIT NUMBER, I.E. +C ALL WRITE-STATEMENTS START WITH 'WRITE(IOUT,... '. +C IFAIL : SHOWS THE TERMINATION REASON. +C IFAIL = 0 : SUCCESSFUL RETURN. +C IFAIL = 1 : TOO MANY ITERATIONS (MORE THAN 40*(N+M)). +C IFAIL = 2 : ACCURACY INSUFFICIENT TO SATISFY CONVERGENCE +C CRITERION. +C IFAIL = 5 : LENGTH OF A WORKING ARRAY IS TOO SHORT. +C IFAIL > 10 : THE CONSTRAINTS ARE INCONSISTENT. +C IPRINT : OUTPUT CONTROL. +C IPRINT = 0 : NO OUTPUT OF QL0001. +C IPRINT > 0 : BRIEF OUTPUT IN ERROR CASES. +C WAR(LWAR) : REAL WORKING ARRAY. THE LENGTH LWAR SHOULD BE GRATER THAN +C 3*NMAX*NMAX/2 + 10*NMAX + 2*MMAX. +C IWAR(LIWAR): INTEGER WORKING ARRAY. THE LENGTH LIWAR SHOULD BE AT +C LEAST N. +C IF IWAR(1)=1 INITIALLY, THEN THE CHOLESKY DECOMPOSITION +C WHICH IS REQUIRED BY THE DUAL ALGORITHM TO GET THE FIRST +C UNCONSTRAINED MINIMUM OF THE OBJECTIVE FUNCTION, IS +C PERFORMED INTERNALLY. OTHERWISE, I.E. IF IWAR(1)=0, THEN +C IT IS ASSUMED THAT THE USER PROVIDES THE INITIAL FAC- +C TORIZATION BY HIMSELF AND STORES IT IN THE UPPER TRIAN- +C GULAR PART OF THE ARRAY C. +C +C EPS DEFINES A GUESS FOR THE UNDERLYING MACHINE PRECISION. +C +C +C AUTHOR: K. SCHITTKOWSKI, +C MATHEMATISCHES INSTITUT, +C UNIVERSITAET BAYREUTH, +C 8580 BAYREUTH, +C GERMANY, F.R. +C +C +C VERSION: 1.4 (MARCH, 1987) +C +C +C********************************************************************* +C +C + character bufstr*(4096) + INTEGER NMAX,MMAX,N,MNN,LWAR,LIWAR + DIMENSION C(NMAX,NMAX),D(NMAX),A(MMAX,NMAX),B(MMAX), + 1 XL(N),XU(N),X(N),U(MNN),WAR(LWAR),IWAR(LIWAR) + DOUBLE PRECISION C,D,A,B,X,XL,XU,U,WAR,DIAG,ZERO, + 1 EPS,QPEPS,TEN + INTEGER M,ME,IOUT,IFAIL,IPRINT,IWAR,INW1,INW2,IN,J,LW,MN,I, + 1 IDIAG,INFO,NACT,MAXIT + LOGICAL LQL +C +C INTRINSIC FUNCTIONS: DSQRT +C +C +C CONSTANT DATA +C +c################################################################# +c + + if(c(nmax,nmax).eq.0.d0) c(nmax,nmax)=eps +c +c umd +c This prevents a subsequent more major modification of the Hessian +c matrix in the important case when a minmax problem (yielding a +c singular Hessian matrix) is being solved. +c ----UMCP, April 1991, Jian L. Zhou +c################################################################# +c + LQL=.FALSE. + IF (IWAR(1).EQ.1) LQL=.TRUE. + ZERO=0.0D+0 + TEN=1.D+1 + MAXIT=40*(M+N) + QPEPS=EPS + INW1=1 + INW2=INW1+MMAX +C +C PREPARE PROBLEM DATA FOR EXECUTION +C + IF (M.LE.0) GOTO 20 + IN=INW1 + DO 10 J=1,M + WAR(IN)=-B(J) + 10 IN=IN+1 + 20 LW=3*NMAX*NMAX/2 + 10*NMAX + M + IF ((INW2+LW).GT.LWAR) GOTO 80 + IF (LIWAR.LT.N) GOTO 81 + IF (MNN.LT.M+N+N) GOTO 82 + MN=M+N +C +C CALL OF QL0002 +C + CALL QL0002(N,M,ME,MMAX,MN,MNN,NMAX,LQL,A,WAR(INW1), + 1 D,C,XL,XU,X,NACT,IWAR,MAXIT,QPEPS,INFO,DIAG, + 2 WAR(INW2),LW) +C +C TEST OF MATRIX CORRECTIONS +C + IFAIL=0 + IF (INFO.EQ.1) GOTO 40 + IF (INFO.EQ.2) GOTO 90 + IDIAG=0 + IF ((DIAG.GT.ZERO).AND.(DIAG.LT.1000.0)) IDIAG=DIAG + IF ((IPRINT.GT.0).AND.(IDIAG.GT.0)) then + WRITE(bufstr,1000) IDIAG + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + IF (INFO .LT. 0) GOTO 70 +C +C REORDER MULTIPLIER +C + DO 50 J=1,MNN + 50 U(J)=ZERO + IN=INW2-1 + IF (NACT.EQ.0) GOTO 30 + DO 60 I=1,NACT + J=IWAR(I) + U(J)=WAR(IN+I) + 60 CONTINUE + 30 CONTINUE + RETURN +C +C ERROR MESSAGES +C + 70 IFAIL=-INFO+10 + IF ((IPRINT.GT.0).AND.(NACT.GT.0)) then + WRITE(bufstr,1100) -INFO,(IWAR(I),I=1,NACT) + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + RETURN + 80 IFAIL=5 + IF (IPRINT .GT. 0) then + WRITE(bufstr,1200) + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + RETURN + 81 IFAIL=5 + IF (IPRINT .GT. 0) then + WRITE(bufstr,1210) + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + RETURN + 82 IFAIL=5 + IF (IPRINT .GT. 0) then + WRITE(bufstr,1220) + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + RETURN + 40 IFAIL=1 + IF (IPRINT.GT.0) then + WRITE(bufstr,1300) MAXIT + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + RETURN + 90 IFAIL=2 + IF (IPRINT.GT.0) then + WRITE(bufstr,1400) + call basout(io_out ,IOUT ,bufstr(1:lnblnk(bufstr))) + endif + RETURN +C +C FORMAT-INSTRUCTIONS +C + 1000 FORMAT(8X,28H***QL: MATRIX G WAS ENLARGED,I3, + 1 20H-TIMES BY UNITMATRIX) + 1100 FORMAT(8X,18H***QL: CONSTRAINT ,I5, + 1 19H NOT CONSISTENT TO ,(10X,10I5)) + 1200 FORMAT(8X,21H***QL: LWAR TOO SMALL) + 1210 FORMAT(8X,22H***QL: LIWAR TOO SMALL) + 1220 FORMAT(8X,20H***QL: MNN TOO SMALL) + 1300 FORMAT(8X,37H***QL: TOO MANY ITERATIONS (MORE THAN,I6,1H)) + 1400 FORMAT(8X,50H***QL: ACCURACY INSUFFICIENT TO ATTAIN CONVERGENCE) + END +C + SUBROUTINE QL0002(N,M,MEQ,MMAX,MN,MNN,NMAX,LQL,A,B,GRAD,G, + 1 XL,XU,X,NACT,IACT,MAXIT,VSMALL,INFO,DIAG,W,LW) +C +C************************************************************************** +C +C +C THIS SUBROUTINE SOLVES THE QUADRATIC PROGRAMMING PROBLEM +C +C MINIMIZE GRAD'*X + 0.5 * X*G*X +C SUBJECT TO A(K)*X = B(K) K=1,2,...,MEQ, +C A(K)*X >= B(K) K=MEQ+1,...,M, +C XL <= X <= XU +C +C THE QUADRATIC PROGRAMMING METHOD PROCEEDS FROM AN INITIAL CHOLESKY- +C DECOMPOSITION OF THE OBJECTIVE FUNCTION MATRIX, TO CALCULATE THE +C UNIQUELY DETERMINED MINIMIZER OF THE UNCONSTRAINED PROBLEM. +C SUCCESSIVELY ALL VIOLATED CONSTRAINTS ARE ADDED TO A WORKING SET +C AND A MINIMIZER OF THE OBJECTIVE FUNCTION SUBJECT TO ALL CONSTRAINTS +C IN THIS WORKING SET IS COMPUTED. IT IS POSSIBLE THAT CONSTRAINTS +C HAVE TO LEAVE THE WORKING SET. +C +C +C DESCRIPTION OF PARAMETERS: +C +C N : IS THE NUMBER OF VARIABLES. +C M : TOTAL NUMBER OF CONSTRAINTS. +C MEQ : NUMBER OF EQUALITY CONTRAINTS. +C MMAX : ROW DIMENSION OF A, DIMENSION OF B. MMAX MUST BE AT +C LEAST ONE AND GREATER OR EQUAL TO M. +C MN : MUST BE EQUAL M + N. +C MNN : MUST BE EQUAL M + N + N. +C NMAX : ROW DIEMSION OF G. MUST BE AT LEAST N. +C LQL : DETERMINES INITIAL DECOMPOSITION. +C LQL = .FALSE. : THE UPPER TRIANGULAR PART OF THE MATRIX G +C CONTAINS INITIALLY THE CHOLESKY-FACTOR OF A SUITABLE +C DECOMPOSITION. +C LQL = .TRUE. : THE INITIAL CHOLESKY-FACTORISATION OF G IS TO BE +C PERFORMED BY THE ALGORITHM. +C A(MMAX,NMAX) : A IS A MATRIX WHOSE COLUMNS ARE THE CONSTRAINTS NORMALS. +C B(MMAX) : CONTAINS THE RIGHT HAND SIDES OF THE CONSTRAINTS. +C GRAD(N) : CONTAINS THE OBJECTIVE FUNCTION VECTOR GRAD. +C G(NMAX,N): CONTAINS THE SYMMETRIC OBJECTIVE FUNCTION MATRIX. +C XL(N), XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR X. +C X(N) : VECTOR OF VARIABLES. +C NACT : FINAL NUMBER OF ACTIVE CONSTRAINTS. +C IACT(K) (K=1,2,...,NACT): INDICES OF THE FINAL ACTIVE CONSTRAINTS. +C INFO : REASON FOR THE RETURN FROM THE SUBROUTINE. +C INFO = 0 : CALCULATION WAS TERMINATED SUCCESSFULLY. +C INFO = 1 : MAXIMUM NUMBER OF ITERATIONS ATTAINED. +C INFO = 2 : ACCURACY IS INSUFFICIENT TO MAINTAIN INCREASING +C FUNCTION VALUES. +C INFO < 0 : THE CONSTRAINT WITH INDEX ABS(INFO) AND THE CON- +C STRAINTS WHOSE INDICES ARE IACT(K), K=1,2,...,NACT, +C ARE INCONSISTENT. +C MAXIT : MAXIMUM NUMBER OF ITERATIONS. +C VSMALL : REQUIRED ACCURACY TO BE ACHIEVED (E.G. IN THE ORDER OF THE +C MACHINE PRECISION FOR SMALL AND WELL-CONDITIONED PROBLEMS). +C DIAG : ON RETURN DIAG IS EQUAL TO THE MULTIPLE OF THE UNIT MATRIX +C THAT WAS ADDED TO G TO ACHIEVE POSITIVE DEFINITENESS. +C W(LW) : THE ELEMENTS OF W(.) ARE USED FOR WORKING SPACE. THE LENGTH +C OF W MUST NOT BE LESS THAN (1.5*NMAX*NMAX + 10*NMAX + M). +C WHEN INFO = 0 ON RETURN, THE LAGRANGE MULTIPLIERS OF THE +C FINAL ACTIVE CONSTRAINTS ARE HELD IN W(K), K=1,2,...,NACT. +C THE VALUES OF N, M, MEQ, MMAX, MN, MNN AND NMAX AND THE ELEMENTS OF +C A, B, GRAD AND G ARE NOT ALTERED. +C +C THE FOLLOWING INTEGERS ARE USED TO PARTITION W: +C THE FIRST N ELEMENTS OF W HOLD LAGRANGE MULTIPLIER ESTIMATES. +C W(IWZ+I+(N-1)*J) HOLDS THE MATRIX ELEMENT Z(I,J). +C W(IWR+I+0.5*J*(J-1)) HOLDS THE UPPER TRIANGULAR MATRIX +C ELEMENT R(I,J). THE SUBSEQUENT N COMPONENTS OF W MAY BE +C TREATED AS AN EXTRA COLUMN OF R(.,.). +C W(IWW-N+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE. +C W(IWW+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE. +C W(IWD+I) (I=1,2,...,N) HOLDS G(I,I) DURING THE CALCULATION. +C W(IWX+I) (I=1,2,...,N) HOLDS VARIABLES THAT WILL BE USED TO +C TEST THAT THE ITERATIONS INCREASE THE OBJECTIVE FUNCTION. +C W(IWA+K) (K=1,2,...,M) USUALLY HOLDS THE RECIPROCAL OF THE +C LENGTH OF THE K-TH CONSTRAINT, BUT ITS SIGN INDICATES +C WHETHER THE CONSTRAINT IS ACTIVE. +C +C +C AUTHOR: K. SCHITTKOWSKI, +C MATHEMATISCHES INSTITUT, +C UNIVERSITAET BAYREUTH, +C 8580 BAYREUTH, +C GERMANY, F.R. +C +C AUTHOR OF ORIGINAL VERSION: +C M.J.D. POWELL, DAMTP, +C UNIVERSITY OF CAMBRIDGE, SILVER STREET +C CAMBRIDGE, +C ENGLAND +C +C +C REFERENCE: M.J.D. POWELL: ZQPCVX, A FORTRAN SUBROUTINE FOR CONVEX +C PROGRAMMING, REPORT DAMTP/1983/NA17, UNIVERSITY OF +C CAMBRIDGE, ENGLAND, 1983. +C +C +C VERSION : 2.0 (MARCH, 1987) +C +C +C************************************************************************* +C + INTEGER MMAX,NMAX,N,LW + DIMENSION A(MMAX,NMAX),B(MMAX),GRAD(N),G(NMAX,N),X(N),IACT(N), + 1 W(LW),XL(N),XU(N) + INTEGER M,MEQ,MN,MNN,NACT,IACT,INFO,MAXIT + DOUBLE PRECISION CVMAX,DIAG,DIAGR,FDIFF,FDIFFA,GA,GB,PARINC,PARNEW + 1 ,RATIO,RES,STEP,SUM,SUMX,SUMY,SUMA,SUMB,SUMC,TEMP,TEMPA, + 2 VSMALL,XMAG,XMAGR,ZERO,ONE,TWO,ONHA,VFACT + DOUBLE PRECISION A,B,G,GRAD,W,X,XL,XU +C +C INTRINSIC FUNCTIONS: DMAX1,DSQRT,DABS,DMIN1 +C + INTEGER IWZ,IWR,IWW,IWD,IWA,IFINC,KFINC,K,I,IA,ID,II,IR,IRA, + 1 IRB,J,NM,IZ,IZA,ITERC,ITREF,JFINC,IFLAG,IWS,IS,K1,IW,KK,IP, + 2 IPP,IL,IU,JU,KFLAG,LFLAG,JFLAG,KDROP,NU,MFLAG,KNEXT,IX,IWX, + 3 IWY,IY,JL + INTEGER NFLAG,IWWN + LOGICAL LQL,LOWER +C +C INITIAL ADDRESSES +C + IWZ=NMAX + IWR=IWZ+NMAX*NMAX + IWW=IWR+(NMAX*(NMAX+3))/2 + IWD=IWW+NMAX + IWX=IWD+NMAX + IWA=IWX+NMAX +C +C SET SOME CONSTANTS. +C + ZERO=0.D+0 + ONE=1.D+0 + TWO=2.D+0 + ONHA=1.5D+0 + VFACT=1.D+0 +C +C SET SOME PARAMETERS. +C NUMBER LESS THAN VSMALL ARE ASSUMED TO BE NEGLIGIBLE. +C THE MULTIPLE OF I THAT IS ADDED TO G IS AT MOST DIAGR TIMES +C THE LEAST MULTIPLE OF I THAT GIVES POSITIVE DEFINITENESS. +C X IS RE-INITIALISED IF ITS MAGNITUDE IS REDUCED BY THE +C FACTOR XMAGR. +C A CHECK IS MADE FOR AN INCREASE IN F EVERY IFINC ITERATIONS, +C AFTER KFINC ITERATIONS ARE COMPLETED. +C + DIAGR=TWO + XMAGR=1.0D-2 + IFINC=3 + KFINC=MAX0(10,N) +C +C FIND THE RECIPROCALS OF THE LENGTHS OF THE CONSTRAINT NORMALS. +C RETURN IF A CONSTRAINT IS INFEASIBLE DUE TO A ZERO NORMAL. +C + NACT=0 + IF (M .LE. 0) GOTO 45 + DO 40 K=1,M + SUM=ZERO + DO 10 I=1,N + 10 SUM=SUM+A(K,I)**2 + IF (SUM .GT. ZERO) GOTO 20 + IF (B(K) .EQ. ZERO) GOTO 30 + INFO=-K + IF (K .LE. MEQ) GOTO 730 + if (B(K) .le. 0) then + goto 30 + else + goto 730 + endif + 20 SUM=ONE/DSQRT(SUM) + 30 IA=IWA+K + 40 W(IA)=SUM + 45 DO 50 K=1,N + IA=IWA+M+K + 50 W(IA)=ONE +C +C IF NECESSARY INCREASE THE DIAGONAL ELEMENTS OF G. +C + IF (.NOT. LQL) GOTO 165 + DIAG=ZERO + DO 60 I=1,N + ID=IWD+I + W(ID)=G(I,I) + DIAG=DMAX1(DIAG,VSMALL-W(ID)) + IF (I .EQ. N) GOTO 60 + II=I+1 + DO 55 J=II,N + GA=-DMIN1(W(ID),G(J,J)) + GB=DABS(W(ID)-G(J,J))+DABS(G(I,J)) + IF (GB .GT. ZERO) GA=GA+G(I,J)**2/GB + 55 DIAG=DMAX1(DIAG,GA) + 60 CONTINUE + IF (DIAG .LE. ZERO) GOTO 90 + 70 DIAG=DIAGR*DIAG + DO 80 I=1,N + ID=IWD+I + 80 G(I,I)=DIAG+W(ID) +C +C FORM THE CHOLESKY FACTORISATION OF G. THE TRANSPOSE +C OF THE FACTOR WILL BE PLACED IN THE R-PARTITION OF W. +C + 90 IR=IWR + DO 130 J=1,N + IRA=IWR + IRB=IR+1 + DO 120 I=1,J + TEMP=G(I,J) + IF (I .EQ. 1) GOTO 110 + DO 100 K=IRB,IR + IRA=IRA+1 + 100 TEMP=TEMP-W(K)*W(IRA) + 110 IR=IR+1 + IRA=IRA+1 + IF (I .LT. J) W(IR)=TEMP/W(IRA) + 120 CONTINUE + IF (TEMP .LT. VSMALL) GOTO 140 + 130 W(IR)=DSQRT(TEMP) + GOTO 170 +C +C INCREASE FURTHER THE DIAGONAL ELEMENT OF G. +C + 140 W(J)=ONE + SUMX=ONE + K=J + 150 SUM=ZERO + IRA=IR-1 + DO 160 I=K,J + SUM=SUM-W(IRA)*W(I) + 160 IRA=IRA+I + IR=IR-K + K=K-1 + W(K)=SUM/W(IR) + SUMX=SUMX+W(K)**2 + IF (K .GE. 2) GOTO 150 + DIAG=DIAG+VSMALL-TEMP/SUMX + GOTO 70 +C +C STORE THE CHOLESKY FACTORISATION IN THE R-PARTITION +C OF W. +C + 165 IR=IWR + DO 166 I=1,N + DO 166 J=1,I + IR=IR+1 + 166 W(IR)=G(J,I) +C +C SET Z THE INVERSE OF THE MATRIX IN R. +C + 170 NM=N-1 + DO 220 I=1,N + IZ=IWZ+I + IF (I .EQ. 1) GOTO 190 + DO 180 J=2,I + W(IZ)=ZERO + 180 IZ=IZ+N + 190 IR=IWR+(I+I*I)/2 + W(IZ)=ONE/W(IR) + IF (I .EQ. N) GOTO 220 + IZA=IZ + DO 210 J=I,NM + IR=IR+I + SUM=ZERO + DO 200 K=IZA,IZ,N + SUM=SUM+W(K)*W(IR) + 200 IR=IR+1 + IZ=IZ+N + 210 W(IZ)=-SUM/W(IR) + 220 CONTINUE +C +C SET THE INITIAL VALUES OF SOME VARIABLES. +C ITERC COUNTS THE NUMBER OF ITERATIONS. +C ITREF IS SET TO ONE WHEN ITERATIVE REFINEMENT IS REQUIRED. +C JFINC INDICATES WHEN TO TEST FOR AN INCREASE IN F. +C + ITERC=1 + ITREF=0 + JFINC=-KFINC +C +C SET X TO ZERO AND SET THE CORRESPONDING RESIDUALS OF THE +C KUHN-TUCKER CONDITIONS. +C + 230 IFLAG=1 + IWS=IWW-N + DO 240 I=1,N + X(I)=ZERO + IW=IWW+I + W(IW)=GRAD(I) + IF (I .GT. NACT) GOTO 240 + W(I)=ZERO + IS=IWS+I + K=IACT(I) + IF (K .LE. M) GOTO 235 + IF (K .GT. MN) GOTO 234 + K1=K-M + W(IS)=XL(K1) + GOTO 240 + 234 K1=K-MN + W(IS)=-XU(K1) + GOTO 240 + 235 W(IS)=B(K) + 240 CONTINUE + XMAG=ZERO + VFACT=1.D+0 + if (NACT .le. 0) then + goto 340 + else + goto 280 + endif + +C +C SET THE RESIDUALS OF THE KUHN-TUCKER CONDITIONS FOR GENERAL X. +C + 250 IFLAG=2 + IWS=IWW-N + DO 260 I=1,N + IW=IWW+I + W(IW)=GRAD(I) + IF (LQL) GOTO 259 + ID=IWD+I + W(ID)=ZERO + DO 251 J=I,N + 251 W(ID)=W(ID)+G(I,J)*X(J) + DO 252 J=1,I + ID=IWD+J + 252 W(IW)=W(IW)+G(J,I)*W(ID) + GOTO 260 + 259 DO 261 J=1,N + 261 W(IW)=W(IW)+G(I,J)*X(J) + 260 CONTINUE + IF (NACT .EQ. 0) GOTO 340 + DO 270 K=1,NACT + KK=IACT(K) + IS=IWS+K + IF (KK .GT. M) GOTO 265 + W(IS)=B(KK) + DO 264 I=1,N + IW=IWW+I + W(IW)=W(IW)-W(K)*A(KK,I) + 264 W(IS)=W(IS)-X(I)*A(KK,I) + GOTO 270 + 265 IF (KK .GT. MN) GOTO 266 + K1=KK-M + IW=IWW+K1 + W(IW)=W(IW)-W(K) + W(IS)=XL(K1)-X(K1) + GOTO 270 + 266 K1=KK-MN + IW=IWW+K1 + W(IW)=W(IW)+W(K) + W(IS)=-XU(K1)+X(K1) + 270 CONTINUE +C +C PRE-MULTIPLY THE VECTOR IN THE S-PARTITION OF W BY THE +C INVERS OF R TRANSPOSE. +C + 280 IR=IWR + IP=IWW+1 + IPP=IWW+N + IL=IWS+1 + IU=IWS+NACT + DO 310 I=IL,IU + SUM=ZERO + IF (I .EQ. IL) GOTO 300 + JU=I-1 + DO 290 J=IL,JU + IR=IR+1 + 290 SUM=SUM+W(IR)*W(J) + 300 IR=IR+1 + 310 W(I)=(W(I)-SUM)/W(IR) +C +C SHIFT X TO SATISFY THE ACTIVE CONSTRAINTS AND MAKE THE +C CORRESPONDING CHANGE TO THE GRADIENT RESIDUALS. +C + DO 330 I=1,N + IZ=IWZ+I + SUM=ZERO + DO 320 J=IL,IU + SUM=SUM+W(J)*W(IZ) + 320 IZ=IZ+N + X(I)=X(I)+SUM + IF (LQL) GOTO 329 + ID=IWD+I + W(ID)=ZERO + DO 321 J=I,N + 321 W(ID)=W(ID)+G(I,J)*SUM + IW=IWW+I + DO 322 J=1,I + ID=IWD+J + 322 W(IW)=W(IW)+G(J,I)*W(ID) + GOTO 330 + 329 DO 331 J=1,N + IW=IWW+J + 331 W(IW)=W(IW)+SUM*G(I,J) + 330 CONTINUE +C +C FORM THE SCALAR PRODUCT OF THE CURRENT GRADIENT RESIDUALS +C WITH EACH COLUMN OF Z. +C + 340 KFLAG=1 + GOTO 930 + 350 IF (NACT .EQ. N) GOTO 380 +C +C SHIFT X SO THAT IT SATISFIES THE REMAINING KUHN-TUCKER +C CONDITIONS. +C + IL=IWS+NACT+1 + IZA=IWZ+NACT*N + DO 370 I=1,N + SUM=ZERO + IZ=IZA+I + DO 360 J=IL,IWW + SUM=SUM+W(IZ)*W(J) + 360 IZ=IZ+N + 370 X(I)=X(I)-SUM + INFO=0 + IF (NACT .EQ. 0) GOTO 410 +C +C UPDATE THE LAGRANGE MULTIPLIERS. +C + 380 LFLAG=3 + GOTO 740 + 390 DO 400 K=1,NACT + IW=IWW+K + 400 W(K)=W(K)+W(IW) +C +C REVISE THE VALUES OF XMAG. +C BRANCH IF ITERATIVE REFINEMENT IS REQUIRED. +C + 410 JFLAG=1 + GOTO 910 + 420 IF (IFLAG .EQ. ITREF) GOTO 250 +C +C DELETE A CONSTRAINT IF A LAGRANGE MULTIPLIER OF AN +C INEQUALITY CONSTRAINT IS NEGATIVE. +C + KDROP=0 + GOTO 440 + 430 KDROP=KDROP+1 + IF (W(KDROP) .GE. ZERO) GOTO 440 + IF (IACT(KDROP) .LE. MEQ) GOTO 440 + NU=NACT + MFLAG=1 + GOTO 800 + 440 IF (KDROP .LT. NACT) GOTO 430 +C +C SEEK THE GREATEAST NORMALISED CONSTRAINT VIOLATION, DISREGARDING +C ANY THAT MAY BE DUE TO COMPUTER ROUNDING ERRORS. +C + 450 CVMAX=ZERO + IF (M .LE. 0) GOTO 481 + DO 480 K=1,M + IA=IWA+K + IF (W(IA) .LE. ZERO) GOTO 480 + SUM=-B(K) + DO 460 I=1,N + 460 SUM=SUM+X(I)*A(K,I) + SUMX=-SUM*W(IA) + IF (K .LE. MEQ) SUMX=DABS(SUMX) + IF (SUMX .LE. CVMAX) GOTO 480 + TEMP=DABS(B(K)) + DO 470 I=1,N + 470 TEMP=TEMP+DABS(X(I)*A(K,I)) + TEMPA=TEMP+DABS(SUM) + IF (TEMPA .LE. TEMP) GOTO 480 + TEMP=TEMP+ONHA*DABS(SUM) + IF (TEMP .LE. TEMPA) GOTO 480 + CVMAX=SUMX + RES=SUM + KNEXT=K + 480 CONTINUE + 481 DO 485 K=1,N + LOWER=.TRUE. + IA=IWA+M+K + IF (W(IA) .LE. ZERO) GOTO 485 + SUM=XL(K)-X(K) + if (SUM .lt. 0) then + goto 482 + elseif (SUM .eq. 0) then + goto 485 + else + goto 483 + endif + 482 SUM=X(K)-XU(K) + LOWER=.FALSE. + 483 IF (SUM .LE. CVMAX) GOTO 485 + CVMAX=SUM + RES=-SUM + KNEXT=K+M + IF (LOWER) GOTO 485 + KNEXT=K+MN + 485 CONTINUE +C +C TEST FOR CONVERGENCE +C + INFO=0 + IF (CVMAX.ne.CVMAX.OR.CVMAX .LE. VSMALL) GOTO 700 +C +C RETURN IF, DUE TO ROUNDING ERRORS, THE ACTUAL CHANGE IN +C X MAY NOT INCREASE THE OBJECTIVE FUNCTION +C + JFINC=JFINC+1 + IF (JFINC .EQ. 0) GOTO 510 + IF (JFINC .NE. IFINC) GOTO 530 + FDIFF=ZERO + FDIFFA=ZERO + DO 500 I=1,N + SUM=TWO*GRAD(I) + SUMX=DABS(SUM) + IF (LQL) GOTO 489 + ID=IWD+I + W(ID)=ZERO + DO 486 J=I,N + IX=IWX+J + 486 W(ID)=W(ID)+G(I,J)*(W(IX)+X(J)) + DO 487 J=1,I + ID=IWD+J + TEMP=G(J,I)*W(ID) + SUM=SUM+TEMP + 487 SUMX=SUMX+DABS(TEMP) + GOTO 495 + 489 DO 490 J=1,N + IX=IWX+J + TEMP=G(I,J)*(W(IX)+X(J)) + SUM=SUM+TEMP + 490 SUMX=SUMX+DABS(TEMP) + 495 IX=IWX+I + FDIFF=FDIFF+SUM*(X(I)-W(IX)) + 500 FDIFFA=FDIFFA+SUMX*DABS(X(I)-W(IX)) + INFO=2 + SUM=FDIFFA+FDIFF + IF (SUM .LE. FDIFFA) GOTO 700 + TEMP=FDIFFA+ONHA*FDIFF + IF (TEMP .LE. SUM) GOTO 700 + JFINC=0 + INFO=0 + 510 DO 520 I=1,N + IX=IWX+I + 520 W(IX)=X(I) +C +C FORM THE SCALAR PRODUCT OF THE NEW CONSTRAINT NORMAL WITH EACH +C COLUMN OF Z. PARNEW WILL BECOME THE LAGRANGE MULTIPLIER OF +C THE NEW CONSTRAINT. +C + 530 ITERC=ITERC+1 + IF (ITERC.LE.MAXIT) GOTO 531 + INFO=1 + GOTO 710 + 531 CONTINUE + IWS=IWR+(NACT+NACT*NACT)/2 + IF (KNEXT .GT. M) GOTO 541 + DO 540 I=1,N + IW=IWW+I + 540 W(IW)=A(KNEXT,I) + GOTO 549 + 541 DO 542 I=1,N + IW=IWW+I + 542 W(IW)=ZERO + K1=KNEXT-M + IF (K1 .GT. N) GOTO 545 + IW=IWW+K1 + W(IW)=ONE + IZ=IWZ+K1 + DO 543 I=1,N + IS=IWS+I + W(IS)=W(IZ) + 543 IZ=IZ+N + GOTO 550 + 545 K1=KNEXT-MN + IW=IWW+K1 + W(IW)=-ONE + IZ=IWZ+K1 + DO 546 I=1,N + IS=IWS+I + W(IS)=-W(IZ) + 546 IZ=IZ+N + GOTO 550 + 549 KFLAG=2 + GOTO 930 + 550 PARNEW=ZERO +C +C APPLY GIVENS ROTATIONS TO MAKE THE LAST (N-NACT-2) SCALAR +C PRODUCTS EQUAL TO ZERO. +C + IF (NACT .EQ. N) GOTO 570 + NU=N + NFLAG=1 + GOTO 860 +C +C BRANCH IF THERE IS NO NEED TO DELETE A CONSTRAINT. +C + 560 IS=IWS+NACT + IF (NACT .EQ. 0) GOTO 640 + SUMA=ZERO + SUMB=ZERO + SUMC=ZERO + IZ=IWZ+NACT*N + DO 563 I=1,N + IZ=IZ+1 + IW=IWW+I + SUMA=SUMA+W(IW)*W(IZ) + SUMB=SUMB+DABS(W(IW)*W(IZ)) + 563 SUMC=SUMC+W(IZ)**2 + TEMP=SUMB+.1D+0*DABS(SUMA) + TEMPA=SUMB+.2D+0*DABS(SUMA) + IF (TEMP .LE. SUMB) GOTO 570 + IF (TEMPA .LE. TEMP) GOTO 570 + IF (SUMB .GT. VSMALL) GOTO 5 + GOTO 570 + 5 SUMC=DSQRT(SUMC) + IA=IWA+KNEXT + IF (KNEXT .LE. M) SUMC=SUMC/W(IA) + TEMP=SUMC+.1D+0*DABS(SUMA) + TEMPA=SUMC+.2D+0*DABS(SUMA) + IF (TEMP .LE. SUMC) GOTO 567 + IF (TEMPA .LE. TEMP) GOTO 567 + GOTO 640 +C +C CALCULATE THE MULTIPLIERS FOR THE NEW CONSTRAINT NORMAL +C EXPRESSED IN TERMS OF THE ACTIVE CONSTRAINT NORMALS. +C THEN WORK OUT WHICH CONTRAINT TO DROP. +C + 567 LFLAG=4 + GOTO 740 + 570 LFLAG=1 + GOTO 740 +C +C COMPLETE THE TEST FOR LINEARLY DEPENDENT CONSTRAINTS. +C + 571 IF (KNEXT .GT. M) GOTO 574 + DO 573 I=1,N + SUMA=A(KNEXT,I) + SUMB=DABS(SUMA) + IF (NACT.EQ.0) GOTO 581 + DO 572 K=1,NACT + KK=IACT(K) + IF (KK.LE.M) GOTO 568 + KK=KK-M + TEMP=ZERO + IF (KK.EQ.I) TEMP=W(IWW+KK) + KK=KK-N + IF (KK.EQ.I) TEMP=-W(IWW+KK) + GOTO 569 + 568 CONTINUE + IW=IWW+K + TEMP=W(IW)*A(KK,I) + 569 CONTINUE + SUMA=SUMA-TEMP + 572 SUMB=SUMB+DABS(TEMP) + 581 IF (SUMA .LE. VSMALL) GOTO 573 + TEMP=SUMB+.1D+0*DABS(SUMA) + TEMPA=SUMB+.2D+0*DABS(SUMA) + IF (TEMP .LE. SUMB) GOTO 573 + IF (TEMPA .LE. TEMP) GOTO 573 + GOTO 630 + 573 CONTINUE + LFLAG=1 + GOTO 775 + 574 K1=KNEXT-M + IF (K1 .GT. N) K1=K1-N + DO 578 I=1,N + SUMA=ZERO + IF (I .NE. K1) GOTO 575 + SUMA=ONE + IF (KNEXT .GT. MN) SUMA=-ONE + 575 SUMB=DABS(SUMA) + IF (NACT.EQ.0) GOTO 582 + DO 577 K=1,NACT + KK=IACT(K) + IF (KK .LE. M) GOTO 579 + KK=KK-M + TEMP=ZERO + IF (KK.EQ.I) TEMP=W(IWW+KK) + KK=KK-N + IF (KK.EQ.I) TEMP=-W(IWW+KK) + GOTO 576 + 579 IW=IWW+K + TEMP=W(IW)*A(KK,I) + 576 SUMA=SUMA-TEMP + 577 SUMB=SUMB+DABS(TEMP) + 582 TEMP=SUMB+.1D+0*DABS(SUMA) + TEMPA=SUMB+.2D+0*DABS(SUMA) + IF (TEMP .LE. SUMB) GOTO 578 + IF (TEMPA .LE. TEMP) GOTO 578 + GOTO 630 + 578 CONTINUE + LFLAG=1 + GOTO 775 +C +C BRANCH IF THE CONTRAINTS ARE INCONSISTENT. +C + 580 INFO=-KNEXT + IF (KDROP .EQ. 0) GOTO 700 + PARINC=RATIO + PARNEW=PARINC +C +C REVISE THE LAGRANGE MULTIPLIERS OF THE ACTIVE CONSTRAINTS. +C + 590 IF (NACT.EQ.0) GOTO 601 + DO 600 K=1,NACT + IW=IWW+K + W(K)=W(K)-PARINC*W(IW) + IF (IACT(K) .GT. MEQ) W(K)=DMAX1(ZERO,W(K)) + 600 CONTINUE + 601 IF (KDROP .EQ. 0) GOTO 680 +C +C DELETE THE CONSTRAINT TO BE DROPPED. +C SHIFT THE VECTOR OF SCALAR PRODUCTS. +C THEN, IF APPROPRIATE, MAKE ONE MORE SCALAR PRODUCT ZERO. +C + NU=NACT+1 + MFLAG=2 + GOTO 800 + 610 IWS=IWS-NACT-1 + NU=MIN0(N,NU) + DO 620 I=1,NU + IS=IWS+I + J=IS+NACT + 620 W(IS)=W(J+1) + NFLAG=2 + GOTO 860 +C +C CALCULATE THE STEP TO THE VIOLATED CONSTRAINT. +C + 630 IS=IWS+NACT + 640 SUMY=W(IS+1) + STEP=-RES/SUMY + PARINC=STEP/SUMY + IF (NACT .EQ. 0) GOTO 660 +C +C CALCULATE THE CHANGES TO THE LAGRANGE MULTIPLIERS, AND REDUCE +C THE STEP ALONG THE NEW SEARCH DIRECTION IF NECESSARY. +C + LFLAG=2 + GOTO 740 + 650 IF (KDROP .EQ. 0) GOTO 660 + TEMP=ONE-RATIO/PARINC + IF (TEMP .LE. ZERO) KDROP=0 + IF (KDROP .EQ. 0) GOTO 660 + STEP=RATIO*SUMY + PARINC=RATIO + RES=TEMP*RES +C +C UPDATE X AND THE LAGRANGE MULTIPIERS. +C DROP A CONSTRAINT IF THE FULL STEP IS NOT TAKEN. +C + 660 IWY=IWZ+NACT*N + DO 670 I=1,N + IY=IWY+I + 670 X(I)=X(I)+STEP*W(IY) + PARNEW=PARNEW+PARINC + IF (NACT .GE. 1) GOTO 590 +C +C ADD THE NEW CONSTRAINT TO THE ACTIVE SET. +C + 680 NACT=NACT+1 + W(NACT)=PARNEW + IACT(NACT)=KNEXT + IA=IWA+KNEXT + IF (KNEXT .GT. MN) IA=IA-N + W(IA)=-W(IA) +C +C ESTIMATE THE MAGNITUDE OF X. THEN BEGIN A NEW ITERATION, +C RE-INITILISING X IF THIS MAGNITUDE IS SMALL. +C + JFLAG=2 + GOTO 910 + 690 IF (SUM .LT. (XMAGR*XMAG)) GOTO 230 + if (ITREF .le. 0) then + goto 450 + else + goto 250 + endif +C +C INITIATE ITERATIVE REFINEMENT IF IT HAS NOT YET BEEN USED, +C OR RETURN AFTER RESTORING THE DIAGONAL ELEMENTS OF G. +C + 700 IF (ITERC .EQ. 0) GOTO 710 + ITREF=ITREF+1 + JFINC=-1 + IF (ITREF .EQ. 1) GOTO 250 + 710 IF (.NOT. LQL) RETURN + DO 720 I=1,N + ID=IWD+I + 720 G(I,I)=W(ID) + 730 RETURN +C +C +C THE REMAINIG INSTRUCTIONS ARE USED AS SUBROUTINES. +C +C +C******************************************************************** +C +C +C CALCULATE THE LAGRANGE MULTIPLIERS BY PRE-MULTIPLYING THE +C VECTOR IN THE S-PARTITION OF W BY THE INVERSE OF R. +C + 740 IR=IWR+(NACT+NACT*NACT)/2 + I=NACT + SUM=ZERO + GOTO 770 + 750 IRA=IR-1 + SUM=ZERO + IF (NACT.EQ.0) GOTO 761 + DO 760 J=I,NACT + IW=IWW+J + SUM=SUM+W(IRA)*W(IW) + 760 IRA=IRA+J + 761 IR=IR-I + I=I-1 + 770 IW=IWW+I + IS=IWS+I + W(IW)=(W(IS)-SUM)/W(IR) + IF (I .GT. 1) GOTO 750 + IF (LFLAG .EQ. 3) GOTO 390 + IF (LFLAG .EQ. 4) GOTO 571 +C +C CALCULATE THE NEXT CONSTRAINT TO DROP. +C + 775 IP=IWW+1 + IPP=IWW+NACT + KDROP=0 + IF (NACT.EQ.0) GOTO 791 + DO 790 K=1,NACT + IF (IACT(K) .LE. MEQ) GOTO 790 + IW=IWW+K + IF ((RES*W(IW)) .GE. ZERO) GOTO 790 + TEMP=W(K)/W(IW) + IF (KDROP .EQ. 0) GOTO 780 + IF (DABS(TEMP) .GE. DABS(RATIO)) GOTO 790 + 780 KDROP=K + RATIO=TEMP + 790 CONTINUE + 791 GOTO (580,650), LFLAG +C +C +C******************************************************************** +C +C +C DROP THE CONSTRAINT IN POSITION KDROP IN THE ACTIVE SET. +C + 800 IA=IWA+IACT(KDROP) + IF (IACT(KDROP) .GT. MN) IA=IA-N + W(IA)=-W(IA) + IF (KDROP .EQ. NACT) GOTO 850 +C +C SET SOME INDICES AND CALCULATE THE ELEMENTS OF THE NEXT +C GIVENS ROTATION. +C + IZ=IWZ+KDROP*N + IR=IWR+(KDROP+KDROP*KDROP)/2 + 810 IRA=IR + IR=IR+KDROP+1 + TEMP=DMAX1(DABS(W(IR-1)),DABS(W(IR))) + SUM=TEMP*DSQRT((W(IR-1)/TEMP)**2+(W(IR)/TEMP)**2) + GA=W(IR-1)/SUM + GB=W(IR)/SUM +C +C EXCHANGE THE COLUMNS OF R. +C + DO 820 I=1,KDROP + IRA=IRA+1 + J=IRA-KDROP + TEMP=W(IRA) + W(IRA)=W(J) + 820 W(J)=TEMP + W(IR)=ZERO +C +C APPLY THE ROTATION TO THE ROWS OF R. +C + W(J)=SUM + KDROP=KDROP+1 + DO 830 I=KDROP,NU + TEMP=GA*W(IRA)+GB*W(IRA+1) + W(IRA+1)=GA*W(IRA+1)-GB*W(IRA) + W(IRA)=TEMP + 830 IRA=IRA+I +C +C APPLY THE ROTATION TO THE COLUMNS OF Z. +C + DO 840 I=1,N + IZ=IZ+1 + J=IZ-N + TEMP=GA*W(J)+GB*W(IZ) + W(IZ)=GA*W(IZ)-GB*W(J) + 840 W(J)=TEMP +C +C REVISE IACT AND THE LAGRANGE MULTIPLIERS. +C + IACT(KDROP-1)=IACT(KDROP) + W(KDROP-1)=W(KDROP) + IF (KDROP .LT. NACT) GOTO 810 + 850 NACT=NACT-1 + GOTO (250,610), MFLAG +C +C +C******************************************************************** +C +C +C APPLY GIVENS ROTATION TO REDUCE SOME OF THE SCALAR +C PRODUCTS IN THE S-PARTITION OF W TO ZERO. +C + 860 IZ=IWZ+NU*N + 870 IZ=IZ-N + 880 IS=IWS+NU + NU=NU-1 + IF (NU .EQ. NACT) GOTO 900 + IF (W(IS) .EQ. ZERO) GOTO 870 + TEMP=DMAX1(DABS(W(IS-1)),DABS(W(IS))) + SUM=TEMP*DSQRT((W(IS-1)/TEMP)**2+(W(IS)/TEMP)**2) + GA=W(IS-1)/SUM + GB=W(IS)/SUM + W(IS-1)=SUM + DO 890 I=1,N + K=IZ+N + TEMP=GA*W(IZ)+GB*W(K) + W(K)=GA*W(K)-GB*W(IZ) + W(IZ)=TEMP + 890 IZ=IZ-1 + GOTO 880 + 900 GOTO (560,630), NFLAG +C +C +C******************************************************************** +C +C +C CALCULATE THE MAGNITUDE OF X AN REVISE XMAG. +C + 910 SUM=ZERO + DO 920 I=1,N + SUM=SUM+DABS(X(I))*VFACT*(DABS(GRAD(I))+DABS(G(I,I)*X(I))) + IF (LQL) GOTO 920 + IF (SUM .LT. 1.D-30) GOTO 920 + VFACT=1.D-10*VFACT + SUM=1.D-10*SUM + XMAG=1.D-10*XMAG + 920 CONTINUE + 925 XMAG=DMAX1(XMAG,SUM) + GOTO (420,690), JFLAG +C +C +C******************************************************************** +C +C +C PRE-MULTIPLY THE VECTOR IN THE W-PARTITION OF W BY Z TRANSPOSE. +C + 930 JL=IWW+1 + IZ=IWZ + DO 940 I=1,N + IS=IWS+I + W(IS)=ZERO + IWWN=IWW+N + DO 940 J=JL,IWWN + IZ=IZ+1 + 940 W(IS)=W(IS)+W(IZ)*W(J) + GOTO (350,550), KFLAG + RETURN + END diff --git a/modules/optimization/src/fortran/ql0001.lo b/modules/optimization/src/fortran/ql0001.lo new file mode 100755 index 000000000..7746b593f --- /dev/null +++ b/modules/optimization/src/fortran/ql0001.lo @@ -0,0 +1,12 @@ +# src/fortran/ql0001.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/ql0001.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/qnbd.f b/modules/optimization/src/fortran/qnbd.f new file mode 100755 index 000000000..0523c871a --- /dev/null +++ b/modules/optimization/src/fortran/qnbd.f @@ -0,0 +1,178 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1986 - INRIA - F. BONNANS +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine qnbd(indqn,simul,n,x,f,g,imp,io,zero, + & napmax,itmax,epsf,epsg,epsx,df0,binf,bsup,nfac, + & trav,ntrav,itrav,nitrav,izs,rzs,dzs) +c!but +c code de minimisation d une fonction reguliere sous contraintes +c de bornes , aux normes modulopt +c!methode +c principe de l algorithme : quasi-newton + projection +c details dans le rapport inria n. 242,1983 +c cette version permet de tester plusieurs variantes de l algorithme +c en modifiant certains parametres internes (cf comment dans le code) +c taille memoire necessaire de l ordre de n**2/2 +c pour les problemes de grande taille le code gcbd est mieux adapte +c +c!sous programmes appeles +c zqnbd optimiseur effectif +c proj projection +c calmaj mise a jour du hessien +c ajour mise a jour des facteurs de choleski +c rlbd,satur recherche lineaire avec bornes +c +c!liste d'appel +c +c subroutine qnbd(indqn,simul,n,x,f,g,imp,io,zero, +c & napmax,itmax,epsf,epsg,epsx,df0,binf,bsup,nfac, +c & trav,ntrav,itrav,nitrav,izs,rzs,dzs) +c +c indqn indicateur de qnbd es +c en entree =1 standard +c =2 dh et indic initialises au debut de trav et itrav +c ifac,f,g initialises +c en sortie +c si < 0 incapacite de calculer un point meilleur que le point initial +c si = 0 arret demande par l utilisateur +c si > 0 on fournit un point meilleur que le point de depart +c < -10 parametres d entree non convenables +c = -6 arret lors du calcul de la direction de descente et iter=1 +c = -5 arret lors du calcul de l approximation du hessien iter=1 +c = -3 anomalie de simul : indic negatif en un point ou +c f et g ont ete precedemment calcules +c = -2 echec de la recherche lineaire a la premiere iteration +c = -1 f non definie au point initial +c = 1 arret sur epsg +c = 2 epsf +c = 3 epsx +c = 4 napmax +c = 5 itmax +c = 6 pente dans la direction opposee au gradient trop petite +c = 7 arret lors du calcul de la direction de descente +c = 8 arret lors du calcul de l approximation du hessien +c = 10 arret par echec de la recherche lineaire , cause non precisee +c = 11 idem avec indsim < 0 +c = 12 un pas trop petit proche d un pas trop grand +c ceci peut resulter d une erreur dans le gradient +c = 13 trop grand nombre d appels dans une recherche lineaire +c simul voir les normes modulopt +c n dim de x e +c binf,bsup bornes inf,sup,de dim n e +c x variables a optimiser (controle) es +c f valeur du critere s +c g gradient de f s +c zero proche zero machine e +c napmax nombre maximum d appels de simul e +c itmax nombre maximum d iterations de descente e +c itrav vect travail dim nitrav=2n , se decompose en indic et izig +c nfac nombre de variables factorisees (e si indqn=2) s +c imp facteur d impression e +c varie de 0 (pas d impressions) a 3 (nombreuses impressions) +c io numero du fichier de resultats e +c epsx vect dim n precision sur x e +c epsf critere arret sur f e +c epsg arret si sup a norm2(g+)/n e +c trav vect travail dim ntrav +c il faut ntrav > n(n+1)/2 +6n +c df0>0 decroissance f prevue (prendre 1. par defaut) e +c izs,rzs,dzs : cf normes modulopt es +c! +c indications sur les variables internes a qnbd et zqnbd +c izig sert a la memorisation des contraintes (actif si izag>1) +c si i ne change pas d ens on enleve 1 a izig (positif) +c sinon on ajoute izag +c factorisation seulement si izig est nul +c dh estimation hessien dim n(n+1)/2 rangee en troismorceaux es +c indic(i) nouvel indice de l indice i +c indic vect dim n ordre de rangement des indices es +c pas necessaire de l initialiser si indqn=1 +c +c parametres de la recherche lineaire +c amd,amf param. du test de wolfe . (.7,.1) +c napm nombre max d appels dans la rl (=15) +c + implicit double precision (a-h,o-z) + real rzs(*) + double precision dzs(*) + character bufstr*(4096) + dimension binf(n),bsup(n),x(n),g(n),epsx(n) + dimension trav(ntrav),itrav(nitrav),izs(*) + external simul +c +c---- initial printing + if(imp.ge.1) then + call basout(io_out, io, '') + write(bufstr,1010) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,750) n,epsg,imp + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,751) itmax + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,752) napmax + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + call basout(io_out ,io , + $ '------------------------------------------------') +1010 format(' *********** qnbd (with bound cstr) ****************') +750 format('dimension=',i10,', epsq=',e24.16, + $ ', verbosity level: imp=',i10) +751 format('max number of iterations allowed: iter=',i10) +752 format('max number of calls to costf allowed: nap=',i10) + endif +c +c +c parametres caracteristiques de l algorithme +c si les parametres sont nuls l algorithme est celui du rr 242 +c ig=1 test sur grad(i) pour relach var +c in=1 limite le nombre de factorisations par iter a n/10 +c irel=1 test sur decroissance grad pour rel a iter courante +c epsrel taux de decroissance permettant le relachement (cf irit) +c iact blocage variables dans ib (gestion contraintes actives) +c ieps1 =1 eps1 egal a zero +c note eps1 correspond a eps(xk) + ig=0 + in=0 + irel=1 + epsrel=.50d+0 + izag=0 + iact=1 + ieps1=0 +c +c decoupage du vecteur trav + n1=(n*(n+1))/2 +1 + n2=n1+n + n3=n2+n + n4=n3+n + n5=n4+n-1 + if(ntrav.lt.n5) then + if(imp.gt.0) then + write(bufstr,110)ntrav,n5 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +110 format(' qnbd : ntrav=',i8,' devrait valoir ',i8) + indqn=-11 + return + endif + ni1=n+1 + if(nitrav.lt.2*n) then + ni2=2*n + if(imp.gt.0) then + write(bufstr,111)nitrav,ni2 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +111 format(' qnbd : nitrav=',i8,'devrait valoir',i8) + indqn=-12 + return + endif + call zqnbd(indqn,simul,trav(1),n,binf,bsup,x,f,g,zero,napmax, + &itmax,itrav,itrav(ni1),nfac,imp,io,epsx,epsf,epsg,trav(n1), + &trav(n2),trav(n3),trav(n4),df0,ig,in,irel,izag,iact, + &epsrel,ieps1,izs,rzs,dzs) + return + end diff --git a/modules/optimization/src/fortran/qnbd.lo b/modules/optimization/src/fortran/qnbd.lo new file mode 100755 index 000000000..ae042026f --- /dev/null +++ b/modules/optimization/src/fortran/qnbd.lo @@ -0,0 +1,12 @@ +# src/fortran/qnbd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qnbd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/qpgen1sci.f b/modules/optimization/src/fortran/qpgen1sci.f new file mode 100755 index 000000000..8f3bfe270 --- /dev/null +++ b/modules/optimization/src/fortran/qpgen1sci.f @@ -0,0 +1,613 @@ +c +c This program by S. Steer INRIA for Scilab is derived from the +c Berwin A. Turlach code qpgen1 from solve.QP.compact.f. +c This version uses a more compact column-compressed sparse matrix storage: +c the linear constraint matrix is supposed stored as follow +c - colnnz (q x 1) array (int) stores the number of non-zero entries for +c each column. +c - nzrindex (nnz x 1) array (int) stores the sequence of row index +c of non-zero entries, for columns 1:q +c - (nnz x 1) array of non zero entries of A (dp) stored columnwise +c replaced part of the code are commented with "corig" +c +c +c Copyright (C) 1995 Berwin A. Turlach <berwin@alphasun.anu.edu.au> +c +c This program is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program; if not, write to the Free Software +c Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +c USA. +c +c this routine uses the Goldfarb/Idnani algorithm to solve the +c following minimization problem: +c +c minimize -d^T x + 1/2 * x^T D x +c where A1^T x = b1 +c A2^T x >= b2 +c +c the matrix D is assumed to be positive definite. Especially, +c w.l.o.g. D is assumed to be symmetric. +c +c Input parameter: +c dmat nxn matrix, the matrix D from above (dp) +c *** WILL BE DESTROYED ON EXIT *** +c The user has two possibilities: +c a) Give D (ierr=0), in this case we use routines from LINPACK +c to decompose D. +c b) To get the algorithm started we need R^-1, where D=R^TR. +c So if it is cheaper to calculate R^-1 in another way (D may +c be a band matrix) then with the general routine, the user +c may pass R^{-1}. Indicated by ierr not equal to zero. +c dvec nx1 vector, the vector d from above (dp) +c *** WILL BE DESTROYED ON EXIT *** +c contains on exit the solution to the inisolve.QP.compact.ftial, i.e., +c unconstrained problem +c fddmat scalar, the leading dimension of the matrix dmat +c n the dimension of dmat and dvec (int) +c amat (nnz x 1) array of non zero entries of A (dp) stored column-wise +c *** ENTRIES CORRESPONDING TO EQUALITY CONSTRAINTS MAY HAVE +c CHANGED SIGNES ON EXIT *** +c colnnz (q x 1) array (int) stores the number of non-zero entries of A for +c each column. +c nzrindex (nnz x 1) array (int) stores the row index of non-zero entries of A + +c bvec qx1 vector, the vector of constants b in the constraints (dp) +c [ b = (b1^T b2^T)^T ] +c *** ENTRIES CORRESPONDING TO EQUALITY CONSTRAINTS MAY HAVE +c CHANGED SIGNES ON EXIT *** +c fdamat the first dimension of amat as declared in the calling program. +c fdamat >= n (and iamat must have fdamat+1 as first dimension) +c q integer, the number of constraints. +c meq integer, the number of equality constraints, 0 <= meq <= q. +c ierr integer, code for the status of the matrix D: +c ierr = 0, we have to decompose D +c ierr != 0, D is already decomposed into D=R^TR and we were +c given R^{-1}. +c +c Output parameter: +c sol nx1 the final solution (x in the notation above) +c crval scalar, the value of the criterion at the minimum +c iact qx1 vector, the constraints which are active in the final +c fit (int) +c nact scalar, the number of constraints active in the final fit (int) +c iter 2x1 vector, first component gives the number of "main" +c iterations, the second one says how many constraints were +c deleted after they became active +c ierr integer, error code on exit, if +c ierr = 0, no problems +c ierr = 1, the minimization problem has no solution +c ierr = 2, problems with decomposing D, in this case sol +c contains garbage!! +c +c Working space: +c work vector with length at least 2*n+r*(r+5)/2 + 2*q +1 +c where r=min(n,q) +c + subroutine qpgen1sci(dmat, dvec, fddmat, n, sol,crval, + * colnnz,nzrindex,amat, + * bvec, q, meq, iact, nact, iter, work, ierr) + implicit none + integer n, i, j, l, l1, + * info, q, iact(*), iter(*), colnnz(*), nzrindex(*),it1, + * ierr, nact, iwzv, iwrv, iwrm, iwsv, iwuv, nvl, + * r, iwnbv, meq, fddmat + double precision dmat(fddmat,*), dvec(*),sol(*), bvec(*), + * work(*), temp, sum, t1, tt, gc, gs, crval, + * nu, amat(*) + logical t1inf, t2min +c added for new storage of A, index on current non zero entry in +C amat and nzrindex + integer nzptr + + r = min(n,q) + l = 2*n + (r*(r+5))/2 + 2*q + 1 + + +c +c store the initial dvec to calculate below the unconstrained minima of +c the critical value. +c + do 10 i=1,n + work(i) = dvec(i) + 10 continue + do 11 i=n+1,l + work(i) = 0.d0 + 11 continue + do 12 i=1,q + iact(i)=0 + 12 continue +c +c get the initial solution +c + if( ierr .EQ. 0 )then + call dpofa(dmat,fddmat,n,info) + if( info .NE. 0 )then + ierr = 2 + goto 999 + endif + call dposl(dmat,fddmat,n,dvec) + call dpori(dmat,fddmat,n) + else +c +c Matrix D is already factorized, so we have to multiply d first with +c R^-T and then with R^-1. R^-1 is stored in the upper half of the +c array dmat. +c + do 20 j=1,n + sol(j) = 0.d0 + do 21 i=1,j + sol(j) = sol(j) + dmat(i,j)*dvec(i) + 21 continue + 20 continue + do 22 j=1,n + dvec(j) = 0.d0 + do 23 i=j,n + dvec(j) = dvec(j) + dmat(j,i)*sol(i) + 23 continue + 22 continue + endif +c +c set lower triangular of dmat to zero, store dvec in sol and +c calculate value of the criterion at unconstrained minima +c + crval = 0.d0 + do 30 j=1,n + sol(j) = dvec(j) + crval = crval + work(j)*sol(j) + work(j) = 0.d0 + do 32 i=j+1,n + dmat(i,j) = 0.d0 + 32 continue + 30 continue + crval = -crval/2.d0 + ierr = 0 +c +c calculate some constants, i.e., from which index on the different +c quantities are stored in the work matrix +c + iwzv = n + iwrv = iwzv + n + iwuv = iwrv + r + iwrm = iwuv + r+1 + iwsv = iwrm + (r*(r+1))/2 + iwnbv = iwsv + q +c +c calculate the norm of each column of the A matrix +c + nzptr = 1 + do 51 i=1,q + sum = 0.d0 +corig do 52 j=1,iamat(1,i) +corig sum = sum + amat(j,i)*amat(j,i) +corig 52 continue + do 52 j=1,colnnz(i) + sum = sum + amat(nzptr)*amat(nzptr) + nzptr=nzptr+1 + 52 continue + work(iwnbv+i) = sqrt(sum) + 51 continue + nact = 0 + iter(1) = 0 + iter(2) = 0 + 50 continue +c +c start a new iteration +c + iter(1) = iter(1)+1 +c +c calculate all constraints and check which are still violated +c for the equality constraints we have to check whether the normal +c vector has to be negated (as well as bvec in that case) +c + l = iwsv + nzptr = 1 + do 60 i=1,q + l = l+1 + sum = -bvec(i) +corig do 61 j = 1,iamat(1,i) +corig sum = sum + amat(j,i)*sol(iamat(j+1,i)) +corig 61 continue + do 61 j = 1,colnnz(i) + sum = sum + amat(nzptr)*sol(nzrindex(nzptr)) + nzptr = nzptr + 1 + 61 continue + if (i .GT. meq) then + work(l) = sum + else + work(l) = -abs(sum) + if (sum .GT. 0.d0) then +corig do 62 j=1,iamat(1,i) +corig amat(j,i) = -amat(j,i) +corig 62 continue + nzptr = nzptr - colnnz(i) + do 62 j=1,colnnz(i) + amat(nzptr) = -amat(nzptr) + nzptr = nzptr + 1 + 62 continue + bvec(i) = -bvec(i) + endif + endif + 60 continue +c +c as safeguard against rounding errors set already active constraints +c explicitly to zero +c + do 70 i=1,nact + work(iwsv+iact(i)) = 0.d0 + 70 continue +c +c we weight each violation by the number of non-zero elements in the +c corresponding row of A. then we choose the violated constraint which +c has maximal absolute value, i.e., the minimum. +c by obvious commenting and uncommenting we can choose the strategy to +c take always the first constraint which is violated. ;-) +c + nvl = 0 + temp = 0.d0 + do 71 i=1,q + if (work(iwsv+i) .LT. temp*work(iwnbv+i)) then + nvl = i + temp = work(iwsv+i)/work(iwnbv+i) + endif +c if (work(iwsv+i) .LT. 0.d0) then +c nvl = i +c goto 72 +c endif + 71 continue + 72 if (nvl .EQ. 0) goto 999 + + 55 continue +c compute index-1 of the first non zero entry of the nvl column of A + nzptr = 0 + if (nvl.gt.1) then + do i=1,nvl-1 + nzptr = nzptr + colnnz(i) + enddo + endif +c +c calculate d=J^Tn^+ where n^+ is the normal vector of the violated +c constraint. J is stored in dmat in this implementation!! +c if we drop a constraint, we have to jump back here. +c + + do 80 i=1,n + sum = 0.d0 +corig do 81 j=1,iamat(1,nvl) +corig sum = sum + dmat(iamat(j+1,nvl),i)*amat(j,nvl) +corig 81 continue + do 81 j=1,colnnz(nvl) + sum = sum + dmat(nzrindex(nzptr+j),i)*amat(nzptr+j) + 81 continue + + work(i) = sum + 80 continue +c +c Now calculate z = J_2 d_2 +c + l1 = iwzv + do 90 i=1,n + work(l1+i) =0.d0 + 90 continue + do 92 j=nact+1,n + do 93 i=1,n + work(l1+i) = work(l1+i) + dmat(i,j)*work(j) + 93 continue + 92 continue +c +c and r = R^{-1} d_1, check also if r has positive elements (among the +c entries corresponding to inequalities constraints). +c + t1inf = .TRUE. + do 95 i=nact,1,-1 + sum = work(i) + l = iwrm+(i*(i+3))/2 + l1 = l-i + do 96 j=i+1,nact + sum = sum - work(l)*work(iwrv+j) + l = l+j + 96 continue + sum = sum / work(l1) + work(iwrv+i) = sum + if (iact(i) .LE. meq) goto 95 + if (sum .LE. 0.d0) goto 95 + 7 t1inf = .FALSE. + it1 = i + 95 continue +c +c if r has positive elements, find the partial step length t1, which is +c the maximum step in dual space without violating dual feasibility. +c it1 stores in which component t1, the min of u/r, occurs. +c + if ( .NOT. t1inf) then + t1 = work(iwuv+it1)/work(iwrv+it1) + do 100 i=1,nact + if (iact(i) .LE. meq) goto 100 + if (work(iwrv+i) .LE. 0.d0) goto 100 + temp = work(iwuv+i)/work(iwrv+i) + if (temp .LT. t1) then + t1 = temp + it1 = i + endif + 100 continue + endif +c +c test if the z vector is equal to zero +c + sum = 0.d0 + do 110 i=iwzv+1,iwzv+n + sum = sum + work(i)*work(i) + 110 continue + temp = 1000.d0 + sum = sum+temp + if (temp .EQ. sum) then +c +c No step in pmrimal space such that the new constraint becomes +c feasible. Take step in dual space and drop a constant. +c + if (t1inf) then +c +c No step in dual space possible either, problem is not solvable +c + ierr = 1 + goto 999 + else +c +c we take a partial step in dual space and drop constraint it1, +c that is, we drop the it1-th active constraint. +c then we continue at step 2(a) (marked by label 55) +c + do 111 i=1,nact + work(iwuv+i) = work(iwuv+i) - t1*work(iwrv+i) + 111 continue + work(iwuv+nact+1) = work(iwuv+nact+1) + t1 + goto 700 + endif + else +c +c compute full step length t2, minimum step in primal space such that +c the constraint becomes feasible. +c keep sum (which is z^Tn^+) to update crval below! +c + sum = 0.d0 +corig do 120 i = 1,iamat(1,nvl) +corig sum = sum + work(iwzv+iamat(i+1,nvl))*amat(i,nvl) +corig 120 continue + do 120 i=1,colnnz(nvl) + sum = sum + work(iwzv+nzrindex(nzptr+i))*amat(nzptr+i) + 120 continue + + + + tt = -work(iwsv+nvl)/sum + t2min = .TRUE. + if (.NOT. t1inf) then + if (t1 .LT. tt) then + tt = t1 + t2min = .FALSE. + endif + endif +c +c take step in primal and dual space +c + do 130 i=1,n + sol(i) = sol(i) + tt*work(iwzv+i) + 130 continue + crval = crval + tt*sum*(tt/2.d0 + work(iwuv+nact+1)) + do 131 i=1,nact + work(iwuv+i) = work(iwuv+i) - tt*work(iwrv+i) + 131 continue + work(iwuv+nact+1) = work(iwuv+nact+1) + tt +c +c if it was a full step, then we check wheter further constraints are +c violated otherwise we can drop the current constraint and iterate once +c more + if(t2min) then +c +c we took a full step. Thus add constraint nvl to the list of active +c constraints and update J and R +c + nact = nact + 1 + iact(nact) = nvl +c +c to update R we have to put the first nact-1 components of the d vector +c into column (nact) of R +c + l = iwrm + ((nact-1)*nact)/2 + 1 + do 150 i=1,nact-1 + work(l) = work(i) + l = l+1 + 150 continue +c +c if now nact=n, then we just have to add the last element to the new +c row of R. +c Otherwise we use Givens transformations to turn the vector d(nact:n) +c into a multiple of the first unit vector. That multiple goes into the +c last element of the new row of R and J is accordingly updated by the +c Givens transformations. +c + if (nact .EQ. n) then + work(l) = work(n) + else + do 160 i=n,nact+1,-1 +c +c we have to find the Givens rotation which will reduce the element +c (l1) of d to zero. +c if it is already zero we don't have to do anything, except of +c decreasing l1 +c + if (work(i) .EQ. 0.d0) goto 160 + gc = max(abs(work(i-1)),abs(work(i))) + gs = min(abs(work(i-1)),abs(work(i))) + temp = sign(gc*sqrt(1+gs*gs/(gc*gc)), work(i-1)) + gc = work(i-1)/temp + gs = work(i)/temp +c +c The Givens rotation is done with the matrix (gc gs, gs -gc). +c If gc is one, then element (i) of d is zero compared with element +c (l1-1). Hence we don't have to do anything. +c If gc is zero, then we just have to switch column (i) and column (i-1) +c of J. Since we only switch columns in J, we have to be careful how we +c update d depending on the sign of gs. +c Otherwise we have to apply the Givens rotation to these columns. +c The i-1 element of d has to be updated to temp. +c + if (gc .EQ. 1.d0) goto 160 + if (gc .EQ. 0.d0) then + work(i-1) = gs * temp + do 170 j=1,n + temp = dmat(j,i-1) + dmat(j,i-1) = dmat(j,i) + dmat(j,i) = temp + 170 continue + else + work(i-1) = temp + nu = gs/(1.d0+gc) + do 180 j=1,n + temp = gc*dmat(j,i-1) + gs*dmat(j,i) + dmat(j,i) = nu*(dmat(j,i-1)+temp) - dmat(j,i) + dmat(j,i-1) = temp + 180 continue + endif + 160 continue +c +c l is still pointing to element (nact,nact) of the matrix R. +c So store d(nact) in R(nact,nact) + work(l) = work(nact) + endif + else +c +c we took a partial step in dual space. Thus drop constraint it1, +c that is, we drop the it1-th active constraint. +c then we continue at step 2(a) (marked by label 55) +c but since the fit changed, we have to recalculate now "how much" +c the fit violates the chosen constraint now. +c + sum = -bvec(nvl) +corig do 190 j = 1,iamat(1,nvl) +corig sum = sum + sol(iamat(j+1,nvl))*amat(j,nvl) +corig 190 continue + do 190 j=1,colnnz(nvl) + sum = sum + sol(nzrindex(nzptr+j))*amat(nzptr+j) + 190 continue + + if( nvl .GT. meq ) then + work(iwsv+nvl) = sum + else + work(iwsv+nvl) = -abs(sum) + if( sum .GT. 0.d0) then +corig do 191 j=1,iamat(1,nvl) +corig amat(j,nvl) = -amat(j,nvl) +corig 191 continue + do 191 j=1,colnnz(nvl) + amat(nzptr+j) = -amat(nzptr+j) + 191 continue + bvec(i) = -bvec(i) + endif + endif + goto 700 + endif + endif + goto 50 +c +c Drop constraint it1 +c + 700 continue +c +c if it1 = nact it is only necessary to update the vector u and nact +c + if (it1 .EQ. nact) goto 799 +c +c After updating one row of R (column of J) we will also come back here +c + 797 continue +c +c we have to find the Givens rotation which will reduce the element +c (it1+1,it1+1) of R to zero. +c if it is already zero we don't have to do anything except of updating +c u, iact, and shifting column (it1+1) of R to column (it1) +c l will point to element (1,it1+1) of R +c l1 will point to element (it1+1,it1+1) of R +c + l = iwrm + (it1*(it1+1))/2 + 1 + l1 = l+it1 + if (work(l1) .EQ. 0.d0) goto 798 + gc = max(abs(work(l1-1)),abs(work(l1))) + gs = min(abs(work(l1-1)),abs(work(l1))) + temp = sign(gc*sqrt(1+gs*gs/(gc*gc)), work(l1-1)) + gc = work(l1-1)/temp + gs = work(l1)/temp +c +c The Givens rotatin is done with the matrix (gc gs, gs -gc). +c If gc is one, then element (it1+1,it1+1) of R is zero compared with +c element (it1,it1+1). Hence we don't have to do anything. +c if gc is zero, then we just have to switch row (it1) and row (it1+1) +c of R and column (it1) and column (it1+1) of J. Since we swithc rows in +c R and columns in J, we can ignore the sign of gs. +c Otherwise we have to apply the Givens rotation to these rows/columns. +c + if (gc .EQ. 1.d0) goto 798 + if (gc .EQ. 0.d0) then + do 710 i=it1+1,nact + temp = work(l1-1) + work(l1-1) = work(l1) + work(l1) = temp + l1 = l1+i + 710 continue + do 711 i=1,n + temp = dmat(i,it1) + dmat(i,it1) = dmat(i,it1+1) + dmat(i,it1+1) = temp + 711 continue + else + nu = gs/(1.d0+gc) + do 720 i=it1+1,nact + temp = gc*work(l1-1) + gs*work(l1) + work(l1) = nu*(work(l1-1)+temp) - work(l1) + work(l1-1) = temp + l1 = l1+i + 720 continue + do 721 i=1,n + temp = gc*dmat(i,it1) + gs*dmat(i,it1+1) + dmat(i,it1+1) = nu*(dmat(i,it1)+temp) - dmat(i,it1+1) + dmat(i,it1) = temp + 721 continue + endif +c +c shift column (it1+1) of R to column (it1) (that is, the first it1 +c elements). The posit1on of element (1,it1+1) of R was calculated above +c and stored in l. +c + 798 continue + l1 = l-it1 + do 730 i=1,it1 + work(l1)=work(l) + l = l+1 + l1 = l1+1 + 730 continue +c +c update vector u and iact as necessary +c Continue with updating the matrices J and R +c + work(iwuv+it1) = work(iwuv+it1+1) + iact(it1) = iact(it1+1) + it1 = it1+1 + if (it1 .LT. nact) goto 797 + 799 work(iwuv+nact) = work(iwuv+nact+1) + work(iwuv+nact+1) = 0.d0 + iact(nact) = 0 + nact = nact-1 + iter(2) = iter(2)+1 + goto 55 + 999 continue + return + end diff --git a/modules/optimization/src/fortran/qpgen1sci.lo b/modules/optimization/src/fortran/qpgen1sci.lo new file mode 100755 index 000000000..a525a7c98 --- /dev/null +++ b/modules/optimization/src/fortran/qpgen1sci.lo @@ -0,0 +1,12 @@ +# src/fortran/qpgen1sci.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qpgen1sci.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/qpgen2.f b/modules/optimization/src/fortran/qpgen2.f new file mode 100755 index 000000000..09479b2d2 --- /dev/null +++ b/modules/optimization/src/fortran/qpgen2.f @@ -0,0 +1,546 @@ +c +c Copyright (C) 1995 Berwin A. Turlach <berwin@alphasun.anu.edu.au> +c +c This program is free software; you can redistribute it and/or modify +c it under the terms of the GNU General Public License as published by +c the Free Software Foundation; either version 2 of the License, or +c (at your option) any later version. +c +c This program is distributed in the hope that it will be useful, +c but WITHOUT ANY WARRANTY; without even the implied warranty of +c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +c GNU General Public License for more details. +c +c You should have received a copy of the GNU General Public License +c along with this program; if not, write to the Free Software +c Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, +c USA. +c +c this routine uses the Goldfarb/Idnani algorithm to solve the +c following minimization problem: +c +c minimize -d^T x + 1/2 * x^T D x +c where A1^T x = b1 +c A2^T x >= b2 +c +c the matrix D is assumed to be positive definite. Especially, +c w.l.o.g. D is assumed to be symmetric. +c +c Input parameter: +c dmat nxn matrix, the matrix D from above (dp) +c *** WILL BE DESTROYED ON EXIT *** +c The user has two possibilities: +c a) Give D (ierr=0), in this case we use routines from LINPACK +c to decompose D. +c b) To get the algorithm started we need R^-1, where D=R^TR. +c So if it is cheaper to calculate R^-1 in another way (D may +c be a band matrix) then with the general routine, the user +c may pass R^{-1}. Indicated by ierr not equal to zero. +c dvec nx1 vector, the vector d from above (dp) +c *** WILL BE DESTROYED ON EXIT *** +c contains on exit the solution to the initial, i.e., +c unconstrained problem +c fddmat scalar, the leading dimension of the matrix dmat +c n the dimension of dmat and dvec (int) +c amat nxq matrix, the matrix A from above (dp) [ A=(A1 A2)^T ] +c *** ENTRIES CORRESPONDING TO EQUALITY CONSTRAINTS MAY HAVE +c CHANGED SIGNES ON EXIT *** +c bvec qx1 vector, the vector of constants b in the constraints (dp) +c [ b = (b1^T b2^T)^T ] +c *** ENTRIES CORRESPONDING TO EQUALITY CONSTRAINTS MAY HAVE +c CHANGED SIGNES ON EXIT *** +c fdamat the first dimension of amat as declared in the calling program. +c fdamat >= n !! +c q integer, the number of constraints. +c meq integer, the number of equality constraints, 0 <= meq <= q. +c ierr integer, code for the status of the matrix D: +c ierr = 0, we have to decompose D +c ierr != 0, D is already decomposed into D=R^TR and we were +c given R^{-1}. +c +c Output parameter: +c sol nx1 the final solution (x in the notation above) +c crval scalar, the value of the criterion at the minimum +c iact qx1 vector, the constraints which are active in the final +c fit (int) +c nact scalar, the number of constraints active in the final fit (int) +c iter 2x1 vector, first component gives the number of "main" +c iterations, the second one says how many constraints were +c deleted after they became active +c ierr integer, error code on exit, if +c ierr = 0, no problems +c ierr = 1, the minimization problem has no solution +c ierr = 2, problems with decomposing D, in this case sol +c contains garbage!! +c +c Working space: +c work vector with length at least 2*n+r*(r+5)/2 + 2*q +1 +c where r=min(n,q) +c + subroutine qpgen2(dmat, dvec, fddmat, n, sol, crval, amat, + * bvec, fdamat, q, meq, iact, nact, iter, work, ierr) + implicit none + integer n, i, j, l, l1, + * info, q, iact(*), iter(*), it1, + * ierr, nact, iwzv, iwrv, iwrm, iwsv, iwuv, nvl, + * r, fdamat, iwnbv, meq, fddmat + double precision dmat(fddmat,*), dvec(*),sol(*), bvec(*), + * work(*), temp, sum, t1, tt, gc, gs, crval, + * nu, amat(fdamat,*) + logical t1inf, t2min + r = min(n,q) + l = 2*n + (r*(r+5))/2 + 2*q + 1 + + do 10 i=1,n + work(i) = dvec(i) + 10 continue + do 11 i=n+1,l + work(i) = 0.d0 + 11 continue + do 12 i=1,q + iact(i)=0 + 12 continue +c +c get the initial solution +c + if( ierr .EQ. 0 )then + call dpofa(dmat,fddmat,n,info) + if( info .NE. 0 )then + ierr = 2 + goto 999 + endif + call dposl(dmat,fddmat,n,dvec) + call dpori(dmat,fddmat,n) + else +c +c Matrix D is already factorized, so we have to multiply d first with +c R^-T and then with R^-1. R^-1 is stored in the upper half of the +c array dmat. +c + do 20 j=1,n + sol(j) = 0.d0 + do 21 i=1,j + sol(j) = sol(j) + dmat(i,j)*dvec(i) + 21 continue + 20 continue + do 22 j=1,n + dvec(j) = 0.d0 + do 23 i=j,n + dvec(j) = dvec(j) + dmat(j,i)*sol(i) + 23 continue + 22 continue + endif +c +c set lower triangular of dmat to zero, store dvec in sol and +c calculate value of the criterion at unconstrained minima +c + crval = 0.d0 + do 30 j=1,n + sol(j) = dvec(j) + crval = crval + work(j)*sol(j) + work(j) = 0.d0 + do 32 i=j+1,n + dmat(i,j) = 0.d0 + 32 continue + 30 continue + crval = -crval/2.d0 + ierr = 0 +c +c calculate some constants, i.e., from which index on the different +c quantities are stored in the work matrix +c + iwzv = n + iwrv = iwzv + n + iwuv = iwrv + r + iwrm = iwuv + r+1 + iwsv = iwrm + (r*(r+1))/2 + iwnbv = iwsv + q +c +c calculate the norm of each column of the A matrix +c + do 51 i=1,q + sum = 0.d0 + do 52 j=1,n + sum = sum + amat(j,i)*amat(j,i) + 52 continue + work(iwnbv+i) = sqrt(sum) + 51 continue + nact = 0 + iter(1) = 0 + iter(2) = 0 + 50 continue +c +c start a new iteration +c + iter(1) = iter(1)+1 +c +c calculate all constraints and check which are still violated +c for the equality constraints we have to check whether the normal +c vector has to be negated (as well as bvec in that case) +c + l = iwsv + do 60 i=1,q + l = l+1 + sum = -bvec(i) + do 61 j = 1,n + sum = sum + amat(j,i)*sol(j) + 61 continue + if (i .GT. meq) then + work(l) = sum + else + work(l) = -abs(sum) + if (sum .GT. 0.d0) then + do 62 j=1,n + amat(j,i) = -amat(j,i) + 62 continue + bvec(i) = -bvec(i) + endif + endif + 60 continue +c +c as safeguard against rounding errors set already active constraints +c explicitly to zero +c + do 70 i=1,nact + work(iwsv+iact(i)) = 0.d0 + 70 continue +c +c we weight each violation by the number of non-zero elements in the +c corresponding row of A. then we choose the violated constraint which +c has maximal absolute value, i.e., the minimum. +c by obvious commenting and uncommenting we can choose the strategy to +c take always the first constraint which is violated. ;-) +c + nvl = 0 + temp = 0.d0 + do 71 i=1,q + if (work(iwsv+i) .LT. temp*work(iwnbv+i)) then + nvl = i + temp = work(iwsv+i)/work(iwnbv+i) + endif +c if (work(iwsv+i) .LT. 0.d0) then +c nvl = i +c goto 72 +c endif + 71 continue + 72 if (nvl .EQ. 0) goto 999 +c +c calculate d=J^Tn^+ where n^+ is the normal vector of the violated +c constraint. J is stored in dmat in this implementation!! +c if we drop a constraint, we have to jump back here. +c + 55 continue + do 80 i=1,n + sum = 0.d0 + do 81 j=1,n + sum = sum + dmat(j,i)*amat(j,nvl) + 81 continue + work(i) = sum + 80 continue +c +c Now calculate z = J_2 d_2 +c + l1 = iwzv + do 90 i=1,n + work(l1+i) =0.d0 + 90 continue + do 92 j=nact+1,n + do 93 i=1,n + work(l1+i) = work(l1+i) + dmat(i,j)*work(j) + 93 continue + 92 continue +c +c and r = R^{-1} d_1, check also if r has positive elements (among the +c entries corresponding to inequalities constraints). +c + t1inf = .TRUE. + do 95 i=nact,1,-1 + sum = work(i) + l = iwrm+(i*(i+3))/2 + l1 = l-i + do 96 j=i+1,nact + sum = sum - work(l)*work(iwrv+j) + l = l+j + 96 continue + sum = sum / work(l1) + work(iwrv+i) = sum + if (iact(i) .LE. meq) goto 95 + if (sum .LE. 0.d0) goto 95 + 7 t1inf = .FALSE. + it1 = i + 95 continue +c +c if r has positive elements, find the partial step length t1, which is +c the maximum step in dual space without violating dual feasibility. +c it1 stores in which component t1, the min of u/r, occurs. +c + if ( .NOT. t1inf) then + t1 = work(iwuv+it1)/work(iwrv+it1) + do 100 i=1,nact + if (iact(i) .LE. meq) goto 100 + if (work(iwrv+i) .LE. 0.d0) goto 100 + temp = work(iwuv+i)/work(iwrv+i) + if (temp .LT. t1) then + t1 = temp + it1 = i + endif + 100 continue + endif +c +c test if the z vector is equal to zero +c + sum = 0.d0 + do 110 i=iwzv+1,iwzv+n + sum = sum + work(i)*work(i) + 110 continue + temp = 1000.d0 + sum = sum+temp + if (temp .EQ. sum) then +c +c No step in pmrimal space such that the new constraint becomes +c feasible. Take step in dual space and drop a constant. +c + if (t1inf) then +c +c No step in dual space possible either, problem is not solvable +c + ierr = 1 + goto 999 + else +c +c we take a partial step in dual space and drop constraint it1, +c that is, we drop the it1-th active constraint. +c then we continue at step 2(a) (marked by label 55) +c + do 111 i=1,nact + work(iwuv+i) = work(iwuv+i) - t1*work(iwrv+i) + 111 continue + work(iwuv+nact+1) = work(iwuv+nact+1) + t1 + goto 700 + endif + else +c +c compute full step length t2, minimum step in primal space such that +c the constraint becomes feasible. +c keep sum (which is z^Tn^+) to update crval below! +c + sum = 0.d0 + do 120 i = 1,n + sum = sum + work(iwzv+i)*amat(i,nvl) + 120 continue + tt = -work(iwsv+nvl)/sum + t2min = .TRUE. + if (.NOT. t1inf) then + if (t1 .LT. tt) then + tt = t1 + t2min = .FALSE. + endif + endif +c +c take step in primal and dual space +c + do 130 i=1,n + sol(i) = sol(i) + tt*work(iwzv+i) + 130 continue + crval = crval + tt*sum*(tt/2.d0 + work(iwuv+nact+1)) + do 131 i=1,nact + work(iwuv+i) = work(iwuv+i) - tt*work(iwrv+i) + 131 continue + work(iwuv+nact+1) = work(iwuv+nact+1) + tt +c +c if it was a full step, then we check wheter further constraints are +c violated otherwise we can drop the current constraint and iterate once +c more + if(t2min) then +c +c we took a full step. Thus add constraint nvl to the list of active +c constraints and update J and R +c + nact = nact + 1 + iact(nact) = nvl +c +c to update R we have to put the first nact-1 components of the d vector +c into column (nact) of R +c + l = iwrm + ((nact-1)*nact)/2 + 1 + do 150 i=1,nact-1 + work(l) = work(i) + l = l+1 + 150 continue +c +c if now nact=n, then we just have to add the last element to the new +c row of R. +c Otherwise we use Givens transformations to turn the vector d(nact:n) +c into a multiple of the first unit vector. That multiple goes into the +c last element of the new row of R and J is accordingly updated by the +c Givens transformations. +c + if (nact .EQ. n) then + work(l) = work(n) + else + do 160 i=n,nact+1,-1 +c +c we have to find the Givens rotation which will reduce the element +c (l1) of d to zero. +c if it is already zero we don't have to do anything, except of +c decreasing l1 +c + if (work(i) .EQ. 0.d0) goto 160 + gc = max(abs(work(i-1)),abs(work(i))) + gs = min(abs(work(i-1)),abs(work(i))) + temp = sign(gc*sqrt(1+gs*gs/(gc*gc)), work(i-1)) + gc = work(i-1)/temp + gs = work(i)/temp +c +c The Givens rotation is done with the matrix (gc gs, gs -gc). +c If gc is one, then element (i) of d is zero compared with element +c (l1-1). Hence we don't have to do anything. +c If gc is zero, then we just have to switch column (i) and column (i-1) +c of J. Since we only switch columns in J, we have to be careful how we +c update d depending on the sign of gs. +c Otherwise we have to apply the Givens rotation to these columns. +c The i-1 element of d has to be updated to temp. +c + if (gc .EQ. 1.d0) goto 160 + if (gc .EQ. 0.d0) then + work(i-1) = gs * temp + do 170 j=1,n + temp = dmat(j,i-1) + dmat(j,i-1) = dmat(j,i) + dmat(j,i) = temp + 170 continue + else + work(i-1) = temp + nu = gs/(1.d0+gc) + do 180 j=1,n + temp = gc*dmat(j,i-1) + gs*dmat(j,i) + dmat(j,i) = nu*(dmat(j,i-1)+temp) - dmat(j,i) + dmat(j,i-1) = temp + 180 continue + endif + 160 continue +c +c l is still pointing to element (nact,nact) of the matrix R. +c So store d(nact) in R(nact,nact) + work(l) = work(nact) + endif + else +c +c we took a partial step in dual space. Thus drop constraint it1, +c that is, we drop the it1-th active constraint. +c then we continue at step 2(a) (marked by label 55) +c but since the fit changed, we have to recalculate now "how much" +c the fit violates the chosen constraint now. +c + sum = -bvec(nvl) + do 190 j = 1,n + sum = sum + sol(j)*amat(j,nvl) + 190 continue + if( nvl .GT. meq ) then + work(iwsv+nvl) = sum + else + work(iwsv+nvl) = -abs(sum) + if( sum .GT. 0.d0) then + do 191 j=1,n + amat(j,nvl) = -amat(j,nvl) + 191 continue + bvec(i) = -bvec(i) + endif + endif + goto 700 + endif + endif + goto 50 +c +c Drop constraint it1 +c + 700 continue +c +c if it1 = nact it is only necessary to update the vector u and nact +c + if (it1 .EQ. nact) goto 799 +c +c After updating one row of R (column of J) we will also come back here +c + 797 continue +c +c we have to find the Givens rotation which will reduce the element +c (it1+1,it1+1) of R to zero. +c if it is already zero we don't have to do anything except of updating +c u, iact, and shifting column (it1+1) of R to column (it1) +c l will point to element (1,it1+1) of R +c l1 will point to element (it1+1,it1+1) of R +c + l = iwrm + (it1*(it1+1))/2 + 1 + l1 = l+it1 + if (work(l1) .EQ. 0.d0) goto 798 + gc = max(abs(work(l1-1)),abs(work(l1))) + gs = min(abs(work(l1-1)),abs(work(l1))) + temp = sign(gc*sqrt(1+gs*gs/(gc*gc)), work(l1-1)) + gc = work(l1-1)/temp + gs = work(l1)/temp +c +c The Givens rotatin is done with the matrix (gc gs, gs -gc). +c If gc is one, then element (it1+1,it1+1) of R is zero compared with +c element (it1,it1+1). Hence we don't have to do anything. +c if gc is zero, then we just have to switch row (it1) and row (it1+1) +c of R and column (it1) and column (it1+1) of J. Since we swithc rows in +c R and columns in J, we can ignore the sign of gs. +c Otherwise we have to apply the Givens rotation to these rows/columns. +c + if (gc .EQ. 1.d0) goto 798 + if (gc .EQ. 0.d0) then + do 710 i=it1+1,nact + temp = work(l1-1) + work(l1-1) = work(l1) + work(l1) = temp + l1 = l1+i + 710 continue + do 711 i=1,n + temp = dmat(i,it1) + dmat(i,it1) = dmat(i,it1+1) + dmat(i,it1+1) = temp + 711 continue + else + nu = gs/(1.d0+gc) + do 720 i=it1+1,nact + temp = gc*work(l1-1) + gs*work(l1) + work(l1) = nu*(work(l1-1)+temp) - work(l1) + work(l1-1) = temp + l1 = l1+i + 720 continue + do 721 i=1,n + temp = gc*dmat(i,it1) + gs*dmat(i,it1+1) + dmat(i,it1+1) = nu*(dmat(i,it1)+temp) - dmat(i,it1+1) + dmat(i,it1) = temp + 721 continue + endif +c +c shift column (it1+1) of R to column (it1) (that is, the first it1 +c elements). The posit1on of element (1,it1+1) of R was calculated above +c and stored in l. +c + 798 continue + l1 = l-it1 + do 730 i=1,it1 + work(l1)=work(l) + l = l+1 + l1 = l1+1 + 730 continue +c +c update vector u and iact as necessary +c Continue with updating the matrices J and R +c + work(iwuv+it1) = work(iwuv+it1+1) + iact(it1) = iact(it1+1) + it1 = it1+1 + if (it1 .LT. nact) goto 797 + 799 work(iwuv+nact) = work(iwuv+nact+1) + work(iwuv+nact+1) = 0.d0 + iact(nact) = 0 + nact = nact-1 + iter(2) = iter(2)+1 + goto 55 + 999 continue + return + end diff --git a/modules/optimization/src/fortran/qpgen2.lo b/modules/optimization/src/fortran/qpgen2.lo new file mode 100755 index 000000000..71ab32c55 --- /dev/null +++ b/modules/optimization/src/fortran/qpgen2.lo @@ -0,0 +1,12 @@ +# src/fortran/qpgen2.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/qpgen2.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/rdmps1.f b/modules/optimization/src/fortran/rdmps1.f new file mode 100755 index 000000000..74b14b45d --- /dev/null +++ b/modules/optimization/src/fortran/rdmps1.f @@ -0,0 +1,970 @@ + +C**************************************************** +C **** RDMPS1 ... READ THE MPS FILE **** +C**************************************************** + SUBROUTINE rdmps1(RCODE,buffer,MAXM,MAXN,MAXNZA, + X M,N,NZA,IROBJ,BIG,DLOBND,DUPBND, + X NAMEC,NAMEB,NAMRAN,NAMBND,NAMMPS,inmps, + X RWNAME,CLNAME,STAVAR,RWSTAT, + X HDRWCD,LNKRW,HDCLCD,LNKCL, + X RWNMBS,CLPNTS,IROW, + X ACOEFF,RHSB,RANGES, + X UPBND,LOBND,RELT) +C +C *** PARAMETERS + INTEGER*4 RCODE,MAXM,MAXN,MAXNZA,M,N,NZA,IROBJ + DOUBLE PRECISION BIG,DLOBND,DUPBND + CHARACTER*(*) NAMEC,NAMEB,NAMRAN,NAMBND,NAMMPS + CHARACTER*(*) BUFFER + CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) + INTEGER*4 STAVAR(*),RWSTAT(*),RWNMBS(*) + INTEGER*4 HDRWCD(*),LNKRW(*) + INTEGER*4 HDCLCD(*),LNKCL(*) + INTEGER*4 CLPNTS(*),IROW(*) + DOUBLE PRECISION ACOEFF(*),RHSB(*),RANGES(*) + DOUBLE PRECISION UPBND(*),LOBND(*),RELT(*) +C +C +C +C *** PARAMETERS DESCRIPTION +C RCODE Return code: +C 0 Everything OK; +C 21 Number of constraints exceeds MAXM. +C 22 Number of variables exceeds MAXN. +C 23 Number of nonzeros exceeds MAXNZA. +C 83 Error in MPS file (in RHSB or RANGES). +C 84 Error in MPS file (in ROWS, COLUMNS or BOUNDS). +C 86 Unable to open the MPS file. +C MAXM Maximum number of constraints. +C MAXN Maximum number of variables. +C MAXNZA Maximum number of nonzeros of the LP constraint matrix. +C M Current number of constraints. +C N Current number of variables. +C NZA Current number of nonzeros of the LP constraint matrix. +C IROBJ Index of the objective row. +C BIG "Big" number. +C DUPBND Default UPPER bound. +C DLOBND Default LOWER bound. +C NAMEC Name of the objective row. +C NAMEB Name of the right hand side section. +C NAMRAN Name of the ranges section. +C NAMBND Name of the bounds section. +C NAMMPS Name of the LP problem. +C FILMPS Name of the MPS input file. +C RWNAME Array of row names. +C CLNAME Array of column names. +C STAVAR Work array for (local) variable status. +C RWSTAT Array of row types: +C 1 row type is = ; +C 2 row type is >= ; +C 3 row type is <= ; +C 4 objective row; +C 5 other free row. +C HDRWCD Header to the linked list of rows with the same codes. +C LNKRW Linked list of rows with the same codes. +C HDCLCD Header to the linked list of columns with the same codes. +C LNKCL Linked list of columns with the same codes. +C RWNMBS Row numbers of nonzeros in columns of matrix A. +C CLPNTS Pointers to the beginning of columns of matrix A. +C IROW Integer work array. +C ACOEFF Array of nonzero elements for each column. +C RHSB Right hand side of the linear program. +C RANGES Array of constraint ranges. +C UPBND Array of upper bounds. +C LOBND Array of lower bounds. +C RELT Real work array. +C +C +C +C *** LOCAL VARIABLES + INTEGER*4 LINE,I,INMPS,J,COLLEN,INDEX,IPOS,STATUS,NSTRCT,KCODE + INTEGER*4 IMPSOK + DOUBLE PRECISION SMALLA,VAL1,VAL2 + CHARACTER*8 NAME0,NAMRW1,NAMRW2,NAMCLN + CHARACTER*2 TYPROW,BNDTYP + CHARACTER*4 NM + CHARACTER*100 RDLINE + CHARACTER SECT +C +C +C +C *** PURPOSE +C This routine reads the MPS input file. +C +C *** SUBROUTINES CALLED +C LKINDX,RDRHS,LKCODE +C +C *** NOTES +C +C +C *** REFERENCES: +C Altman A., Gondzio J. (1993). An efficient implementation of +C a higher order primal-dual interior point method for large +C sparse linear programs, Archives of Control Sciences 2, +C No 1-2, pp. 23-40. +C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- +C dual method for large scale linear programmming, European +C Journal of Operational Research 66 (1993) pp 158-160. +C Gondzio J., Tachat D. (1994). The design and application of +C IPMLO - a FORTRAN library for linear optimization with +C interior point methods, RAIRO Recherche Operationnelle 28, +C No 1, pp. 37-56. +C Murtagh B. (1981). Advanced Linear Programming, McGrew-Hill, +C New York, 1981. +C Murtagh B., Saunders M. (1983). MINOS 5.0 User's guide, +C Technical Report SOL 83-20, Department of Operations Research, +C Stanford University, Stanford, 1983. +C +C *** HISTORY: +C Written by: Jacek Gondzio, Systems Research Institute, +C Polish Academy of Sciences, Newelska 6, +C 01-447 Warsaw, Poland. +C Date written: November 15, 1992 +C Last modified: February 8, 1997 +C DIGITEO - Michael Baudin, 06/2011: Ignore blank lines +C +C +C *** BODY OF (RDMPS1) *** +C + SMALLA=1.0D-10 +C +C Format used to read every line of the MPS file. + 1000 FORMAT(A80) +C +C +C Initialize. + M=0 + LINE=0 + IROBJ=-1 +C + + + DO 20 I=1,MAXM + RWNAME(I)=' ' + RWSTAT(I)=0 + 20 CONTINUE +C + +C Initialize linked lists of rows/cols with the same codes. + DO 40 I=1,MAXM + HDRWCD(I)=0 + LNKRW(I)=0 + 40 CONTINUE + DO 50 J=1,MAXN + HDCLCD(J)=0 + LNKCL(J)=0 + 50 CONTINUE +C +C +C +C Read the problem name. + 60 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 60 + READ(RDLINE,61,ERR=9000) NM,NAMMPS + 61 FORMAT(A4,10X,A8) + IF(NM.NE.'NAME'.AND.NM.NE.'name') GO TO 60 + + 70 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 70 + READ(RDLINE,71,ERR=9000) SECT + 71 FORMAT(A1) + IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 9000 +C +C +C + +C +C Read the ROWS section. + 100 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 100 + READ(RDLINE,101,ERR=9000) SECT,TYPROW,NAMRW1 + 101 FORMAT(A1,A2,1X,A8) + IF(SECT.NE.' ') GO TO 200 +C +C Here if a constraint has been found. Determine its type. +C Check if there is enough space for a new row. + M=M+1 +css IF(M.GE.MAXM) GO TO 9010 + IF(M.GT.MAXM) GO TO 9010 +C + IF(TYPROW.EQ.' E'.OR.TYPROW.EQ.'E '.OR. + X TYPROW.EQ.' e'.OR.TYPROW.EQ.'e ') THEN + RWSTAT(M)=1 + GO TO 120 + ENDIF +C + IF(TYPROW.EQ.' G'.OR.TYPROW.EQ.'G '.OR. + X TYPROW.EQ.' g'.OR.TYPROW.EQ.'g ') THEN + RWSTAT(M)=2 + GO TO 120 + ENDIF +C + IF(TYPROW.EQ.' L'.OR.TYPROW.EQ.'L '.OR. + X TYPROW.EQ.' l'.OR.TYPROW.EQ.'l ') THEN + RWSTAT(M)=3 + GO TO 120 + ENDIF +C + IF(TYPROW.EQ.' N'.OR.TYPROW.EQ.'N '.OR. + X TYPROW.EQ.' n'.OR.TYPROW.EQ.'n ') THEN + IF(NAMRW1.EQ.NAMEC(1:8)) THEN +C +C Save index of the objective row. + IROBJ=M + RWSTAT(M)=4 + ELSE + RWSTAT(M)=5 +C +C The first free row is a default objective. + IF(NAMEC(1:8).EQ.' ') THEN + IROBJ=M + RWSTAT(M)=4 + NAMEC(1:8)=NAMRW1 + ENDIF + ENDIF + GO TO 120 + ENDIF +C +C Invalid row type. + GO TO 9050 +C +C Here to save the row name. + 120 RWNAME(M)=NAMRW1 +C +C Continue reading of the ROWS section. + GO TO 100 +C +C +C +C +C +C +C Read COLUMNS section. + 200 CONTINUE + + INDEX=1 +C +C ENCODE all row names and create linked lists of rows +C with the same codes. + IMPSOK=1 + DO 210 I=1,M + CALL MYCODE(IOLOG,RWNAME(I),KCODE,M) + LNKRW(I)=HDRWCD(KCODE) + HDRWCD(KCODE)=I +C +C Check for multiple row definition (February 10, 1996). +C Scan all rows with the same code. + IPOS=LNKRW(I) + 205 IF(IPOS.EQ.0) GO TO 210 + IF(RWNAME(IPOS).EQ.RWNAME(I)) THEN + WRITE(BUFFER,206) RWNAME(IPOS) + 206 FORMAT(1X,'RDMPS1 error: Row ',A8,'repeated.') +C CALL basout(io,wte,BUFFER) + IMPSOK=0 + GO TO 210 + ENDIF + IPOS=LNKRW(IPOS) + GO TO 205 + 210 CONTINUE + IF(IMPSOK.EQ.0) GO TO 9400 +C + IF(SECT.NE.'C'.AND.SECT.NE.'c') GO TO 9000 + NAME0=' ' + 220 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 220 + READ(RDLINE,221,ERR=9000) SECT,NAMCLN,NAMRW1,VAL1,NAMRW2,VAL2 + 221 FORMAT(A1,3X,A8,2X,A8,2X,D12.0,3X,A8,2X,D12.0) +C + IF(NAMCLN.EQ.NAME0) GO TO 260 +C +C Here if the new column has been found. +C Save the previous column in the LP data structures. +C +C Check if this is the first column. + IF(NAME0.EQ.' ') THEN + NAME0=NAMCLN + COLLEN=0 + NZA=0 + N=1 + GO TO 260 + ENDIF +C + IF(NZA+COLLEN.GT.MAXNZA) GO TO 9020 +C + CLPNTS(N)=NZA+1 + CLNAME(N)=NAME0 + DO 240 I=1,COLLEN + IPOS=NZA+I + RWNMBS(IPOS)=IROW(I) + ACOEFF(IPOS)=RELT(I) + 240 CONTINUE + NZA=NZA+COLLEN +C +C Check if there are still columns to be read. + IF(SECT.NE.' ') THEN + CLPNTS(N+1)=NZA+1 + NSTRCT=N + GO TO 300 + ELSE +C +C Initialize the new column. + N=N+1 +css IF(N.GE.MAXN) GO TO 9030 + IF(N.GT.MAXN) GO TO 9030 + NAME0=NAMCLN + COLLEN=0 + GO TO 260 + ENDIF +C +C +C Find the position of the nonzero element. +C 260 CALL LKINDX(RWNAME,M,NAMRW1,INDEX) + 260 CALL LKCODE(RWNAME,M,NAMRW1,INDEX,HDRWCD,LNKRW,IOLOG) + IF(INDEX.EQ.0) GO TO 9040 +C +C +C Save nonzero element of the N-th column. + IF(DABS(VAL1).LE.SMALLA) GO TO 280 + COLLEN=COLLEN+1 + IROW(COLLEN)=INDEX + RELT(COLLEN)=VAL1 +C +C Check if there is another nonzero read in the analysed line. + 280 IF(NAMRW2.NE.' ') THEN + NAMRW1=NAMRW2 + VAL1=VAL2 + NAMRW2=' ' + GO TO 260 + ELSE + GO TO 220 + ENDIF +C +C +C +C +C Initialize RHSB and RANGES arrays. + 300 DO 320 I=1,MAXM + RHSB(I)=0.0 + RANGES(I)=BIG + 320 CONTINUE +C +C +C +C Set the default bounds for all structural variables. + DO 520 J=1,MAXN + STAVAR(J)=0 + LOBND(J)=DLOBND + UPBND(J)=DUPBND + 520 CONTINUE +C +C +C +C +C +C +C Read the RHSB section. +C + IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 9000 + CALL RDRHS(RCODE,BUFFER,MAXM,M,LINE, + X HDRWCD,LNKRW,HDCLCD,LNKCL, + X NAMEB,RHSB,RWNAME,SECT,INMPS,IOLOG) +C + IF(RCODE.GT.0) GO TO 6000 +C +C +C +C +C Check if there is a RANGES section to be read. + IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 400 +C +C +C +C +C +C +C Read the RANGES section. +C + CALL RDRHS(RCODE,BUFFER,MAXM,M,LINE, + X HDRWCD,LNKRW,HDCLCD,LNKCL, + X NAMRAN,RANGES,RWNAME,SECT,INMPS,IOLOG) +C + IF(RCODE.GT.0) GO TO 6000 +C +C +C + 400 CONTINUE + IF(SECT.NE.'B'.AND.SECT.NE.'b') GO TO 600 +C +C +C +C +C +C +C Read the BOUNDS section. +C + INDEX=1 + 550 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 550 +C +C ENCODE all column names and create linked lists of columns +C with the same codes. +C DO 560 J=1,N +C LNKCL(J)=HDCLCD(KCODE) +C HDCLCD(KCODE)=J +C 560 CONTINUE +C + READ(RDLINE,561,ERR=9000) SECT,BNDTYP,NAME0,NAMCLN,VAL1 + 561 FORMAT(A1,A2,1X,A8,2X,A8,2X,D12.0) +C + IF(SECT.NE.' ') GO TO 600 +C +C First record met defines default section name. + IF(NAMBND(1:8).EQ.' ') THEN + NAMBND(1:8)=NAME0 + ENDIF +C +C Ignore the record that define unimportant bound. + IF(NAME0.NE.NAMBND(1:8)) GO TO 550 +C +C Determine index of the variable to which the bound refers. + CALL LKINDX(CLNAME,N,NAMCLN,INDEX) +C CALL LKCODE(CLNAME,N,NAMCLN,INDEX,HDCLCD,LNKCL,IOLOG) + IF(INDEX.EQ.0) GO TO 9060 +C +C +C Here to detect the type of the bound read. + STATUS=STAVAR(INDEX) +C +C +C + IF(BNDTYP.EQ.'UP'.OR.BNDTYP.EQ.'up') THEN +C +C Here when an UPPER bound is being defined. +C Accept multiple definition of the UPPER bound. +C The last definition is valid. + IF(STATUS.EQ.6) GO TO 9070 + IF(STATUS.EQ.-1) GO TO 9080 +C + IF(STATUS.EQ.0.OR.STATUS.EQ.1) THEN +C +C Not yet bounded variable (or multiple UPPER bound). + UPBND(INDEX)=VAL1 + STAVAR(INDEX)=1 + GO TO 550 + ENDIF +C + IF(STATUS.EQ.2.OR.STATUS.EQ.3) THEN +C +C Already LOWER bounded variable. + UPBND(INDEX)=VAL1 + STAVAR(INDEX)=3 + GO TO 550 + ENDIF +C + ENDIF +C +C +C + IF(BNDTYP.EQ.'LO'.OR.BNDTYP.EQ.'lo') THEN +C +C Here when a LOWER bound is being defined. + IF(STATUS.EQ.2.OR.STATUS.EQ.3.OR.STATUS.EQ.6) GO TO 9070 + IF(STATUS.EQ.-1) GO TO 9080 +C + IF(STATUS.EQ.0) THEN +C +C Not yet bounded variable. + LOBND(INDEX)=VAL1 + STAVAR(INDEX)=2 + GO TO 550 + ENDIF +C + IF(STATUS.EQ.1) THEN +C +C Already UPPER bounded variable. + LOBND(INDEX)=VAL1 + STAVAR(INDEX)=3 + GO TO 550 + ENDIF +C + ENDIF +C +C +C + IF(BNDTYP.EQ.'FR'.OR.BNDTYP.EQ.'fr') THEN +C +C Here when a FREE variable is being defined. + IF(STATUS.GT.0) GO TO 9090 +C +C Not yet bounded variable. + LOBND(INDEX)=-BIG + UPBND(INDEX)=BIG + STAVAR(INDEX)=-1 + GO TO 550 +C + ENDIF +C +C +C + IF(BNDTYP.EQ.'FX'.OR.BNDTYP.EQ.'fx') THEN +C +C Here when a FIXED variable is being defined. + IF(STATUS.EQ.-1) GO TO 9080 + IF(STATUS.NE.0) GO TO 9100 +C +C Not yet bounded variable. + LOBND(INDEX)=VAL1 + UPBND(INDEX)=VAL1 + STAVAR(INDEX)=6 + GO TO 550 +C + ENDIF +C +C +C + IF(BNDTYP.EQ.'PL'.OR.BNDTYP.EQ.'pl') THEN +C +C Here when a PLUS INFINITY bound is being defined. + IF(STATUS.EQ.-1) GO TO 9080 + IF(STATUS.NE.0) GO TO 9070 +C +C Not yet bounded variable. +C LOBND(INDEX)=VAL1 + UPBND(INDEX)=BIG + STAVAR(INDEX)=2 + GO TO 550 +C + ENDIF +C +C +C + IF(BNDTYP.EQ.'MI'.OR.BNDTYP.EQ.'mi') THEN +C +C Here when a MINUS INFINITY bound is being defined. + IF(STATUS.EQ.-1) GO TO 9080 + IF(STATUS.NE.0) GO TO 9070 +C +C Not yet bounded variable. + LOBND(INDEX)=-BIG +C UPBND(INDEX)=VAL1 + STAVAR(INDEX)=1 + GO TO 550 +C + ENDIF +C + GO TO 9110 +C +C +C + 600 CONTINUE + IF(SECT.NE.'E'.AND.SECT.NE.'e') GO TO 9000 +C +C +C +C +C +C +C The ENDATA card has been found. +C + IF(IROBJ.EQ.-1) GO TO 9130 + 5000 CONTINUE + RCODE=0 +C + 6000 CONTINUE +C Close the MPS input file. +css call clunit(-inmps,filmps(1:ilen),mode) +c CLOSE(INMPS) + RETURN +C +C +C +C +C +C Here when error occurs. + 9000 WRITE(BUFFER,9001) LINE + 9001 FORMAT(1X,'RDMPS1: Error while reading line',I10, + X ' of the MPS file.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9010 WRITE(BUFFER,9011) + 9011 FORMAT(1X,'RDMPS1 ERROR: Number of constraints', + X ' in the MPS file exceeds MAXM.') +css CALL basout(io,wte,BUFFER) + RCODE=21 + GO TO 6000 +C + 9020 WRITE(BUFFER,9021) + 9021 FORMAT(1X,'RDMPS1 ERROR: Number of nonzeros', + X ' of matrix A exceeds MAXNZA.') +css CALL basout(io,wte,BUFFER) + RCODE=23 + GO TO 6000 +C + 9030 WRITE(BUFFER,9031) + 9031 FORMAT(1X,'RDMPS1 ERROR: Number of variables', + X ' in the MPS file exceeds MAXN.') +css CALL basout(io,wte,BUFFER) + RCODE=22 + GO TO 6000 +C + 9040 WRITE(BUFFER,9041) LINE + 9041 FORMAT(1X,'RDMPS1 ERROR: Unknown row found', + X ' at line',I10,' of the MPS file.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9050 WRITE(BUFFER,9051) TYPROW,LINE + 9051 FORMAT(1X,'RDMPS1 ERROR: Unknown row type=',A2, + X ' at line',I10,' of the MPS file.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9060 WRITE(BUFFER,9061) LINE + 9061 FORMAT(1X,'RDMPS1 ERROR: Unknown column found', + X ' at line',I10,' of the MPS file.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9070 WRITE(BUFFER,9071) LINE,BNDTYP + 9071 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', + X ' defines ',A2,' bound') +css CALL basout(io,wte,BUFFER) + WRITE(BUFFER,9072) NAMCLN + 9072 FORMAT(14X,'for variable ',A8, + X ' that has already been bounded.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9080 WRITE(BUFFER,9081) LINE,BNDTYP + 9081 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', + X ' defines ',A2,' bound') + CALL basout(io,wte,BUFFER) + WRITE(BUFFER,9082) NAMCLN + 9082 FORMAT(14X,'for variable ',A8, + X ' that has earlier been declared FREE.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9090 WRITE(BUFFER,9091) LINE + 9091 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', + X ' declares as FREE') +css CALL basout(io,wte,BUFFER) + WRITE(BUFFER,9092) NAMCLN + 9092 FORMAT(14X,' variable ',A8, + X ' that has earlier been bounded.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9100 WRITE(BUFFER,9101) LINE,NAMCLN + 9101 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', + X ' declares as FIXED',14X,' variable ',A8, + X ' that has earlier been bounded.') +css CALL basout(io,wte,BUFFER) +css WRITE(BUFFER,9102) NAMCLN +css 9102 FORMAT(14X,' variable ',A8, +css X ' that has earlier been bounded.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9110 WRITE(BUFFER,9111) LINE,BNDTYP + 9111 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', + X ' has invalid bound type ',A2) +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C + 9130 WRITE(BUFFER,9131) NAMEC(1:8) + 9131 FORMAT(1X,'RDMPS1 ERROR: Objective row =',A8, + X ' has no entries.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 + +C + 9400 WRITE(BUFFER,9401) + 9401 FORMAT(1X,'RDMPS1 ERROR: Multiple row definition.') +css CALL basout(io,wte,BUFFER) + RCODE=84 + GO TO 6000 +C *** LAST CARD OF (RDMPS1) *** + END +C****************************************************************** + SUBROUTINE LKCODE(RWNAME,M,NAME,INDEX,HEADER,LINKS,IOLOG) +C + INTEGER*4 KCODE,M,I,INDEX,IOLOG + + INTEGER*4 HEADER(M),LINKS(M) + CHARACTER*8 RWNAME(M),NAME +C +C Get code of the NAME. + CALL MYCODE(IOLOG,NAME,KCODE,M) + INDEX=HEADER(KCODE) +C +C Determine the index such that RWNAME(index) = NAME. + DO 100 I=1,M + IF(INDEX.EQ.0) GO TO 200 + IF(RWNAME(INDEX).EQ.NAME) GO TO 200 + INDEX=LINKS(INDEX) + 100 CONTINUE +C + 200 CONTINUE + RETURN + END +C******************************************************************* + SUBROUTINE LKINDX(RWNAME,M,NAME,INDEX) +C + INTEGER*4 M,I,INDEX,INDEX2 + CHARACTER*8 RWNAME(M),NAME +C + INDEX2=INDEX +C WRITE(0,10) INDEX +C 10 FORMAT(1X,' old index=',I5) + INDEX=0 + DO 100 I=INDEX2,M + IF(RWNAME(I).EQ.NAME) THEN + INDEX=I + GO TO 200 + ENDIF + 100 CONTINUE + DO 150 I=1,INDEX2 + IF(RWNAME(I).EQ.NAME) THEN + INDEX=I + GO TO 200 + ENDIF + 150 CONTINUE +C + 200 CONTINUE + RETURN + END +C******************************************************************** +C ******* RDRHS ... READ THE RHS SECTION OF THE MPS FILE ******* +C******************************************************************** +C + SUBROUTINE RDRHS(RCODE,BUFFER,MAXM,M,LINE, + X HDRWCD,LNKRW,HDCLCD,LNKCL, + X NAMEB,RRHS,RWNAME,SECT,INMPS,IOLOG) +C +C + include 'stack.h' +C +C *** PARAMETERS + INTEGER*4 RCODE,MAXM,M,LINE,INMPS,IOLOG + CHARACTER*8 NAMEB,RWNAME(MAXM) + INTEGER*4 HDRWCD(M+1),LNKRW(M+1) + INTEGER*4 HDCLCD(M+1),LNKCL(M+1) + DOUBLE PRECISION RRHS(MAXM) + CHARACTER*100 BUFFER + CHARACTER SECT +C +C +C +C *** LOCAL VARIABLES + INTEGER*4 INDEX + DOUBLE PRECISION VAL1,VAL2 + CHARACTER*8 NAME0,NAMRW1,NAMRW2 + CHARACTER*100 RDLINE +C +C +C +C *** PARAMETERS DESCRIPTION +C ON INPUT: +C MAXM Maximum number of constraints. +C M Current number of constraints. +C LINE Current number of the line read from the MPS file. +C NAMEB The name of the right hand side section chosen. +C RWNAME Array of row names. +C HDRWCD Header to the linked list of rows with the same codes. +C LNKRW Linked list of rows with the same codes. +C HDCLCD Header to the linked list of columns with the same codes. +C LNKCL Linked list of columns with the same codes. +C IOLOG Output unit number where log messages are to be written. +C INMPS Input unit number where the input MPS file is read from. +C +C ON OUTPUT: +C RCODE Return code: +C 0 Everything OK; +C 83 Error in MPS file (in RRHS or RANGES section). +C RRHS The right hand side vector. +C SECT Indicator of the section that follows RRHS one. +C +C +C +C *** SUBROUTINES CALLED +C LKINDX +C +C +C +C *** PURPOSE +C This routine reads the RRHS section of the MPS file. +C (It can also be used to read the RANGES section). +C +C +C +C *** NOTES +C +C +C +C *** REFERENCES: +C Altman A., Gondzio J. (1993). An efficient implementation of +C a higher order primal-dual interior point method for large +C sparse linear programs, Archives of Control Sciences 2, +C No 1-2, pp. 23-40. +C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- +C dual method for large scale linear programmming, European +C Journal of Operational Research 66 (1993) pp 158-160. +C Gondzio J., Tachat D. (1994). The design and application of +C IPMLO - a FORTRAN library for linear optimization with +C interior point methods, RAIRO Recherche Operationnelle 28, +C No 1, pp. 37-56. +C +C +C +C *** HISTORY: +C Written by: Jacek Gondzio, Systems Research Institute, +C Polish Academy of Sciences, Newelska 6, +C 01-447 Warsaw, Poland. +C Last modified: February 8, 1997 +C +C +C +C *** BODY OF (RDRHS) *** +C +C Format used to read every line of the MPS file. + 1000 FORMAT(A80) +C +C +C +C +C Main loop begins here. + 200 LINE=LINE+1 + READ(INMPS,1000,ERR=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 200 + INDEX=1 + READ(RDLINE,201,ERR=9000) SECT,NAME0,NAMRW1,VAL1,NAMRW2,VAL2 + 201 FORMAT(A1,3X,A8,2X,A8,2X,D12.0,3X,A8,2X,D12.0) +C +C Check if the line belongs to the same section. + IF(SECT.NE.' ') GO TO 300 +C +C First record met defines default section name. + IF(NAMEB.EQ.' ') THEN + NAMEB=NAME0 + ENDIF + IF(NAME0.NE.NAMEB) GO TO 9000 +C +C +C Find the position of the nonzero element. +C 250 CALL LKINDX(RWNAME,M,NAMRW1,INDEX) + 250 CALL LKCODE(RWNAME,M,NAMRW1,INDEX,HDRWCD,LNKRW,IOLOG) + IF(INDEX.EQ.0) GO TO 9010 +C +C Save the RRHS coefficient. + RRHS(INDEX)=VAL1 +C WRITE(BUFFER,251) INDEX,RWNAME(INDEX),VAL1 +C 251 FORMAT(1X,'RDRHS: rw=',I6,' rwname=',A8,' elt=',D14.6) +C CALL MYWRT(IOLOG,BUFFER) +C +C Check if there is another nonzero read in the analysed line. + IF(NAMRW2.NE.' ') THEN + NAMRW1=NAMRW2 + VAL1=VAL2 + NAMRW2=' ' + GO TO 250 + ELSE + GO TO 200 + ENDIF +C +C +C + 300 CONTINUE + RCODE=0 +C + 6000 CONTINUE + RETURN +C +C +C +C Here if an error occurs. + 9000 WRITE(BUFFER,9001) LINE + 9001 FORMAT(1X,'RDRHS ERROR: Unexpected characters found', + X ' at line',I10,' of the MPS file.') +css CALL basout(io,wte,BUFFER) + RCODE=83 + GO TO 6000 +C + 9010 WRITE(BUFFER,9011) LINE + 9011 FORMAT(1X,'RDRHS ERROR: Unknown row was found', + X ' at line',I10,' of the MPS file.') +css CALL basout(io,wte,BUFFER) + RCODE=83 + GO TO 6000 +C +C +C +C *** LAST CARD OF (RDRHS) *** + END + +C******************************************************************* +C ** MYCODE ... ENCODE THE 8-CHARACTER NAME INTO AN INTEGER ** +C******************************************************************* +C + SUBROUTINE MYCODE(IOLOG,NAME,KCODE,M) +C +C +C *** PARAMETERS + CHARACTER*9 NAME + INTEGER*4 IOLOG,KCODE,M +C +C +C *** LOCAL VARIABLES + INTEGER*4 IPOS +C +C +C *** PARAMETERS DESCRIPTION +C NAME 8-character name (row or column name). +C KCODE Integer code associated to the name. +C M The number of rows (or columns) in matrix A. +C IOLOG Output unit number where log messages are to be written. +C +C *** HISTORY: +C Written by: Jacek Gondzio, Systems Research Institute, +C Polish Academy of Sciences, Newelska 6, +C 01-447 Warsaw, Poland. +C Date written: October 14, 1994 +C Last modified: May 17, 1995 +C +C +C *** BODY OF (MYCODE) *** +C +C + KCODE=0 + DO 100 IPOS=1,8 + KCODE=KCODE+ICHAR(NAME(IPOS:IPOS))*IPOS +C WRITE(BUFFER,101) IPOS,NAME(IPOS:IPOS) +C 101 FORMAT(1X,'ipos=',I2,' char=',A1) +C CALL MYWRT(IOLOG,BUFFER) + 100 CONTINUE + KCODE=MOD(KCODE,M)+1 +C WRITE(BUFFER,102) NAME,KCODE +C 102 FORMAT(1X,' name=',A8,' has a code=',I6) +C CALL MYWRT(IOLOG,BUFFER) + RETURN +C +C +C *** LAST CARD OF (MYCODE) *** + END + diff --git a/modules/optimization/src/fortran/rdmps1.lo b/modules/optimization/src/fortran/rdmps1.lo new file mode 100755 index 000000000..42ff33ed1 --- /dev/null +++ b/modules/optimization/src/fortran/rdmps1.lo @@ -0,0 +1,12 @@ +# src/fortran/rdmps1.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rdmps1.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/rdmpsz.f b/modules/optimization/src/fortran/rdmpsz.f new file mode 100755 index 000000000..10cf24c73 --- /dev/null +++ b/modules/optimization/src/fortran/rdmpsz.f @@ -0,0 +1,158 @@ +C************************************************************** +C **** RDMPSZ ... READ THE MPS FILE TO GET MAX SIZES **** +C************************************************************** +C + SUBROUTINE rdmpsz(INMPS,M,N,NZA,RCODE,TYPROW,LINE) +C *** PARAMETERS + INTEGER*4 RCODE,M,N,NZA,INMPS,LINE + CHARACTER*2 TYPROW +C INMPS : logical unit of the MPS file +C RCODE : error indicator +C 0 = OK +C 1 = Error while reading line "LINE" of the MPS file. +C 2 = ERROR: Unknown row type "TYPROW" at line "LINE". +C TYPROW: SET IF RCODE==2 +C LINE : SET IF RCODE>0 +C M : NUMBER OF CONSTRAINTS +C N : number of variables. +C NZA : number of nonzeros of the LP constraint matrix. + +C DIGITEO - Michael Baudin, 06/2011: Ignore blank lines + +C +C *** LOCAL VARIABLES + INTEGER*4 COLLEN + DOUBLE PRECISION SMALLA,VAL1,VAL2 + CHARACTER*8 NAME0,NAMRW1,NAMRW2,NAMCLN + CHARACTER*8 NAMMPS + CHARACTER*4 NM + CHARACTER*100 RDLINE + CHARACTER SECT + +C + SMALLA=1.0D-10 +C +C Format used to read every line of the MPS file. + 1000 FORMAT(A80) +C +C Initialize. + M=0 + RCODE=0 + LINE=0 +C +C Read the problem name. + 60 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 60 + READ(RDLINE,61,ERR=9000) NM,NAMMPS + 61 FORMAT(A4,10X,A8) + IF(NM.NE.'NAME'.AND.NM.NE.'name') GO TO 60 + 70 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 70 + READ(RDLINE,71,ERR=9000) SECT + 71 FORMAT(A1) + IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 9000 +C +C Read the ROWS section. + 100 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 100 + READ(RDLINE,101,ERR=9000) SECT,TYPROW,NAMRW1 + 101 FORMAT(A1,A2,1X,A8) + IF(SECT.NE.' ') GO TO 200 +C +C Here if a constraint has been found. Check its type. + M=M+1 +C + IF(TYPROW.EQ.' E'.OR.TYPROW.EQ.'E '.OR. + X TYPROW.EQ.' e'.OR.TYPROW.EQ.'e ') THEN + GO TO 100 + ENDIF +C + IF(TYPROW.EQ.' G'.OR.TYPROW.EQ.'G '.OR. + X TYPROW.EQ.' g'.OR.TYPROW.EQ.'g ') THEN + GO TO 100 + ENDIF +C + IF(TYPROW.EQ.' L'.OR.TYPROW.EQ.'L '.OR. + X TYPROW.EQ.' l'.OR.TYPROW.EQ.'l ') THEN + GO TO 100 + ENDIF +C + IF(TYPROW.EQ.' N'.OR.TYPROW.EQ.'N '.OR. + X TYPROW.EQ.' n'.OR.TYPROW.EQ.'n ') THEN + GO TO 100 + ENDIF +C +C Invalid row type. + GO TO 9050 +C Continue reading of the ROWS section. + GO TO 100 +C +C Read COLUMNS section. + 200 CONTINUE +C + IF(SECT.NE.'C'.AND.SECT.NE.'c') GO TO 9000 + NAME0=' ' + 220 LINE=LINE+1 + READ(INMPS,1000,END=9000) RDLINE + IF(RDLINE(1:1).EQ.'*'.OR. LNBLNK(RDLINE).EQ.0) GO TO 220 + READ(RDLINE,221,ERR=9000) SECT,NAMCLN,NAMRW1,VAL1,NAMRW2,VAL2 + 221 FORMAT(A1,3X,A8,2X,A8,2X,D12.0,3X,A8,2X,D12.0) + IF(NAMCLN.EQ.NAME0) GO TO 260 +C +C Here if the new column has been found. +C Save the previous column in the LP data structures. +C +C Check if this is the first column. + IF(NAME0.EQ.' ') THEN + NAME0=NAMCLN + COLLEN=0 + NZA=0 + N=1 + GO TO 260 + ENDIF +C + NZA=NZA+COLLEN +C +C Check if there are still columns to be read. + IF(SECT.NE.' ') THEN + RETURN + ELSE +C +C Initialize the new column. + N=N+1 + NAME0=NAMCLN + COLLEN=0 + GO TO 260 + ENDIF +C +C +C Find the position of the nonzero element. + 260 continue + +C Save nonzero element of the N-th column. + IF(DABS(VAL1).LE.SMALLA) GO TO 280 + COLLEN=COLLEN+1 +C +C Check if there is another nonzero read in the analysed line. + 280 IF(NAMRW2.NE.' ') THEN + NAMRW1=NAMRW2 + VAL1=VAL2 + NAMRW2=' ' + GO TO 260 + ELSE + GO TO 220 + ENDIF + +C +C Here when error occurs. + 9000 RCODE=1 + RETURN +C + 9050 RCODE=2 + RETURN +C *** LAST CARD OF (RDMPS1) *** + END + diff --git a/modules/optimization/src/fortran/rdmpsz.lo b/modules/optimization/src/fortran/rdmpsz.lo new file mode 100755 index 000000000..339edae9e --- /dev/null +++ b/modules/optimization/src/fortran/rdmpsz.lo @@ -0,0 +1,12 @@ +# src/fortran/rdmpsz.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rdmpsz.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/rednor.f b/modules/optimization/src/fortran/rednor.f new file mode 100755 index 000000000..79bb058b8 --- /dev/null +++ b/modules/optimization/src/fortran/rednor.f @@ -0,0 +1,21 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + function rednor(n,binf,bsup,x,epsx,g) +c + implicit double precision (a-h,o-z) + dimension binf(n),bsup(n),x(n),epsx(n),g(n) + rednor=0.0d+0 + do 1 i=1,n + aa=g(i) + if(x(i)-binf(i).le.epsx(i))aa=min(0.0d+0,aa) + if(bsup(i)-x(i).le.epsx(i))aa=max(0.0d+0,aa) +1 rednor=rednor + aa**2 + rednor=sqrt(rednor) + end diff --git a/modules/optimization/src/fortran/rednor.lo b/modules/optimization/src/fortran/rednor.lo new file mode 100755 index 000000000..fb04c542b --- /dev/null +++ b/modules/optimization/src/fortran/rednor.lo @@ -0,0 +1,12 @@ +# src/fortran/rednor.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rednor.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/relvar.f b/modules/optimization/src/fortran/relvar.f new file mode 100755 index 000000000..3f7713422 --- /dev/null +++ b/modules/optimization/src/fortran/relvar.f @@ -0,0 +1,89 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine relvar(ind,n,x,binf,bsup,x2,g,diag,imp,io,ibloc,izag, + &iter,nfac,irit) +c +c determination des variables a relacher par meth bertsekas + implicit double precision (a-h,o-z) + dimension x(n),binf(n),bsup(n),x2(n),g(n),ibloc(n),diag(n) + character bufstr*(4096) +c x2 vect de travail de dim n +c ind: =1 si relachement des vars +c =0 sinon +c +c calcul eps1 + do 10 i=1,n +10 x2(i)=x(i)-abs(g(i))*g(i)/diag(i) + call proj(n,binf,bsup,x2) + eps1=0. + do 20 i=1,n +20 eps1=eps1 + abs(x2(i)-x(i)) + if(imp.gt.2) then + write(bufstr,322) eps1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +322 format(' relvar1. valeur de eps1=',d15.7) +c nfac nombre de lignes factorisees (nr pour ajournd) + ifac=0 + idfac=0 + k=0 + frac=1./10. + do 340 k=1,n + bi=binf(k) + bs=bsup(k) + d1=x(k)-bi + d2=bs-x(k) + dd=(bs-bi)*frac + ep=min(eps1,dd) + if(d1.gt.ep)go to 324 + if(g(k).gt.0.)go to 330 + go to 335 +324 if(d2.gt.ep)go to 335 + if(g(k).gt.0.)go to 335 + go to 330 +c on defactorise si necessaire +330 continue + if(ibloc(k).gt.0)go to 340 + ibloc(k)=iter + idfac=idfac+1 + nfac=nfac-1 + ind=1 + if(imp.ge.4) then + write(bufstr,336)k,x(k) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +336 format(' defactorisation de x(',i3,')=',d15.7) + go to 340 +c on factorise +335 continue + if(irit.eq.0) go to 340 + if(ibloc(k).le.0)go to 340 + izag1=iter-ibloc(k) + if(izag.ge.izag1)go to 340 + ifac=ifac+1 + nfac=nfac+1 + ibloc(k)=-iter + if(imp.ge.4) then + write(bufstr,339)k + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +339 format(' on factorise l indice ',i3) +340 continue + if(imp.ge.2.and.(ifac.gt.0.or.idfac.gt.0)) then + write(io,350)ifac,idfac,nfac + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + +350 format(' relvar1 . nbre fact',i3,' nbre defact',i3,' nbre var + &factorisees',i3) + ind=1 + if(ifac.eq.0.and.idfac.eq.0)ind=0 + return + end diff --git a/modules/optimization/src/fortran/relvar.lo b/modules/optimization/src/fortran/relvar.lo new file mode 100755 index 000000000..86a6b9663 --- /dev/null +++ b/modules/optimization/src/fortran/relvar.lo @@ -0,0 +1,12 @@ +# src/fortran/relvar.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/relvar.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/rlbd.f b/modules/optimization/src/fortran/rlbd.f new file mode 100755 index 000000000..142fbc7de --- /dev/null +++ b/modules/optimization/src/fortran/rlbd.f @@ -0,0 +1,530 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 1988 - INRIA - F. BONNANS +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine rlbd(indrl,n,simul,x,binf,bsup,f,hp,t,tmax,d,gn, + & tproj,amd,amf,imp,io,zero,nap,napmax,xn,izs,rzs,dzs) +c +c!but +c subroutine de recherche lineaire pour des problemes avec +c contraintes de borne (traitees par projection) +c le critere de retour est une extension de celui de wolfe +c!methode +c pour chaque valeur du parametre t , sont calcules le critere +c et son gradient. +c une phase d extrapolation permet d obtenir un encadrement. +c l intervalle est ensuite reduit suivant les cas par une methode +c de dichotomie, d interpolation lineaire sur les derivees ou +c d interpolation cubique. +c +c!impressions +c si imp > 2 , rlbd fournit les impressions suivantes : +c +c la premiere ligne indique : +c t premiere valeur de t fournie en liste d' appel +c tproj plus petit t > 0 pour lequel on bute sur une borne +c dh/dt derivee en zero de h(t)=f(x+t*d)-f(x) +c tmax valeur maximale de t fournie en liste d' appel +c +c lignes suivantes : +c chaine de caracteres en debut de ligne : indique comment sera calcule +c le pas de la ligne suivante ; +c ic : interpolation cubique +c s : saturation d une variable sur une borne +c id : interpolation lineaire sur la derivee +c e : extrapolation +c d :interpolation cubique ayant echouee t est calcule par dichotomie +c b :sauvegarde de convergence active +c +c!subroutines utilisees +c proj et satur (bibl. modulopt) +c!liste d appel +c +c subroutine rlbd(indrl,n,simul,proj,x,binf,bsup,f,hp,t,tmax,d,gn, +c & tproj,amd,amf,imp,io,zero,nap,napmax,xn,izs,rzs,dzs) +c +c e;s;e,s:parametres initialises en entree,en sortie,en entree et +c en sortie +c indrl<0:la recherche lineaire n a pas trouve de meilleur pas(e,s) +c =0:arret demande par l'utilisateur dans simul +c >0:meilleur pas fourni avec f et g +c >9:meilleur pas fourni avec f et sans g +c =14:deltat trop petit +c =13:nap=napmax +c =8:toutes les variables sont saturees +c =4:deltat trop petit +c =3:nap=napmax +c =2:t=tmax +c =1:descente serieuse avec t<tmax +c =0:arret demande par l'utilisateur +c =-3:nap=napmax +c =-4:deltat trop petit +c =-1000+indic:nap=napmax et indic<0 +c n:dimension de x (e,s) +c simul: subroutine fournissant le critere et le gradient (e) +c x:valeur initiale de la variable a optimiser en entree;valeur a +c l optimum en sortie. (e,s) +c binf,bsup:bornes inf et sup de dimension n (e,s) +c f:valeur du critere en x (e,s) +c hp:derivee de f(x+t*d) par rapport a t en 0 (e) +c t:pas (e) +c tmax:valeur maximal du pas (e,s) +c d:direction de descente (e) +c gn: gradient de f en xn (e,s) +c tproj:plus petit pas saturant une nouvelle contrainte(e,s) +c amf,amd:constantes du test de wolfe (e) +c imp<=2:pas d'impression (e) +c >=3:une impression par calcul de simul (e) +c io:numero du fichier resultat (e) +c zero:proche du zero machine (e) +c nap:nombre d'appel a simul (e) +c napmax:nombre maximum d'appel a simul (e) +c xn:tableau de travail de dimension n (=x+t*d) +c izs,rzs,dzs:cf norme modulopt (e,s) +c! +c parametres de l algorithme +c eps1:sauvegarde de conv.dans l interpolation lineaire sur la derivee +c eps:sauvegarde de conv.dans la l interpolation par saturation +c d une contrainte. +c epst:sauvegerde de conv.dans l interpolation cubique +c extra,extrp:servent a calculer la limite sur la variation relative +c de t dans l extrapolation et l interpolation lineaire sur la derivee +c cofder: intervient dans le choix entre les methodes d' interpolation +c +c variables de travail +c fn:valeur du critere en xn +c hpn:derivee de f(x+t*d) par rapport a t +c hpd:valeur de hpn a droite +c hpg:valeur de hpn a gauche +c td:pas trop grand +c tg:pas trop petit +c tproj:plus petit pas saturant une contrainte +c tmaxp:plus grand pas saturant une contraite +c ftd:valeur de f en x+td*d +c ftg:valeur de f en x+tg*d +c hptd:valeur de hpn en x+td*d +c hptg:valeur de hpn en x+tg*d +c imax=1:tmax a ete atteint +c =0:tmax n a pas ete atteint +c icos:indice de la variable saturee par la borne superieure +c icoi:indice de la variable saturee par la borne inferieure +c ico1:indice de la variable saturee en tmaxp +c icop:indice de la variable saturee en tproj +c + implicit double precision(a-h,o-z) + external simul,proj + character var2*3 + dimension x(n),xn(n),gn(n),d(n),binf(n),bsup(n),izs(*) + double precision dzs(*) + character bufstr*(4096) + real rzs(*) +c + indrl=1 + eps1=.90d+0 + eps=.10d+0 + epst=.10d+0 + extrp=100.0d+0 + extra=10.0d+0 + cofder=100. + var2=' ' +c + ta1=0.0d+0 + f0=f + fa1=f + hpta1=hp + imax=0 + hptg=hp + ftg=f + tg=0.0d+0 + td=0.0d+0 + icos=0 + icoi=0 + icop=0 +c +c calcul de tproj:plus petit point de discontinuite de h'(t) + tproj=0.0d+0 + do 7 i=1,n + CRES=d(i) + if (CRES .lt. 0) then + goto 4 + elseif (CRES .eq. 0) then + goto 7 + else + goto 5 + endif +4 t2=(binf(i)-x(i))/d(i) + go to 6 +5 t2=(bsup(i)-x(i))/d(i) +6 if (t2.le.0.0d+0) go to 7 + if (tproj.eq.0.0d+0) tproj=t2 + if (t2.gt.tproj) go to 7 + tproj=t2 + icop=i +7 continue +c + if (imp.ge.3) then + write (bufstr,14050) tproj,tmax,hp + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +14050 format (' rlbd tp=',e11.4, + & ' tmax=',e11.4,' dh0/dt=',e11.4 ) +15000 format (a3,' t=',e11.4,' h=',e11.4,' dh/dt=',e11.4, + & ' dfh/dt=', e11.4,' dt',e8.1) +15020 format (3x,' t=',e11.4,' h=',e11.4,' dh/dt=',e11.4, + & ' dfh/dt=', e11.4,' dt',e8.1) +16000 format (' rlbd : sortie du domaine : indic=',i2,' t=',e11.4) +c +c boucle +c +c calcul de xn,de fn et de gn +200 if (nap.ge.napmax) then + k=3 + goto 1000 + end if + do 230 i=1,n +230 xn(i)=x(i)+t*d(i) + call proj (n,binf,bsup,xn) + if (icos.gt.0) xn(icos)=bsup(icos) + if (icoi.gt.0) xn(icoi)=binf(icoi) + indic=4 + call simul (indic,n,xn,fn,gn,izs,rzs,dzs) + nap=nap+1 + if (indic.lt.0) then + if (imp.ge.3) then + write (bufstr,16000) indic,t + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if (nap.ge.napmax) go to 1000 + t=tg+(t-tg)/4.0d+0 + tmax=t + imax=1 + icoi=0 + icos=0 + var2='dd ' + go to 800 + endif + if(indic.eq.0) then + indrl=0 + go to 1010 + endif +c +c calcul de hpg et hpd + hpg=0.0d+0 + do 242 i=1,n +242 xn(i)=x(i)+t*d(i) + if (icoi.gt.0) xn(icoi)=bsup(icoi) + if (icos.gt.0) xn(icos)=bsup(icos) + call proj(n,binf,bsup,xn) + do 244 i=1,n + xni=xn(i) +244 if(binf(i).lt.xni.and.xni.lt.bsup(i)) hpg=hpg + d(i)*gn(i) + hpd=hpg + if(icoi.gt.0) hpg=hpg + d(icoi)*gn(icoi) + if(icos.gt.0) hpg=hpg + d(icos)*gn(icos) +c + icoi=0 + icos=0 + if((hpd.ne.0.0d+0).or.(hpg.ne.0.0d+0)) go to 360 +c +c la derivee de h est nulle +c calcul du pas saturant toutes les bornes:tmaxp + tmaxp=0.0d+0 + ico1=0 + do 350 i=1,n + CRES=d(i) + if (CRES .lt. 0) then + goto 310 + elseif (CRES .eq. 0) then + goto 350 + else + goto 320 + endif +310 t2=(binf(i)-x(i))/d(i) + go to 330 +320 t2=(bsup(i)-x(i))/d(i) +330 if (t2.le.0.0d+0) go to 350 + if (tmaxp.eq.0.0d+0) tmaxp=t2 + if (tmaxp.gt.t2)go to 350 + tmaxp=t2 + ico1=i +350 continue + if (t.lt.tmaxp) then + if(fn.le.f+amf*hp*t) goto 1010 + t=t/10.0d+0 + var2='d ' + goto 800 + end if + icos=ico1 + icoi=0 + if (d(ico1).lt.0.0d+0) then + icoi=ico1 + icos=0 + end if +c +c toutes les variables sont saturees + if (imp.ge.3) then + write (bufstr,3330) tmaxp + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +3330 format ('toutes les variables sont saturees:tmaxp= ',e11.4) + t=tmaxp + if (fn.lt.f+amf*hp*tmaxp) then + indrl=8 + goto 1010 + end if + hpg=d(ico1)*gn(ico1) + if ((fn.lt.f).and.(hpg.lt.0.0d+0)) then + indrl=8 + goto 1010 + end if +360 continue +c +c test de wolfe +c + a=f+amf*hp*t + if (fn.gt.a) then +c le pas est trop grand +c (dans le cas quadratique changer eps1 et extra si td<tproj) + td=t + t1=t-ta1 + h1=(fn-fa1)/t1 + ftd=fn + hptd=hpg + ta=tg + hpn=hptd + hpa=hptg + fa=ftg + else + if (hpd.ge.(amd*hp)) go to 1010 +c le pas est trop petit + tg=t + t1=t-ta1 + h1=(fn-fa1)/t1 + ftg=fn + hptg=hpd + ta=td + hpn=hptg + hpa=hptd + fa=ftd + if (td.eq.0.0d+0) go to 700 + a1=abs(hptd/hp) + if ((a1.gt.cofder).and.(ftd.gt.f).and.(hptg.gt.(.99*hp))) + & then + hpta1=hp + fa1=f + ta1=0.0d+0 + go to 700 + end if + endif + a1=abs(hpn/hp) + if ((tg.ne.0.0d+0).or.(fn.le.f).or.(a1.le.cofder).or. + & (hpn.lt.0.0d+0)) then + if (td.le.tproj) go to 600 + go to 500 + end if +c +c calcul du nouveau t +c +c par interpolation lineaire sur la derivee +c + ta1=t + fa1=fn + div=hp-hptd + text=t/10.0d+0 + if(abs(div).gt.zero) text=t*(hp/div) + if (text.gt.tproj) text=t/10.0d+0 + text=max(text,t/(extrp*extra)) + t=min(text,t*eps1) + ttsup=1.50d+0*t + extrp=10. + if (tproj.gt.ta1) then + var2='id ' + go to 800 + end if + ttmin=0.70d+0*t + tmi=t + topt=0.0d+0 + iproj=0 + call satur(n,x,binf,bsup,d,ttmin,ttsup,topt,tg,td,tmi, + & icoi,icos,iproj) + var2='id ' + if (topt.ne.0.0d+0) then + t=topt + var2='ids' + end if + go to 800 +c +c interpolation par saturation d une contrainte +c +500 if (td.le.tproj) go to 600 + topt=0.0d+0 + iproj=1 + ta1=t + fa1=fn + ttmin=tg+eps*(td-tg) + ttsup=td-eps*(td-tg) + tmi=(td+tg)/2.0d+0 + call satur(n,x,binf,bsup,d,ttmin,ttsup,topt,tg,td,tmi, + & icoi,icos,iproj) + if (topt.eq.0.0d+0) go to 600 + t=topt + var2='s ' + if (t.eq.ttsup.or.t.eq.ttmin) var2='sb ' + go to 800 +c +c interpolation cubique +c +c test de securite +600 if ((td-tg).lt.1.0d+2*zero) then + k=4 + goto 1000 + end if +c +c calcul du minimum + b=1.0d+0 + p=hpn+hpa-3.0d+0*(fn-fa)/(t-ta) + di=p*p-hpn*hpa + if (di.lt.0.0d+0) go to 690 + if ((t-ta).lt.0.0d+0) b=-1 + div=hpn+p+b*sqrt(di) + if (abs(div).le.zero) go to 690 + r=hpn/div + topt=t-r*(t-ta) + if ((topt.lt.tg).or.(topt.gt.td))go to 690 +c +c sauvegarde de convergence + e=epst*(td-tg) + var2='ic ' + if (topt.gt.(td-e)) then + topt=td-e + var2='icb' + end if + if (topt.lt.(tg+e)) then + topt=tg+e + var2='icb' + end if + ta1=t + fa1=fn + t=topt + goto 800 +690 ta1=t + fa1=fn + t=0.50d+0*(tg+td) + var2='d ' + go to 800 +c +c extrapolation +c +700 if (imax.ge.1) then + k=2 + goto 1000 + end if + text=10.0d+0*t + difhp=hptg-hpta1 + if (difhp.gt.zero)then + text=(amd*hp/3.0d+0-hptg)*((tg-ta1)/difhp)+tg + if ((td.ne.0.0d+0).and.(text.ge.td)) go to 600 +c dans le cas quadratique prendre extrp plus grand + text=min(text,extra*extrp*t) + text=max(text,2.50d+0*t) + else + text=extra*extrp*t + end if + ta1=t + fa1=fn + hpta1=hpn + extrp=10. + if (text.ge.tmax/2.0d+0) then + text=tmax + imax=1 + end if + if ((t.lt.tproj).and.(text.gt.tproj)) then + t=max(tproj,2.50d+0*t) + icoi=0 + icos=icop + if(d(icop).lt.0.0d+0) then + icoi=icop + icos=0 + end if + var2='es ' + goto 800 + end if + ttsup=min(1.50d+0*text,tmax) + if (ttsup.lt.tproj) go to 785 + ttmin=2*t + iproj=0 + tmi=text + topt=0.0d+0 + call satur(n,x,binf,bsup,d,ttmin,ttsup,topt,tg,td,tmi, + & icoi,icos,iproj) + if (topt.gt.0.0d+0)then + t=topt + var2='es ' + go to 800 + endif +785 t=text + var2='e ' +800 f11=fn-f + if (imp.ge.3.and.indic.gt.0) then + write (bufstr,15000)var2,ta1,f11,hpn,h1,t1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +c +c test sur deltat + if(abs(ta1-t).ge.1.0d+2*zero) go to 200 + k=4 +c calcul de indrl +1000 if (indic.lt.0) then + indrl=13 + if (tg.eq.0.0d+0) indrl=-1000+indic + fn=ftg + hpn=hptg + t=tg + go to 1010 + endif + if (fn.le.ftg) then + indrl=k + t=tg + go to 1010 + end if + if (tg.eq.0.0d+0) then + indrl=-1*k + go to 1010 + end if + indrl=10+k + t=tg + fn=ftg + hpn=hptg +c +c fin du programme +1010 f=fn + do 810 i=1,n +810 x(i)=x(i)+t*d(i) + call proj(n,binf,bsup,x) + if (icos.gt.0) x(icos)=bsup(icos) + if (icoi.gt.0) x(icoi)=binf(icoi) +c + if (indrl.lt.0) then + nap=nap+1 + indic=4 + call simul (indic,n,x,f,gn,izs,rzs,dzs) + endif +c + t1=t-ta1 + if (t1.eq.0.0d+0) then + t1=1. + end if + h1=(fn-fa1)/t1 + hp=hpd + f0=f-f0 + if (imp.ge.3) then + write (bufstr,15020)t,f0,hpd,h1,t1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + end diff --git a/modules/optimization/src/fortran/rlbd.lo b/modules/optimization/src/fortran/rlbd.lo new file mode 100755 index 000000000..9f8b7d976 --- /dev/null +++ b/modules/optimization/src/fortran/rlbd.lo @@ -0,0 +1,12 @@ +# src/fortran/rlbd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/rlbd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/satur.f b/modules/optimization/src/fortran/satur.f new file mode 100755 index 000000000..826451364 --- /dev/null +++ b/modules/optimization/src/fortran/satur.f @@ -0,0 +1,75 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine satur (n,x,binf,bsup,d,ttmin,ttsup,topt,tg,td, + & tmi,icoi,icos,iproj) +c +c subroutine calculant ,dans un intervalle donne, un pas proche +c de tmi saturant une contrainte +c topt:pas calculer (=0 s'il n'existe pas un tel pas (s) +c ttmin,ttsup:bornes de l'intervalle dans lequel doit +c etre topt (e) +c tmi:pas au voisinnage duquel on calcul topt (e) +c iproj:indicateur de projection (e) +c =0:on cherche un pas saturant une contrainte dans +c l'intervalle ttmin,ttsup +c =1:on cherche un pas dans l'intervalle tg,td et on +c le ramene dans l'intervalle ttmin,ttsup +c par projection +c icos:indice de la variable saturee par la borne superieure +c icoi:indice de la variable saturee par la borne inferieure +c inf:indicateur pour l initialisation de icoi et icos +c =0:la borne superieure est atteinte +c =1:la borne superieure est atteinte +c =2:le pas est obtenu par projection sur ttmin ttsup +c + implicit double precision(a-h,o-z) + integer iproj + dimension x(n),binf(n),bsup(n),d(n) +c + icoi=0 + icos=0 + ep=tmi +c +c boucle + do 70 i=1,n + inf=0 +c calcul du pas saturant la ieme contrainte:tb + CRES=d(i) + if (CRES .lt. 0) then + goto 61 + elseif (CRES .eq. 0) then + goto 70 + else + goto 62 + endif +61 tb=(binf(i)-x(i))/d(i) + inf=1 + go to 63 +62 tb=(bsup(i)-x(i))/d(i) +63 if ((tb.gt.ttsup).or.(tb.lt.ttmin))then +c projection de tb sur l intervalle ttmin,ttsup + if ((iproj.eq.0).or.(tb.lt.tg).or.(tb.gt.td)) go to 70 + tb=max(tb,ttmin) + tb=min(tb,ttsup) + inf=2 + end if +c recherche du pas le plus proche de tmi + e=abs(tb-tmi) + if (e.ge.ep) go to 70 + topt=tb + ep=e +c mise a jour de icoi,icos + icoi=0 + icos=0 + if (inf.eq.0) icos=i + if (inf.eq.1) icoi=i +70 continue + return + end diff --git a/modules/optimization/src/fortran/satur.lo b/modules/optimization/src/fortran/satur.lo new file mode 100755 index 000000000..21c04693e --- /dev/null +++ b/modules/optimization/src/fortran/satur.lo @@ -0,0 +1,12 @@ +# src/fortran/satur.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/satur.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/shanph.f b/modules/optimization/src/fortran/shanph.f new file mode 100755 index 000000000..b6426f071 --- /dev/null +++ b/modules/optimization/src/fortran/shanph.f @@ -0,0 +1,37 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + + subroutine shanph(diag,n,nt,np,y,s,ys,scal,index,io,imp) +c mise a l echelle de diag par la methode de shanno-phua +c calcul du facteur d echelle scal +c diag=(y,(diag-1)y)/(y,s)*diag +c + implicit double precision (a-h,o-z) + dimension diag(n),y(nt,n),s(nt,n),ys(nt),index(nt) + character bufstr*(4096) + + inp=index(np) + cof=0. + do 203 i=1,n +203 cof=cof + y(inp,i)**2/diag(i) + cof=cof/ys(inp) + if(imp.gt.3) then + write(bufstr,1203) cof + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1203 format(' gcbd. facteur d echelle=',d15.7) + do 205 i=1,n +205 diag(i)=cof*diag(i) + scal=0. + do 206 i=1,n +206 scal=scal + diag(i) + scal=n/scal + return + end diff --git a/modules/optimization/src/fortran/shanph.lo b/modules/optimization/src/fortran/shanph.lo new file mode 100755 index 000000000..a3583d347 --- /dev/null +++ b/modules/optimization/src/fortran/shanph.lo @@ -0,0 +1,12 @@ +# src/fortran/shanph.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/shanph.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/strang.f b/modules/optimization/src/fortran/strang.f new file mode 100755 index 000000000..c7566434e --- /dev/null +++ b/modules/optimization/src/fortran/strang.f @@ -0,0 +1,83 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine strang(prosca,n,m,depl,jmin,jmax,precon,alpha,ybar, + / sbar,izs,rzs,dzs) +c---- +c +c Calcule le produit H g ou +c . H est une matrice construite par la formule de bfgs inverse +c a m memoires a partir de precon fois la matrice unite dans +c un espace hilbertien dont le produit scalaire est donne par +c prosca +c (cf. J. Nocedal, math. of comp. 35/151 (1980) 773-782) +c . g est un vecteur de dimension n (en general le gradient) +c +c Le facteur precon apparait donc comme un preconditionneur +c scalaire. +c +c delp = g (en entree), = H g (en sortie) +c +c La matrice H est memorisee par les vecteurs des tableaux +c ybar, sbar et les pointeurs jmin, jmax. +c +c alpha(m) est une zone de travail. +c +c izs(1),rzs(1),dzs(1) sont des zones de travail pour prosca +c +c---- +c +c arguments +c + integer n,m,jmin,jmax,izs(*) + real rzs(*) + double precision depl(n),precon,alpha(m),ybar(n,m),sbar(n,m) + double precision dzs(*) + external prosca +c +c variables locales +c + integer jfin,i,j,jp + double precision r + double precision ps +c + jfin=jmax + if (jfin.lt.jmin) jfin=jmax+m +c +c phase de descente +c + do 100 j=jfin,jmin,-1 + jp=j + if (jp.gt.m) jp=jp-m + call prosca (n,depl,sbar(1,jp),ps,izs,rzs,dzs) + alpha(jp)=ps + do 20 i=1,n + depl(i)=depl(i)-ps*ybar(i,jp) +20 continue +100 continue +c +c preconditionnement +c + do 150 i=1,n + depl(i)=depl(i)*precon +150 continue +c +c remontee +c + do 200 j=jmin,jfin + jp=j + if (jp.gt.m) jp=jp-m + call prosca (n,depl,ybar(1,jp),ps,izs,rzs,dzs) + r=alpha(jp)-ps + do 120 i=1,n + depl(i)=depl(i)+r*sbar(i,jp) +120 continue +200 continue + return + end diff --git a/modules/optimization/src/fortran/strang.lo b/modules/optimization/src/fortran/strang.lo new file mode 100755 index 000000000..7ca61695d --- /dev/null +++ b/modules/optimization/src/fortran/strang.lo @@ -0,0 +1,12 @@ +# src/fortran/strang.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/strang.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/writebuf.f b/modules/optimization/src/fortran/writebuf.f new file mode 100755 index 000000000..f59990fe3 --- /dev/null +++ b/modules/optimization/src/fortran/writebuf.f @@ -0,0 +1,92 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) 2007-2008 - INRIA - Allan CORNET +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt + +c ==================================== +c required by f2c :( +c ==================================== + subroutine writebufbjsqrsolv(buffer,r1,r2,r3) + + character*(*) buffer + double precision r1 + double precision r2 + double precision r3 + + write(buffer(1:13),'(3i4)') r1,r2,r3 + + end +c ==================================== + subroutine writebufbjsolv(buffer,r1,r2,r3) + + character*(*) buffer + double precision r1 + double precision r2 + double precision r3 + + write(buffer(1:12),'(3i4)') r1,r2,r3 + + end +c ==================================== + subroutine writebufbsolv(buffer,r1,r2,r3) + + character*(*) buffer + double precision r1 + double precision r2 + double precision r3 + + write(buffer(1:12),'(3i4)') r1,r2,r3 + + end +c ==================================== + subroutine writebufblsqrsolv(buffer,r1,r2,r3) + + character*(*) buffer + double precision r1 + double precision r2 + double precision r3 + + write(buffer(1:12),'(3i4)') r1,r2,r3 + + end +c ==================================== + subroutine writebufscioptim(buffer,r1) + + character*(*) buffer + double precision r1 + +c Initialize the buffer with empty blanks +c write(buffer(:),'(a)') " " +c What is the p format edit descriptor ? +c write(buffer(1:15),'(1pd15.7)') r1 + write(buffer(1:15),'(1d15.7)') r1 + + end +c ==================================== + + subroutine writebufspa(buffer,fname,line) + + character*(*) buffer + character*(*) fname + integer line + + write(buffer,'(A,'': Error while reading line '',I5)') fname,line + + end +c ==================================== + subroutine writebufspb(buffer,fname,typrow,line) + + character*(*) buffer + character*(*) fname + character*(*) typrow + integer line + + write(buffer,'(A,''Unknown row type '',a2,'' at line '',I5)') + $ fname,typrow,line + + end +c ==================================== diff --git a/modules/optimization/src/fortran/writebuf.lo b/modules/optimization/src/fortran/writebuf.lo new file mode 100755 index 000000000..cc24d4394 --- /dev/null +++ b/modules/optimization/src/fortran/writebuf.lo @@ -0,0 +1,12 @@ +# src/fortran/writebuf.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/writebuf.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/zgcbd.f b/modules/optimization/src/fortran/zgcbd.f new file mode 100755 index 000000000..407866a26 --- /dev/null +++ b/modules/optimization/src/fortran/zgcbd.f @@ -0,0 +1,516 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine zgcbd(simul,n,binf,bsup,x,f,g,zero,napmax,itmax,indgc + & ,ibloc,nfac,imp,io,epsx,epsf,epsg,dir,df0,diag,x2, + &izs,rzs,dzs,y,s,z,ys,zs,nt,index,wk1,wk2,alg,ialg,nomf) +c + implicit double precision (a-h,o-z) + real rzs(*) + double precision dzs(*) + dimension x2(n),dir(n),epsx(n) + dimension binf(n),bsup(n),x(n),g(n),diag(n),ibloc(n),izs(*) + dimension y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt) + dimension wk1(n),wk2(n),alg(15) + character*6 nomf + integer index(nt),ialg(15) + external simul + character bufstr*(4096) +c + if(imp.ge.4) then + write(bufstr,10000) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +10000 format (' dans gcbd. algorithme utilise: ') + if(ialg(1).eq.1) then + write(bufstr,10001) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10001 format (' emploi correction de powell ') + if(ialg(2).eq.1) then + write(bufstr,10002) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10002 format (' mise a jour de diag par la methode bfgs') + if(ialg(3).eq.1) then + write(bufstr,10003) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10003 format (' mise a echelle de diag par methode de shanno-phua') + if(ialg(3).eq.2) then + write(bufstr,10004) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10004 format (' mise a echelle de diag seulement a la 2e iter') + if(ialg(4).eq.1) then + write(bufstr,10005) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10005 format (' memorisation pour choix iteration ') + if(ialg(5).eq.1) then + write(bufstr,10006) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10006 format (' memorisation par variable') + if(ialg(6).eq.1) then + write(bufstr,10007) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10007 format (' relachememt de variables a toutes les iteration') + if(ialg(6).eq.2) then + write(bufstr,10008) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10008 format (' relachement de vars si decroissance g_norme') + if(ialg(6).eq.10) then + write(bufstr,10009) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10009 format (' relachement de vars si dec f % iter_init du cycle') + if(ialg(6).eq.11) then + write(bufstr,10010) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10010 format (' relachement de vars si dec f % dec du cycle') + if(ialg(7).eq.1) then + write(bufstr,10011) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10011 format (' choix de vars a relacher par bertsekas modifiee') + if(ialg(8).eq.1) then + write(bufstr,10012) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10012 format (' choix de dir descente par methode de gradient') + if(ialg(8).eq.2) then + write(bufstr,10013) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10013 format (' choix de dir descente par methode qn') + if(ialg(8).eq.3) then + write(bufstr,10014) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10014 format (' choix de dir descente par qn sans memoire.nt depl') + if(ialg(8).eq.4) then + write(bufstr,10015) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10015 format (' choix de dir descente par qn -mem,redem,sans acc.') + if(ialg(8).eq.5) then + write(bufstr,10016) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10016 format (' choix de dir descente par qn -mem,redem,avec acc.') + if(ialg(9).eq.2) then + write(bufstr,10017) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10017 format (' redem si relachement de vars') + if(ialg(9).eq.10) then + write(bufstr,10018) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10018 format (' redem si dec f % dec iter_init du cycle') + if(ialg(9).eq.11) then + write(bufstr,10019) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10019 format (' redem si dec f % dec totale du cycle.') + if(ialg(9).eq.12) then + write(bufstr,10020)alg(9) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +10020 format (' redem si diminution du gradient des var libres d un', + & 'facteur',d11.4) + endif +c +c section 1 initialisations +c irl nombre de rech lin 'lentes' +c nred nombre de redemarrage de la direction de descente +c icycl nombre de cycles de minimisation +c + epsgcp=1.0d-5 + indsim=4 + indrl=1 + irl=0 + irl=0 + nred=1 + icycl=1 + nap=0 +c + iresul=1 + call proj(n,binf,bsup,x) + indsim=4 + call simul(indsim,n,x,f,g,izs,rzs,dzs) + nap=nap+1 + if(indsim.gt.0)go to 99 + indgc=-1 + if(indsim.eq.0)indgc=0 + if(imp.gt.0) then + write(bufstr,123)indgc + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + go to 900 +99 continue + ceps0=20.0d+0 + eps0=0.0d+0 + do 100 i=1,n +100 eps0=eps0+epsx(i) + eps0=ceps0*eps0/n +c +c calcul de zng + znog0=rednor(n,binf,bsup,x,epsx,g) + zng=znog0 + zngrit=znog0 + zngred=znog0 +c + do 130 i=1,n +130 ibloc(i)=0 + izag=3 + izag1=izag + nap=0 + iter=0 + scal=1.0d+0 + nfac=n + np=0 + lb=1 + nb=2 + if(ialg(8).eq.3) nb=1 + do 140 i=1,nt +140 index(i)=i + tetaq=alg(9) + condm=alg(2) + param=alg(1) + indgc1=indgc +c si indgc=0 on init diag a k*ident puis scal a it=2 +c + if(indgc.eq.1.or.indgc.ge.100)go to 150 + if(indgc.eq.2)go to 180 + indgc=-13 + if(imp.gt.0) then + write(bufstr,123) indgc + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + go to 900 +c +150 continue +c on initialise diag par approximation quadratique +c df0 decroissance prevue . si mod quad df0=((dh)-1g,g)/2 +c et on cherche dh diag de la forme cst/(dx)**2 +c donc cst=som((g(i)*(dx))**2))/(2*df0) + sy=0.0d+0 + do 160 i=1,n +160 sy=sy+(g(i)*epsx(i))**2 + sy=sy/(2.0d+0*df0) + do 170 i=1,n +170 diag(i)=(sy + zero)/(epsx(i)**2 + zero) +180 continue +c +c +c bouclage +200 iter=iter +1 + indgc=1 + if(iter.gt.itmax)then + indgc=5 + go to 900 + endif +201 continue + if(imp.ge.2) then + write(bufstr,1210)iter,f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1210 format(' dans gcbd iter=',i3,' f=',d15.7) + if(iter.eq.1)then + irit=1 + goto 301 + endif +c + call majysa(n,nt,np,y,s,ys,lb,g,x,wk2,wk1,index,ialg,nb) + inp=index(np) +c +c +c correction powell sur y si (y,s) trop petit + if(ialg(1).ne.1) go to 290 + param1=1.-param + bss=0.0d+0 + do 260 i=1,n +260 bss=bss + diag(i)*s(inp,i)**2 + bss2=param*bss + if(ys(inp).gt.bss2)go to 290 + if(imp.gt.2) then + write(bufstr,1270) ys(inp) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1270 format(' gcbd. emploi correction powell (y,s)=',d11.4) + teta=param1*bss/(bss-ys(inp)) + teta1=1.0d+0-teta + do 274 i=1,n +274 y(inp,i)=teta*y(inp,i)+teta1*diag(i)*s(inp,i) + ys(inp)=bss2 +c verif correction powell (facultatif; faire go to 300) + ys1=ddot(n,s(inp,1),1,y(inp,1),1) + ys1=abs(bss2-ys1)/bss2 + if(imp.gt.2) then + write(bufstr,1280) ys1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1280 format(' erreur relative correction powell =',d11.4) +c +c mise a jour de diag +290 continue + if(ialg(2).eq.1) + & call bfgsd(diag,n,nt,np,y,s,ys,condm,param,zero,index) +c + if(ialg(3).eq.1.or.(ialg(3).eq.2.and.iter.eq.2)) + & call shanph(diag,n,nt,np,y,s,ys,scal,index,io,imp) +c + call majz(n,np,nt,y,s,z,ys,zs,diag,index) +c +c section 3 determination des variables libres et bloquees +300 continue +c -----decision de relachement a l'iteration courante +c relachement si irit=1 (sinon irit=0) + irit=0 + if(ialg(6).eq.1) irit=1 + if(ialg(6).eq.2.and.znglib.le.alg(6)*zngrit)irit=1 + if(ialg(6).eq.10.and.diff.le.dfrit1*alg(6))irit=1 + if(ialg(6).eq.11.and.diff.le.difrit*alg(6))irit=1 + if(irit.eq.1) nred=nred+1 +c ----choix des variables a relacher + imp1=imp +301 if(ialg(7).eq.1)call relvar(ind,n,x,binf,bsup,x2,g,diag, + & imp,io,ibloc,izag,iter,nfac,irit) +c +c +c section 4 expression de dir + if (np.eq.0) then + do 400 i=1,n + dir(i)=-g(i)/diag(i) +400 continue + else + do 410 i=1,n + dir(i)=-scal*g(i) +410 continue + call gcp(n,index,ibloc,np,nt,y,s,z,ys,zs,diag,g,dir,wk1, + & wk2,epsgcp) + endif +c +c section 5 redemarrage +c + if(ialg(8).eq.4.or.ialg(8).eq.5) then + ired=0 + if(ialg(9).eq.2.and.ind.eq.1) ired=1 + if(ialg(9).eq.10.and.diff.lt.dfred1*tetaq) ired=1 + if(ialg(9).eq.11.and.diff.lt.difred*tetaq) ired=1 + if(ialg(9).eq.12.and.znglib.le.tetaq*zngred) ired=1 + if(ired.eq.1) then + icycl=icycl+1 + np=0 + lb=1 + if(imp.gt.2) then + write(bufstr,1000) icycl + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1000 format (' redemarrage. icycl=',i5) + endif + endif +c +c section 6 annulation de d(i) , i dans ib + if(ialg(6).eq.1)go to 640 + do 630 i=1,n +630 if(ibloc(i).gt.0) dir(i)=0.0d+0 +640 continue +c +c recherche lineaire +c conservation de x et g dans wk1 et wk2 + call dcopy(n,x,1,wk1,1) + call dcopy(n,g,1,wk2,1) +c calcul de la derivee dans la direction dir + ifp=0 + fn=f + znog0=zng +702 dfp=0.0d+0 + do 710 i=1,n + epsxi=epsx(i) + xi=x(i) + diri=dir(i) + if(xi-binf(i).le.epsxi.and.diri.lt.0.0d+0)dir(i)=0.0d+0 +710 if(bsup(i)-xi.le.epsxi.and.diri.gt.0.0d+0)dir(i)=0.0d+0 + dfp=ddot(n,g,1,dir,1) + if(-dfp.gt.0)go to 715 + if(ifp.eq.1) then + indgc=6 + go to 900 + endif +c restauration dir + if(imp.ge.3) then + write(bufstr,1712)dfp,zero + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1712 format(' gcbd : restauration dir ; fp,zero',2d11.4) + do 712 i=1,n +712 dir(i)=-scal*g(i) + ifp=1 + go to 702 +715 continue +c pas initial suivant idee fletcher + t=-2.0d+0*diff/dfp + if(iter.eq.1)t=-2.0d+0*df0/dfp + tmax=1.0d+10 + t=min(t,tmax) + t=max(t,1.0d+10*zero) + napm=15 + napm1=nap + napm + if(napm1.gt.napmax) napm1=napmax + napav=nap + amd=0.70d+0 + amf=0.10d+0 +c + call rlbd(indrl,n,simul,x,binf,bsup,f,dfp,t,tmax,dir,g,tproj, + & amd,amf,imp,io,zero,nap,napm1,x2,izs,rzs,dzs) + if(imp.gt.2) then + write(bufstr,750)indrl,t,f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +750 format(' retour mlibd indrl=',i6,' pas= ',d11.4,' f= ',d11.4) + if(nap-napav.ge.5) irl=irl+1 + if(indrl.ge.10)then + indsim=4 + nap=nap + 1 + call simul(indsim,n,x,f,g,izs,rzs,dzs) + if(indsim.le.0)then + indgc=-3 + if(indsim.eq.0)indgc=0 + if(imp.gt.0) then + write(bufstr,123)indgc + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +123 format(' gcbd : retour avec indgc=',i8) + go to 900 + endif + endif + if(indrl.le.0)then + indgc=10 + if(indrl.eq.0)indgc=0 + if(indrl.eq.-3)indgc=13 + if(indrl.eq.-4)indgc=12 + if(indrl.le.-1000)indgc=11 + if(imp.gt.0) then + write(bufstr,123)indgc + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + go to 900 + endif + if(imp.ge.5) then + do 760 i=1,n +760 if(imp.gt.2) write(io,777)i,x(i),g(i),dir(i) +777 format(' i=',i2,' xgd ',3f11.4) + + endif +c + if(nap.lt.napmax)go to 758 + if(imp.gt.0) then + write(bufstr,755) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +755 format(' gcbd max appels simul') + indgc=4 + go to 900 +758 continue +c +c section 8 test de convergence + do 805 i=1,n + if(abs(x(i)-wk1(i)).gt.epsx(i))go to 806 +805 continue + if(imp.gt.0) then + write(bufstr,1805) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1805 format(' gcbd. retour apres convergence sur x') + indgc=3 + go to 900 +c calcul grad residuel,norme l2 +806 continue + difg=rednor(n,binf,bsup,x,epsx,g) + diff=fn-f + if(imp.ge.2) then + write(bufstr,860)epsg,difg,epsf,diff,nap + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +860 format(' gcbd. epsg,difg=',2d11.4,' epsf,diff=',2d11.4 + &,' nap=',i3) +c + if(diff.le.epsf) then + indgc=2 + go to 900 + endif + if(difg.le.epsg) then + indgc=1 + go to 900 + endif +c +c -----mise a jour de difrit,dfrit1,difred,dfred1 + if(irit.eq.1) then + difrit=diff + dfrit1=diff + else + difrit=difrit+diff + endif + if(ired.eq.1) then + difred=diff + dfred1=diff + else + difred=difred + diff + endif +c + znglib=0.0d+0 + do 884 i=1,n + if(ibloc(i).gt.0)go to 884 + aa=g(i) + if(x(i)-binf(i).le.epsx(i)) aa=min(0.0d+0,aa) + if(bsup(i)-x(i).le.epsx(i)) aa=max(0.0d+0,aa) + znglib=znglib+aa**2 +884 continue + znglib=sqrt(znglib) + if(ired.eq.1)zngred=znglib + if(irit.eq.1)zngrit=znglib + go to 200 +c +c fin des calculs +900 if(indrl.eq.0)indgc=0 + if(indgc.eq.1.and.indrl.le.0) indgc=indrl + if(imp.gt.0) then + write(bufstr,123)indgc + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + if(imp.ge.1.and.indrl.le.zero) then + write(bufstr,1910) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + write(bufstr,1911) indrl + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1910 format(' arret impose par la recherche lineaire. cf notice rlbd') +1911 format(' indicateur de rlbd=',i6) + if(imp.ge.1) then + write(bufstr,950)f,difg,nap,iter,indgc + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +950 format(' f,norme grad,nap,iter,indgc=',2e11.4,3i6) +c +c autres impressions finales + if(indgc1.lt.100) return + zrl=0. + if(iter.gt.0) zrl=dble(nap)/dble(iter) +2000 format(' nom n f norm2g nf iter rl/it ', + & ' irl cpu cycl red') + + write(bufstr,2001)nomf,f,difg,nap,iter,zrl,irl + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +2001 format(1x,a6,2e11.4,2i5,f6.2,i5) + end diff --git a/modules/optimization/src/fortran/zgcbd.lo b/modules/optimization/src/fortran/zgcbd.lo new file mode 100755 index 000000000..87e085869 --- /dev/null +++ b/modules/optimization/src/fortran/zgcbd.lo @@ -0,0 +1,12 @@ +# src/fortran/zgcbd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zgcbd.o' + +# Name of the non-PIC object +non_pic_object=none + diff --git a/modules/optimization/src/fortran/zqnbd.f b/modules/optimization/src/fortran/zqnbd.f new file mode 100755 index 000000000..771c93b8d --- /dev/null +++ b/modules/optimization/src/fortran/zqnbd.f @@ -0,0 +1,697 @@ +c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab +c Copyright (C) INRIA +c +c This file must be used under the terms of the CeCILL. +c This source file is licensed as described in the file COPYING, which +c you should have received as part of this distribution. The terms +c are also available at +c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt +c + subroutine zqnbd(indqn,simul,dh,n,binf,bsup,x,f,g,zero,napmax, + &itmax,indic,izig,nfac,imp,io,epsx,epsf,epsg,x1,x2,g1,dir,df0, + &ig,in,irel,izag,iact,epsrel,ieps1,izs,rzs,dzs) +c + implicit double precision (a-h,o-z) + real rzs(*) + double precision dzs(*) + character bufstr*(4096) + dimension x1(n),x2(n),g1(n),dir(n),epsx(n) + dimension binf(n),bsup(n),x(n),g(n),dh(*),indic(n),izig(n), + &izs(*) + external simul,proj +c + if(imp.lt.4)go to 3 + write(bufstr,1020)izag,ig,in,irel,iact,epsrel + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +1020 format(' qnbd : izag,ig,in,irel,iact,epsrel=',5i3,f11.4) +c + if(ig.eq.1) then + write(bufstr,110) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +110 format(' test sur gradient pour sortie ib') + if(in.eq.1) then + write(bufstr,111) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +111 format(' test sur nombre de defactorisations pour sortie ib') + if(izag.ne.0) then + write(bufstr,112)izag + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +112 format(' memorisation de variables izag=',i3) + if(irel.eq.1) then + write(bufstr,114)epsrel + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +114 format(' methode de minimisations incompletes ; epsrel=',d11.4) + if(iact.eq.1) then + write(bufstr,116) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +116 format(' blocage des variables dans ib') + if(ieps1.eq.1) then + write(bufstr,118) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +118 format(' parametre eps1 nul') + if(ieps1.eq.2) then + write(bufstr,119) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +119 format(' parametre eps1 grand') +c +c cscal1 utilise pour calculer eps(x) = eps1 cf avant 310 + cscal1=1.0d+8 + if(ieps1.eq.2) then + write(bufstr,120)cscal1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +120 format(' parametre eps1=eps(x) calcule avec cscal1=',d11.4) +3 continue +c + difg0=1.0d+0 + difg1=0.0d+0 +c +c eps0 sert a partitionner les variables + eps0=0.0d+0 + do 5 i=1,n + izig(i)=0 +5 eps0=eps0+epsx(i) + eps0=10.*eps0/n +c +c section 1 mise en forme de dh +c si indqn=1 on init dh a ident puis scal a it=2 +c + call proj(n,binf,bsup,x) + ndh=n*(n+1)/2 + if(indqn.eq.1)go to 10 + if(indqn.eq.2)go to 30 +c erreur + if(imp.gt.0) then + write(bufstr,105)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +105 format(' qnbd : valeur non admissible de indqn ',i5) + indqn=-105 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +10 continue +c on initialise dh a l identite puis a l iteration 2 +c on met a l echelle + nfac=0 + do 11 i=1,n +11 indic(i)=i + do 12 i=1,ndh +12 dh(i)=0.0d+0 +30 continue +c +c section 2 mise a jour dh +c +c iter nombre d iterations de descente + iter=0 + scal=1.0d+0 + nap=1 + indsim=4 + if(indqn.eq.1) call simul(indsim,n,x,f,g,izs,rzs,dzs) + if(indsim.le.0)then + indqn=-1 + if(indsim.eq.0)indqn=0 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +123 format(' qnbd : indqn=',i8) + return + endif + if(indqn.ne.1)go to 200 +c mise a echelle dh +c df0 decroissance prevue . si mod quad df0=((dh)-1g,g)/2 +c et on cherche dh diag de la forme cst/(dx)**2 +c d ou cst=som((y(i)*(dx))**2))/(2*df0) + cof1=0.0d+0 + do 80 i=1,n +80 cof1=cof1+(g(i)*epsx(i))**2 + cof1=cof1/(2.0d+0*df0) + i1=-n + do 82 i=1,n + i1=i1+n+2-i +82 dh(i1)=(cof1 + zero)/(epsx(i)**2 + zero) + iconv=0 +200 iter=iter +1 + if(iter.le.itmax)go to 202 + if(imp.gt.0) then + write(bufstr,1202) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1202 format(' qnbd : maximum d iterations atteint') + indqn=5 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +202 if(imp.ge.2) then + write(bufstr,1210)iter,f + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1210 format(' qnbd : iter=',i3,' f=',d15.7) +c x1,g1 valeurs a l iteration precedente + if(iter.eq.1)go to 300 + cof1=0.0d+0 + do 201 i=1,n + x1(i)=x(i)-x1(i) + g1(i)=g(i)-g1(i) +201 cof1=cof1 + x1(i)*g1(i) + if(cof1.le.zero)go to 250 + if(iter.gt.2.or.indqn.ne.1)go to 250 +c mise a l echelle de dh par methode shanno-phua +c dh=(y,y)/(y,s)*id + cof2=0.0d+0 + do 203 i=1,n +203 cof2=cof2 + g1(i)**2 + cof2=cof2/cof1 + if(imp.gt.3) then + write(bufstr,1203)cof2 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1203 format(' qnbd : facteur d echelle=',d11.4) + dh(1)=cof2 + i1=1 + do 205 i=1,nfac + i1=i1+n+1-i +205 dh(i1)=cof2 +c +c scal= (y,s)/(y,y) +c scal sert de coeff a g dans le calcul de dir pour i dans ib + scal=1.0d+0/cof2 +250 continue +c +c mise a jour dh par methode bfgs (majour) si iter ge 2 +c dh1=dh +y*yt/(y,s) - dh*s*st*dh/(s,dh*s) +c exprimons ds=x1 et y=g1 dans les nouv variables soit x2 et g1 + do 251 i=1,n + i1=indic(i) + x2(i1)=g1(i) +251 dir(i1)=x1(i) + do 252 i=1,n +252 g1(i)=x2(i) + do 253 i=1,n + i1=indic(i) +253 x2(i1)=x1(i) +c on stocke d abord dh*s dans x2 +c calcul des nfac premieres variables,en deux fois + continue + if(nfac.eq.0) go to 2312 + if(nfac.gt.1) go to 2300 + dir(1)=dir(1)*dh(1) + go to 2312 +2300 continue + np=nfac+1 + ii=1 + n1=nfac-1 + do 2303 i=1,n1 + y=dir(i) + if(dh(ii).eq.0.0d+0) go to 2302 + ij=ii + ip=i+1 + do 2301 j=ip,nfac + ij=ij+1 +2301 y=y+dir(j)*dh(ij) +2302 dir(i)=y*dh(ii) +2303 ii=ii+np-i + dir(nfac)=dir(nfac)*dh(ii) + do 2311 k=1,n1 + i=nfac-k + ii=ii-np+i + if(dir(i).eq.0.0d+0) go to 2311 + ip=i+1 + ij=ii + y=dir(i) + do 2310 j=ip,nfac + ij=ij+1 +2310 dir(j)=dir(j)+dh(ij)*dir(i) +2311 continue +2312 continue + nfac1=nfac+1 + n2fac=(nfac*nfac1)/2 + nnfac=n-nfac + k=n2fac + if(nfac.eq.n)go to 268 + do 255 i=nfac1,n +255 dir(i)=0.0d+0 + if(nfac.eq.0)go to 265 + do 260i=1,nfac + do 260j=nfac1,n + k=k+1 + if(x2(j).eq.0.)go to 260 + dir(i)= dir(i) + dh(k)*x2(j) +260 continue +c calcul autres comp de dh*s=d en deux fois + k=n2fac + do 264 j=1,nfac + do 264 i=nfac1,n + k=k+1 + dir(i)=dir(i) + dh(k)*x2(j) +264 continue +265 continue + k=n2fac+nfac*nnfac + do 266 j=nfac1,n + do 266 i=j,n + k=k+1 + if(x2(j).eq.0.)go to 266 + dir(i)=dir(i) + dh(k)*x2(j) +266 continue + if(nfac.eq.n-1)go to 268 + nm1=n-1 + k=n2fac+nfac*nnfac + do 267 i=nfac1,nm1 + k=k+1 + i1=i+1 + do 267 j=i1,n + k=k+1 + if(x2(j).eq.0.)go to 267 + dir(i)=dir(i)+dh(k)*x2(j) +267 continue +c calcul de dh*s fini +c calcul sig1 pour 2eme mise a jour +268 sig1=0.0d+0 + do 271 i=1,n +271 sig1=sig1+dir(i)*x2(i) + if(sig1.gt.0.0d+0)go to 272 + if(imp.gt.2) then + write(bufstr,1272)sig1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1272 format(' qnbd : pb (bs,s) negatif=',d11.4) +c +c ****************************************************** + indqn=8 + if(iter.eq.1)indqn=-5 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +272 sig1=-1.0d+0/sig1 +c truc powell si (y,s) negatif + if(cof1.gt.zero)go to 277 + if(imp.gt.2) then + write(bufstr,1270)cof1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1270 format(' qnbd : emploi truc powell (y,s)=',d11.4) + teta=-1.0d+0/sig1 + teta=.8*teta/(teta-cof1) + teta1=1.0d+0-teta + do 274 i=1,n +274 g1(i)=teta*g1(i)+teta1*dir(i) + cof1=-.2/sig1 +277 continue +c +c premiere mise a jour de dh + sig=1.0d+0/cof1 + zsig1=1.0d+0/sig1 + mk=0 + ir=nfac + epsmc=1.0d-9 + call calmaj(dh,n,g1,sig,x2,ir,mk,epsmc,nfac) + if(ir.ne.nfac)go to 280 + call calmaj(dh,n,dir,sig1,x2,ir,mk,epsmc,nfac) + if(ir.ne.nfac)go to 280 + go to 300 +280 if(imp.gt.0) then + write(bufstr,282) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +282 format(' qnbd : pb dans appel majour') + indqn=8 + if(iter.eq.1)indqn=-5 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +300 continue +c +c section 3 determination des variables libres et bloquees +c +c calcul eps1 +c + scal1=scal + if(ieps1.eq.1)scal1=0.0d+0 + if(ieps1.eq.2)scal1=scal*cscal1 +305 do 310 i=1,n +310 x1(i)=x(i)-scal1*abs(g(i))*g(i) + call proj(n,binf,bsup,x1) + eps1=0.0d+0 + do 320 i=1,n +320 eps1=eps1 + abs(x1(i)-x(i)) + eps1=min(eps0,eps1) + if(ieps1.eq.1)eps1=0.0d+0 + if(ieps1.eq.2)eps1=eps1*1.0d+4 + if(imp.gt.3) then + write(bufstr,322)eps1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +322 format(' qnbd : val de eps1 servant a partitionner les variables' + &,d11.4) +c nfac nombre de lignes factorisees (nr pour ajour) + ifac=0 + idfac=0 + k=0 +c +c + gr=0.0d+0 + if(ig.eq.1)gr=0.2*difg/n + n3=n + if(in.eq.1)n3=n/10 +c si irit=1 on peut relacher des variables + irit=0 + if(difg1.le.epsrel*difg0)irit=1 + if(irel.eq.0.or.iter.eq.1)irit=1 + if(irit*irel.gt.0.and.imp.gt.3) then + write(bufstr,1320)difg0,epsrel,difg1 + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1320 format(' qnbd : redemarrage ; difg0,epsrel,difg1=',3d11.4) +c + tiers=1.0d+0/3.0d+0 + do 340 k=1,n + izig(k)=izig(k)-1 + if(izig(k).le.0)izig(k)=0 + bi=binf(k) + bs=bsup(k) + ic=indic(k) + d1=x(k)-bi + d2=bs-x(k) + dd=(bs-bi)*tiers + ep=min(eps1,dd) + if(d1.gt.ep)go to 324 + if(g(k).gt.0.)go to 330 + go to 335 +324 if(d2.gt.ep)go to 335 + if(g(k).gt.0.)go to 335 + go to 330 +c on defactorise si necessaire +330 continue + if(ic.gt.nfac)go to 340 + idfac=idfac+1 + mode=-1 + if(imp.ge.4) then + write(bufstr,336)k + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +336 format(' defactorisation de ',i3) + izig(k)=izig(k) + izag + call ajour(mode,n,k,nfac,dh,x2,indic) + if(mode.eq.0) go to 340 + if(imp.gt.0) then + write(bufstr,333)mode + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +333 format(' qnbd : pb dans ajour. mode=',i3) + indqn=8 + if(iter.eq.1)indqn=-5 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +c on factorise +335 continue + if(irit.eq.0)go to 340 + if(ic.le.nfac)go to 340 + if(izig(k).ge.1)go to 340 + mode=1 + if(ifac.ge.n3.and.iter.gt.1)go to 340 + if(abs(g(k)).le.gr)go to 340 + ifac=ifac+1 + if(imp.ge.4) then + write(bufstr,339)k + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +339 format(' on factorise l indice ',i3) + call ajour(mode,n,k,nfac,dh,x2,indic) + if(mode.eq.0)go to 340 + if(imp.gt.0) then + write(bufstr,333)mode + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + indqn=8 + if(iter.eq.1)indqn=-5 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +340 continue + if(imp.ge.2) then + write(bufstr,350)ifac,idfac,nfac + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +350 format(' qnbd : nbre fact',i3,' defact',i3, + &' total var factorisees',i3) +c +c *********************************************** a voir + if(iconv.eq.1)return +c +c section 6 resolution systeme lineaire et expression de dir +c on inverse le syst correspondant aux nl premieres composantes +c dans le nouveau syst d indices + ir=nfac + do 640 i=1,n + i1=indic(i) +640 x2(i1)=g(i) +641 continue + if(ir.lt.nfac) go to 412 + if(nfac.gt.1) go to 400 + x2(1)=x2(1)/dh(1) + go to 412 +400 continue + do 402 i=2,nfac + ij=i + i1=i-1 + v=x2(i) + do 401 j=1,i1 + v=v-dh(ij)*x2(j) +401 ij=ij+nfac-j + x2(i)=v +402 x2(i)=v + x2(nfac)=x2(nfac)/dh(ij) + np=nfac+1 + do 411 nip=2,nfac + i=np-nip + ii=ij-nip + v=x2(i)/dh(ii) + ip=i+1 + ij=ii + do 410 j=ip,nfac + ii=ii+1 +410 v=v-dh(ii)*x2(j) +411 x2(i)=v +412 continue + if(ir.eq.nfac)go to 660 + if(imp.gt.0) then + write(bufstr,650) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +650 format(' qnbd : pb num dans mult par inverse') + indqn=7 + if(iter.eq.1)indqn=-6 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +660 continue + do 610 i=1,n + i1=indic(i) + dir(i)=-g(i)*scal +610 if(i1.le.nfac) dir(i)=-x2(i1) + continue +c +c gestion contraintes actives (si iact=1) + if(iact.ne.1)go to 675 + do 670 i=1,n + if(izig(i).gt.0)dir(i)=0. + if(indic(i).gt.nfac)dir(i)=0.0d+0 +670 continue +675 continue +c +c recherche lineaire +c conservation de x et g . calcul de dir+ et fpn + do 700 i=1,n + g1(i)=g(i) +700 x1(i)=x(i) +c ifp =1 si fpn trop petit. on prend alors d=-g + ifp=0 + fn=f +709 fpn=0.0d+0 + do 710 i=1,n + if(x(i)-binf(i).le.epsx(i).and.dir(i).lt.0.)dir(i)=0.0d+0 + if(bsup(i)-x(i).le.epsx(i).and.dir(i).gt.0.)dir(i)=0.0d+0 +710 fpn=fpn + g(i)*dir(i) + if(fpn.gt.0.0d+0) then + if(ifp.eq.1) then + if(imp.gt.0) then + write(bufstr,1705) fpn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1705 format(' qnbd : arret fpn non negatif=',d11.4) + indqn=6 + if(iter.eq.1)indqn=-3 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + else + ifp=1 + do 707 i=1,n +707 if(izig(i).gt.0)dir(i)=-scal*g(i) + irit=1 + go to 709 + endif + endif +c calcul du t initial suivant une idee de fletcher + t1=t + if(iter.eq.1) diff=df0 + t=-2.0d+0*diff/fpn + if(t.gt.0.30d+0.and.t.lt.3.0d+0)t=1.0d+0 + if(eps1.lt.eps0)t=1.0d+0 + if(indqn.eq.2)t=1.0d+0 + if(iter.gt.1.and.t1.gt.0.010d+0.and.t1.lt.100.0d+0)t=1.0d+0 + tmax=1.0d+10 + t=min(t,tmax) + t=max(t,10.*zero) +c amd,amf tests sur h'(t) et diff + amd=.7 + amf=.1 + napm=15 + napm1=nap + napm + if(napm1.gt.napmax)napm1=napmax + call rlbd(indrl,n,simul,x,binf,bsup,fn,fpn,t,tmax,dir,g, + & tproj,amd,amf,imp,io,zero,nap,napm1,x2,izs,rzs,dzs) + if(indrl.ge.10)then + indsim=4 + nap=nap + 1 + call simul(indsim,n,x,f,g,izs,rzs,dzs) + if(indsim.le.0)then + indqn=-3 + if(indsim.eq.0)indqn=0 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + endif + endif + if(indrl.le.0)then + indqn=10 + if(indrl.eq.0)indqn=0 + if(indrl.eq.-3)indqn=13 + if(indrl.eq.-4)indqn=12 + if(indrl.le.-1000)indqn=11 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + endif +c +753 if(imp.lt.6)go to 778 + do 760 i=1,n +760 write(bufstr,777)i,x(i),g(i),dir(i) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) +777 format(' i=',i2,' xgd ',3f11.4) +c +778 continue + if(nap.lt.napmax)go to 758 + f=fn + if(imp.gt.0) then + write(bufstr,755)napmax + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +755 format(' qnbd : retour cause max appels simul',i9) + indqn=4 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +758 continue +c section 8 test de convergence +c + do 805 i=1,n + if(abs(x(i)-x1(i)).gt.epsx(i))go to 806 +805 continue + f=fn + if(imp.gt.0) then + write(bufstr,1805) + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1805 format(' qnbd : retour apres convergence de x') + indqn=3 + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return +806 continue + difg=0.0d+0 + do 810 i=1,n + aa=g(i) + if(x(i)-binf(i).le.epsx(i))aa=min(0.0d+0,aa) + if(bsup(i)-x(i).le.epsx(i))aa=max(0.0d+0,aa) +810 difg=difg + aa**2 + difg1=0.0d+0 + do 820 i=1,n + if(indic(i).gt.nfac)go to 820 + aa=g(i) + if(x(i)-binf(i).le.epsx(i))aa=min(0.0d+0,aa) + if(bsup(i)-x(i).le.epsx(i))aa=max(0.0d+0,aa) + difg1=difg1 + aa**2 +820 continue + difg1=sqrt(difg1) + difg=sqrt(difg) + difg=difg/sqrt(real(n)) + diff=abs(f-fn) + df0=-diff + if(irit.eq.1)difg0=difg1 + f=fn + if(imp.ge.2) then + write(bufstr,860)epsg,difg,epsf,diff,nap + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +860 format(' qnbd : epsg,difg=',2d11.4,' epsf,diff=',2d11.4 + &,' nap=',i3) + if(diff.lt.epsf)then + indqn=2 + if(imp.gt.0) then + write(bufstr,1865)diff + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1865 format(' qnbd : retour cause decroissance f trop petite=',d11.4) + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + endif + if(difg.gt.epsg)go to 200 + indqn=1 + if(imp.gt.0) then + write(bufstr,1900)difg + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif +1900 format(' qnbd : retour cause gradient projete petit=',d11.4) + if(imp.gt.0) then + write(bufstr,123)indqn + call basout(io_out ,io ,bufstr(1:lnblnk(bufstr))) + endif + return + end diff --git a/modules/optimization/src/fortran/zqnbd.lo b/modules/optimization/src/fortran/zqnbd.lo new file mode 100755 index 000000000..4d03119f7 --- /dev/null +++ b/modules/optimization/src/fortran/zqnbd.lo @@ -0,0 +1,12 @@ +# src/fortran/zqnbd.lo - a libtool object file +# Generated by libtool (GNU libtool) 2.4.2 +# +# Please DO NOT delete this file! +# It is necessary for linking the library. + +# Name of the PIC object. +pic_object='.libs/zqnbd.o' + +# Name of the non-PIC object +non_pic_object=none + |